getdp-2.4.2-source/README.txt000644 001750 001750 00000005635 12010200205 017265 0ustar00geuzainegeuzaine000000 000000 This is GetDP, a General environment for the treatment of Discrete Problems. GetDP is distributed under the terms of the GNU General Public License, Version 2 or later. See doc/LICENSE.txt and doc/CREDITS.txt for more information. See the doc/ and demos/ directories for documentation. The reference manual is located in doc/texinfo/. See the web site http://geuz.org/getdp for additional examples. Building a bare-bones version of GetDP from its source code requires a C++ compiler and CMake (http://cmake.org). By default GetDP also uses the GSL (http://www.gnu.org/software/gsl) and PETSc (http://www.mcs.anl.gov/petsc), using either real or complex arithmetic. If PETSc is available, GetDP can use SLEPc (http://www.grycap.upv.es/slepc) to solve eigenvalue problems. Instead of PETsc (and SLEPc), GetDP can also use a built-in set of linear solvers derived from Sparskit Version 2 (http://www-users.cs.umn.edu/~saad/) and eigensolvers from Arpack (http://www.caam.rice.edu/software/ARPACK). Sparskit and Arpack, as well GetDP's special mathematical functions require a Fortan compiler and BLAS/LAPACK. Build GetDP using CMake's graphical user interface ------------------------------------------------- * Launch CMake and fill-in the two top input fields (telling where the GetDP source directory is located and where you want the GetDP binary to be created). * Click on "Add entry" and define the variable CMAKE_PREFIX_PATH, of type "PATH", pointing to the location(s) of any external package(s) (BLAS/LAPACK, etc.) installed in non-standard directories. * Click on "Configure" and choose your compiler. * Optionally change some configuration options (re-run "Configure" every time you change some options). * Once you are happy with all the configuration options, click on "Generate". * Go to the build directory and build Gmsh using your chosen compiler. Build GetDP from the command line -------------------------------- * Create a build directory, for example as a subdirectory of GetDP's source directory: mkdir build * Run cmake from within the build directory, pointing to GetDP's source directory: cd build cmake .. * To build and install GetDP then simply type make make install * To change build options you can use "ccmake" instead of "cmake", e.g.: ccmake .. or you can specify options directly on the command line. For example, you can use cmake -DCMAKE_PREFIX_PATH=/opt/local .. to specify the location of external packages installed in non-standard directories. You can use cmake -DCMAKE_INSTALL_PREFIX=/opt to change the installation directory. Or you can use cmake -DENABLE_PETSC=0 -DENABLE_SPARSKIT=1 .. to build a version of GetDP that uses Sparskit instead of PETSc. * You can keep multiple builds with different build options at the same time: just configure the builds in separate directories. * To see a detailed compilation log use make VERBOSE=1 getdp-2.4.2-source/utils/misc/onelab_sync.sh000755 001750 001750 00000000564 12210577720 022536 0ustar00geuzainegeuzaine000000 000000 #!/bin/sh SRC=../../benchmarks DST=/onelab_files MODELS='machines relay inductor' # sync files from local svn checkout for m in ${MODELS}; do sudo rsync -avz ${SRC}/${m} ${DST} --delete --exclude .svn done # create zip file for m in ${MODELS}; do cd ${DST} && sudo zip -r ${DST}/${m}.zip ${m} -x \*.svn\* done # fix permissions sudo chown -R onelab:onelab ${DST}/ getdp-2.4.2-source/utils/misc/getdp_framework.plist000644 001750 001750 00000001040 12010200204 024100 0ustar00geuzainegeuzaine000000 000000 CFBundleNameGetDP CFBundleExecutableGetDP CFBundlePackageTypeFMWK CFBundleVersionGETDP_VERSION CFBundleSignatureGETDP CFBundleIdentifierorg.geuz.GetDP getdp-2.4.2-source/utils/misc/onelab_screenshot.sh000755 001750 001750 00000000313 12205340467 023727 0ustar00geuzainegeuzaine000000 000000 #!/bin/sh if [ $# -lt 1 ]; then echo "Usage: $0 number" 1>&2; exit 1; fi NUMBER=$1 screencapture -Wi screenshot${NUMBER}.png convert -scale 512 screenshot${NUMBER}.png screenshot${NUMBER}_512.png getdp-2.4.2-source/utils/misc/update_copyright.sh000755 001750 001750 00000000544 12116424200 023577 0ustar00geuzainegeuzaine000000 000000 #!/bin/sh - files=`find ../.. -not -path "*.svn*" -and -not -path "*lib*" -and -not -path "*bin*" -and -not -name "update_copyright.sh" | xargs grep 'Copyright (C) 1997-2012 P. Dular, C. Geuzaine' -sl` echo $files for file in $files do sed "s|(C) 1997-2012 P|(C) 1997-2013 P|g" $file > $file.tmp echo modified $file rm -f $file mv $file.tmp $file done getdp-2.4.2-source/utils/misc/pyram.c000644 001750 001750 00000002627 11266605602 021202 0ustar00geuzainegeuzaine000000 000000 /* $Id: pyram.c,v 1.1 2008-07-10 10:27:47 geuzaine Exp $ */ /* Calcul des points de Gauss pour une pyramide cf. ../Integration/Gauss_Pyramid.h ref.: Coulomb et al., IEEE tr.mag. 32(3) May 1996, p.1395 Note: Pyramid de reference de sommets [(0,0,0),(1,0,0),(0,1,0),(0,0,1)] a la difference de l'article de Coulomb */ #include "stdlib.h" #include "math.h" #include "../Integration/Gauss_Quadrangle.h" /* double x[1] = {0.75}; double b[1] = {0.33}; */ double x[2] = {0.455848155988775, 0.877485177344559}; double b[2] = {0.100785882079825, 0.232547451253508}; /* double x[4] = {0.204148582103227, 0.482952704895632, 0.761399262448138, 0.951499450553003}; double b[4] = {0.010352240749918, 0.068633887172923, 0.143458789799214, 0.110888415611278}; */ void printout(int i, double * s, char * item){ int m; printf("double %s%d[%d] = {",item,i,i); for(m=0 ; m. set(CTEST_PROJECT_NAME "GetDP") set(CTEST_DROP_METHOD "http") set(CTEST_DROP_SITE_CDASH TRUE) set(CTEST_DROP_SITE "onelab.info") set(CTEST_DROP_LOCATION "/CDash/submit.php?project=GetDP") set(CTEST_TRIGGER_SITE "") set(SITE ${GETDP_HOST}) set(BUILDNAME "${GETDP_OS}-${GETDP_PACKAGER}") getdp-2.4.2-source/doc/VERSIONS.txt000644 001750 001750 00000013001 12221300353 020340 0ustar00geuzainegeuzaine000000 000000 2.4.2: fixed function arguments in nested expressions; minor improvements. 2.4.1: minor improvements and bug fixes. 2.4.0: new two-step Init constraints; faster network computation (with new -cache); improved Update operation; better cpu/memory reporting; new -setnumber, -setstring and -gmshread command line options; accept unicode file paths on Windows; small bug fixes. 2.3.1: updated onelab; small bug fixes. 2.3.0: moved build system from autoconf to cmake; new family of Field functions to use data imported from Gmsh; improved list handling; general code cleanup. 2.2.1: cleaned up nonlinear convergence tests and integrated experimental adaptive time loop code; small bug fixes. 2.2.0: new solver interface based on ONELAB; parallel SLEPC eigensolvers; cleaned up syntax for groups, moving band and global basis functions; new Field[] functions to interpolate post-processing datasets from Gmsh; fixed bug in Sur/Lin transformation of 2 forms; fixed bug for periodic constraints on high-order edge elements. 2.1.0: parallel resolution using PETSc solvers; new Gmsh2 output format; new experimental SLEPc-based eigensolvers; various bug and performance fixes (missing face basis functions, slow PETSc assembly with global quantities, ...) 2.0.0: general code cleanup (separated interface from legacy code; removed various undocumented, unstable and otherwise experimental features; moved to C++); updated input file formats; default solvers are now based on PETSc; small bug fixes (binary .res read, Newmark -restart). 1.2: Windows versions do not depend on Cygwin anymore; major parser cleanup (loops & co). 1.1: New eigensolver based on Arpack (EigenSolve); generalized old Lanczos solver to work with GSL+lapack; reworked PETSc interface, which now requires PETSc 2.3; documented many previously undocumented features (loops, conditionals, strings, link constraints, etc.); various improvements and bug fixes. 1.0: New license (GNU GPL); added support for latest Gmsh mesh file format; more code cleanups. 0.91: Merged moving band and multi-harmonic code; new loops and conditionals in the parser; removed old readline code (just use GNU readline if available); upgraded to latest Gmsh post-processing format; various small enhancements and bug fixes. 0.89: Code cleanup. 0.88: Integrated FMM code. 0.87: Fixed major performance problem on Windows (matrix assembly and post-processing can be up to 3-4 times faster with 0.87 compared to 0.86, bringing performance much closer to Unix versions); fixed stack overflow on Mac OS X; Re-introduced face basis functions mistakenly removed in 0.86; fixed post-processing bug with pyramidal basis functions; new build system based on autoconf. 0.86: Updated Gmsh output format; many small bug fixes. 0.85: Upgraded communication interface with Gmsh; new ChangeOfValues option in PostOperation; many internal changes. 0.84: New ChangeOfCoordinate option in PostOperation; fixed crash in InterpolationAkima; improved interactive postprocessing (-ipos); changed syntax of parametric OnGrid ($S, $T -> $A, $B, $C); corrected Skin for non simplicial meshes; fixed floating point exception in diagonal matrix scaling; many other small fixes and cleanups. 0.83: Fixed bugs in SaveSolutions[] and InitSolution[]; fixed corrupted binary post-processing files in the harmonic case for the Gmsh format; output files are now created relatively to the input file directory; made solver options available on the command line; added optional matrix scaling and changed default parameter file name to 'solver.par' (Warning: please check the scaling definition in your old SOLVER.PAR files); generalized syntax for lists (start:[incr]end -> start:end:incr); updated reference guide; added a new short presentation on the web site; OnCut -> OnSection; new functional syntax for resolution operations (e.g. Generate X -> Generate[X]); many other small fixes and cleanups. 0.82: Added communication socket for interactive use with Gmsh; corrected (again) memory problem (leak + seg. fault) in time stepping schemes; corrected bug in Update[]. 0.81: Generalization of transformation jacobians (spherical and rectangular, with optional parameters); changed handling of missing command line arguments; enhanced Print OnCut; fixed memory leak for time domain analysis of coupled problems; -name option; fixed seg. fault in ILUK. 0.80: Fixed computation of time derivatives on first time step (in post-processing); added tolerance in transformation jacobians; fixed parsing of DOS files (carriage return problems); automatic memory reallocation in ILUD/ILUK. 0.79: Various bug fixes (mainly for the post-processing of intergal quantities); automatic treatment of degenerated cases in axisymmetrical problems. 0.78: Various bug fixes. 0.77: Changed syntax for PostOperations (Plot suppressed in favour of Print; Plot OnRegion becomes Print OnElementsOf); changed table oriented post-processing formats; new binary formats; new error diagnostics. 0.76: Reorganized high order shape functions; optimization of the post-processing (faster and less bloated); lots of internal cleanups. 0.74: High order shape functions; lots of small bug fixes. 0.73: Eigen value problems (Lanczos); minor corrections. 0.7: constraint syntax; fourier transform; unary minus correction; complex integral quantity correction; separate iteration matrix generation. 0.6: Second order time derivatives; Newton nonlinear scheme; Newmark time stepping scheme; global quantity syntax; interactive post-processing; tensors; integral quantities; post-processing facilities. 0.3: First distributed version. getdp-2.4.2-source/doc/getdp.html000644 001750 001750 00000021411 12221301111 020315 0ustar00geuzainegeuzaine000000 000000 GetDP: a General Environment for the Treatment of Discrete Problems

GetDP: a General Environment for the Treatment of Discrete Problems

Patrick Dular and Christophe Geuzaine

Version 2.4.2, September 27 2013

Description | Download | Authors and credits | Documentation | Licensing | Links

Description

GetDP is a general finite element solver using mixed elements to discretize de Rham-type complexes in one, two and three dimensions. The main feature of GetDP is the closeness between the input data defining discrete problems (written by the user in ASCII data files) and the symbolic mathematical expressions of these problems.

For example, to solve the Poisson equation div(a grad(v)) = f on a domain D, an input file (".pro" file) would contain something like this:

  FunctionSpace {
    { Name H1; Type Form0; 
      BasisFunction {
        { Name sn; NameOfCoef vn; Function BF_Node; Support D; Entity NodesOf[All]; }
      }
    }
  }
  Formulation{
    { Name Poisson; Type FemEquation;
      Quantity { 
        { Name v; Type Local; NameOfSpace H1; }
      }
      Equation {
        Galerkin { [ a[] * Dof{d v}, {d v} ] ; In D; Jacobian V; Integration I; }
        Galerkin { [ f[], {v} ] ; In D; Jacobian V; Integration I; }
      }
    }
  }
i.e., a direct transcription of the discrete function space and weak form of the problem.

See GetDP's reference manual for a more thorough overview of GetDP's capabilities.

Download

GetDP is distributed under the terms of the GNU General Public License (GPL): If you use GetDP please cite one of the references in your work (books, articles, reports, etc.).

Authors and credits

GetDP is developed by Patrick Dular and Christophe Geuzaine (both with the University of Liège). The CREDITS file has more information.

Please use the public mailing list getdp@geuz.org to send questions or ask for help. If you think you have found a bug in the program, you can file a report directly here (username: getdp, password: getdp).

Documentation

   

Licensing

GetDP is copyright (C) 1997-2013 by P. Dular and C. Geuzaine and is distributed under the terms of the GNU General Public License (GPL).

In short, this means that everyone is free to use GetDP and to redistribute it on a free basis. GetDP is not in the public domain; it is copyrighted and there are restrictions on its distribution (see the license and its associated FAQ). For example, you cannot integrate this version of GetDP (in full or in parts) in any closed-source software you plan to distribute (commercially or not). If you want to integrate parts of GetDP into a closed-source software, or want to sell a modified closed-source version of GetDP, you will need to obtain a different license. Please contact us directly for more information.

Links

Back to geuz.org getdp-2.4.2-source/doc/getdp.1000644 001750 001750 00000013432 12166744451 017547 0ustar00geuzainegeuzaine000000 000000 .TH GetDP 1 "8 July 2013" "2.4" "GetDP Manual Pages" .UC 4 .\" ******************************************************************** .SH NAME GetDP \- a General environment for the treatment of Discrete Problems .\" ******************************************************************** .SH SYNOPSIS .B getdp [file] [options] .\" ******************************************************************** .SH DESCRIPTION \fIGetDP\fP is a general finite element solver using mixed elements to discretize de Rham-type complexes in one, two and three dimensions. The main feature of \fIGetDP\fP is the closeness between the input data defining discrete problems (written by the user in ASCII data files) and the symbolic mathematical expressions of these problems. .PP \fIGetDP\fP is a command-line program. See \fIGmsh\fP for a graphical front-end. .\" ******************************************************************** .SH WARNING This man page does not describe the syntax of the input files: you should refer to the info documentation for this (e.g. with \fBinfo getdp\fP). Up-to-date versions of the manual in various formats are available at \fIhttp://www.geuz.org/getdp/\fP. .\" ******************************************************************** .SH PROCESSING OPTIONS .TP 4 .B file is an ASCII file containing the problem definition, i.e., the structures the Texinfo documentation will teach you to create. This file can include other files, so that only one problem definition file should always be given on the command line. The input files containing the problem definition structure are usually given the \fI.pro\fP extension (if so, there is no need to specify the extension on the command line). The name of this file (without the extension) is used as a basis for the creation of intermediate files during the pre-processing and the processing stages. .TP 4 .B \-pre \fIresolution-id\fP performs the pre-processing associated with the resolution called \fIresolution-id\fP. In the pre-processing stage, \fIGetDP\fP creates the geometric database (from the mesh file), identifies the degrees of freedom (the unknowns) of the problem and sets up the constraints on these degrees of freedom. The pre-processing creates a file with a \fI.pre\fP extension. If \fIresolution-id\fP is omitted, the list of available choices is displayed. .TP 4 .B \-cal performs the processing. This requires that a pre-processing has been performed previously, or that a \fB\-pre\fP option is given on the same command line. The performed resolution is the one given as an argument to the \fB\-pre\fP option. In the processing stage, \fIGetDP\fP executes all the operations of the selected resolution (such as matrix assemblies, system resolutions, ...). The processing creates a file with a \fI.res\fP extension. .TP 4 .B \-pos \fIpost-operation-id\fP(s) performs the post-processing operations selected by the \fIpost-operation-id\fP(s). This requires that a processing has been performed previously, or that a \fB\-cal\fP option is given on the same command line. If \fIpost-operation-id\fP is omitted, the list of available choices is displayed. .TP 4 .B \-msh \fIfilename\fP reads the mesh database from \fIfilename\fP rather than reading it from the default problem file name with the \fI.msh\fP extension appended. .TP 4 .B \-restart resumes time loop processing from where it stopped. .TP 4 .B \-solve \fIresolution-id\fP same as \-pre \fIresolution-id\fP \-cal. .TP 4 .B \-split saves processing results in separate files (one for each timestep). .TP 4 .B \-res \fIfilename\fP(s) loads processing results from \fIfilename(s)\fP instead of from the default problem file name with the \fI.res\fP extension appended. .TP 4 .B \-name \fIstring\fP uses \fIstring\fP as the default generic file name for input or output of mesh, pre-processing and processing files. .TP 4 .B \-adapt \fIfilename\fP(s) reads adaptation constraints from \fIfilename(s)\fP. .TP 4 .B \-order \fIfloat\fP specifies maximum interpolation order. .\" ******************************************************************** .SH LINEAR SOLVER OPTIONS .TP 4 .B \-solver \fIfilename\fP specifies solver parameter file. .TP 4 .B [PETSc options] PETSc options (if GetDP was compiled with PETSc support). .\" ******************************************************************** .SH LINEAR SOLVER OPTIONS .TP 4 .B \-bin creates binary output files. .B \-v2 creates mesh-based Gmsh output files when possible .\" ******************************************************************** .SH OTHER OPTIONS .TP 4 .B \-check lets you check the problem structure interactively. .TP 4 .B \-v \fIint\fP sets the verbosity level. A value of 0 means that no information will be displayed during processing. Higher values increase the amount of information displayed. .TP 4 .B \-p \fIint\fP sets the progress update rate. This controls the refreshment rate of the counter indicating the progress of the current computation. .TP 4 .B \-onelab \fIname\fP \fIaddress\fP communicates with OneLab server through socket. .TP 4 .B \-version displays the version number. .TP 4 .B \-info displays detailed version information. .TP 4 .B \-help displays a message listing basic usage and available options. .PP .\" ******************************************************************** .SH AUTHORS Patrick Dular (patrick.dular at ulg.ac.be) and Christophe Geuzaine (cgeuzaine at ulg.ac.be). See the documentation for a comprehensive list of contributors. .\" ******************************************************************** .SH SEE ALSO .BR gmsh (1), .BR GetDP examples (\fI/usr/share/doc/getdp-*/\fR), .BR GetDP homepage (\fIhttp://www.geuz.org/getdp/\fR). .PP The full documentation for GetDP is maintained as a Texinfo manual. If the .B info and .B getdp programs are properly installed at your site, the command .IP .B info getdp .PP should give you access to the complete manual. getdp-2.4.2-source/doc/LICENSE.txt000644 001750 001750 00000043235 12010200205 020155 0ustar00geuzainegeuzaine000000 000000 GetDP is provided under the terms of the GNU General Public License (GPL), Version 2 or later. GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 51 Franklin St, 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. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, 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 software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, 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 redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's 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 give any other recipients of the Program a copy of this License along with the Program. 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 Program or any portion of it, thus forming a work based on the Program, 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) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, 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 Program, 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 Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) 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; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, 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 executable. 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. If distribution of executable or 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 counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program 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. 5. 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 Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program 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. 7. 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 Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program 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 Program. 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. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program 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. 9. The Free Software Foundation may publish revised and/or new versions of the 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 Program 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 Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, 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 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "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 PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. 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 PROGRAM 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 PROGRAM (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 PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 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 Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. 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 program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. getdp-2.4.2-source/doc/CREDITS.txt000644 001750 001750 00000004514 12205340471 020205 0ustar00geuzainegeuzaine000000 000000 GetDP is copyright (C) 1997-2013 Patrick Dular and Christophe Geuzaine Major code contributions to GetDP have been provided by Johan Gyselinck and Ruth Sabariego. Other code contributors include: Michael Asam, David Colignon, Tuan Ledinh, Patrick Lefevre, Andre Nicolet, Jean-Francois Remacle, Timo Tarhasaari, Christophe Trophime and Marc Ume. See the source code for more details. The AVL tree code (Common/avl.*) is copyright (C) 1988-1993, 1995 The Regents of the University of California. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that copyright notice and this permission notice appear in supporting documentation, and that the name of the University of California not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. The University of California makes no representations about the suitability of this software for any purpose. It is provided "as is" without express or implied warranty. This version of GetDP may contain code (in the contrib/Arpack subdirectory) written by Danny Sorensen, Richard Lehoucq, Chao Yang and Kristi Maschhoff from the Dept. of Computational & Applied Mathematics at Rice University, Houston, Texas, USA. See http://www.caam.rice.edu/software/ARPACK/ for more info. This version of GetDP may contain code (in the contrib/Sparskit subdirectory) copyright (C) 1990 Yousef Saad: check the configuration options. Thanks to the following folks who have contributed by providing fresh ideas on theoretical or programming topics, who have sent patches, requests for changes or improvements, or who gave us access to exotic machines for testing GetDP: Olivier Adam, Alejandro Angulo, Geoffrey Deliege, Mark Evans, Philippe Geuzaine, Eric Godard, Sebastien Guenneau, Francois Henrotte, Daniel Kedzierski, Samuel Kvasnica, Benoit Meys, Uwe Pahner, Georgia Psoni, Robert Struijs, Ahmed Rassili, Thierry Scordilis, Herve Tortel, Jose Geraldo A. Brito Neto, Matthias Fenner, Daryl Van Vorst, Guillaume Dem\'esy. getdp-2.4.2-source/doc/WELCOME.txt000644 001750 001750 00000002362 12010200205 020162 0ustar00geuzainegeuzaine000000 000000 This is GetDP, a General Environment for the Treatment of Discrete Problems. GetDP is distributed under the terms of the GNU General Public License. See the LICENSE.txt and CREDITS.txt files for more information. The demos/ directory contains a simple example. For more examples see the reference manual (http://geuz.org/getdp/doc/texinfo/) and the OneLab web site (http://onelab.info). Notes: * GetDP has no integrated graphical user interface: it is run from the command shell (terminal). * If you are looking for a graphical user interface to GetDP, download Gmsh (http://geuz.org/gmsh/). To launch GetDP via Gmsh, simply open Gmsh, go to the solver module and click on the GetDP button. The OneLab web site (http://onelab.info) has more info. * The problem definition files (".pro" files) are regular ASCII text files: you can create them with whatever text editor you prefer (Notepad, Wordpad, Emacs, etc.). * For Windows users: if you often use GetDP from the command (DOS) shell, you should probably consider installing a more powerful replacement. Amongst the many free alternatives, we recommend the rxvt shell in the cygwin environment (http://www.cygwin.com), which also provides all the necessary tools to compile GetDP. getdp-2.4.2-source/doc/texinfo/objects-wrap.pdf000644 001750 001750 00000071260 11266605602 023126 0ustar00geuzainegeuzaine000000 000000 %PDF-1.2 %쏢 4 0 obj <> stream xgq )S-$UeiWPVeÝl%VqT%m砟g,]xb=sxiF#|7?Ç~|Hcl?{Z<!~?ho7?~~ }z|?AW݇?/KG}_?o>#/?^?/K}i Jb&%,ďC}ǣhR~aM@W~R [?_| ?C|7+CN+||(~j'nRc̳/<<ܔ++7P<[\BGN 3(CV!Kkʐue҆Oe؃p,=*C!Kʐeҫ2dM YP,S8FP#*C!ʐźc22dM YΔe*CQw3*Cƙ!ʐee22dM.\ ʔe*,) +8+wpQ*CR!K)ʐdeR2d)QeȒ2dCc\ʨܔ!Kʐ%eȒ2dILY2dISs4!KʨԔ!Kʐ%|=|++o7#~8ex9mxڒtڤ|ڶrzv~qtytl+ǣK磓_k%]:|(s, 2E\\C e82v kcnW'*/YLr9esN>esԑ|1MkCk_kvMf3(_s-67*+Xk}5|>&*S[ {}~T,ٖd_Y~qml_% <=(ȿsfGrZ[Ve,i+==2=u1Zum淭W&I4bkʦ {A/M=Q=O6[ nYXç>Gr}|Rٹ 0cCFX!}dJUCpLr0SHǧ?hg`=%sf#YZbD=SgZ yVHhyVx~nw!^zV|${ c #|CRȓF|)]{3˲Yi{W Kȍw} Z훮kj>}9"'-T Krطh(S_ӗUkG7M;q!?oMK_N+= 0bY[O{Kf\ۍvr)g{˞O<_]s㫣2dAϘw*7#X"܌<Ϣ mt3:2֕ F6:9.Iڦٔq ܄+̼֕MaS'*6n"hG@Ścg|_z1=#z\_yj1Pmx^gqa26J~S&]x\<,Kp=1ǔecJ)rKYk8x3X|F4aStR0=_8咑RĀa =Cf^ i-gg-v74btђNM;:p '€B?-UXIb =و~5ߥjZe {!}eeIyƤBP8d65e,.R3&k3&ka9wܵ2Lϐqz˭3d\@!czb[ejo~p3m{,QlƲcȸs=SG!2L9뤜Op ^g) 7ژcȸ=6fkÞ!{̾=ﲵ>r3xW;r=}1PF^yl{/S|tcꖤ)W:oƭ\O:N >hm&ӆo C>8>uszt͜ØNp܎qd}0f8߭4&'TӖsrlfu̴J]51 l )w[cڜhtڛI26渼\ϸHL`g=V6؞q{&лY{ھɼ@>rrcد^xwY\i[Tli->b,X?$C*&S+K2g`3krj41eWmE4mͶ6$mGv`}v_[o9^6z6US}q$$6<l/ 4{X K6_>a̷eln]@8s\{343 wf3eh\)gpW.\m&币rnʐf7gh3Pǐf!cNʐ-fh+Hǐf!CF[18p ⼸@F[8)뙛Λg[!9vser<2:ΧL r;ey-:rO:fr=m1ic7M:FKC9}*ӧnCVNo:Χ/;fr?:1`+g8SUztc!+ϣ/!3Ngyʗekyv7mX8 ofێ]9:}3Np 뙛rY#~8e[oW:o 2Uf 2 1dcɈhX9জU9rg MFb0!(ʐqde82dA2 P+Cޔ!c/!2 {T_y[QU^ܜ/oWYx<\O:Χ 8ڌ㫍\N[u\OvO_pOqN_'YqǗqihǶ vn۽'fpҡa6t # cҥܐطkS-Gܓ]g g\쌦9h LA[B6H@+M>+]g/W*Ѝo+V6X,yWU綛_eY´ZJpm$رNNycy?X}vl 6aHVј+^~n[\^1_-4aζaes|B5>e2? H%x>';4w,٧F4ivҕ/k-%7NƳ`N 3,zͣ>+`+$"V\ib4\~## fz2 ~C`\#l\̓$j3جFb}8xZe"t %l6w615F:}V?M,׆h/*~L'I9r7v7pTyEʃc~+ xdqoL[m(S77]S1UkVWqozڞc|e^- |)VMey8G'8Ʒ̫bxs@xΩQ7睎G982:Ln*Cq=ypN#qA'x0d52]`FcPyY'M'I4zHJC,Nj- 1BUզ+i4Cϯ/:r-6:- +H!~RuaG*TB0 ".1g~fYեip`庎xؗy<͗ DړEvؙِ΁#%(ϧGU,6hh{%X֧5Cs$#qDXJ4#,5|~z+L1.N= ֧5ڻh}Z#ӧ}yXؙድWj(5} Į,o~ik?k1ߵEc'InN< `VT31gXYZpٗu-"a㙦Xi&0@QL"0̀ےR\!sR|:Bꃁ%ti^Q# \"]rKkbGI +ݑyNeH4W.ajƜtCB +OzinKKOǫ)ImL s;l[:l6d9M6ev22{UI+Zp}ztFwO[4>*6QUMى7UnFi꟩#槡omft^Y0ޒ%խa\<2˕0:>8K@zXlO}l%|eȅcorЎlym\-6gGm9%o%GCkbR6E{07랩*ɕ=y,;FXot3Y)uҔ'IL0[S4u KSζ]fuʕ(d6#+J(O3V(6B{-Z%S*4# +g B= CMμ1u/p˼:S+TbhE}c:sLTp6d58e91b,GW^l 00og)+?qʌq0҄ϩ Mk) 67ηZZWYk޿q{7Z [L2N=7=Mwڄbذ v-1;wWmtϛEb,՝ . 8y"li5͈~UPF`2@s1}#c 4$ܘAyvyC"o+#ofpqrbwFe!3e*͘a1te! +Ͱeh(!Vn[T춰q *|1U[89FrW)Cvhj.[[6->3C 떮N|jys[9i;ᰵ㶵WV[ 8}s~e۫+X6tG0+ rv3ܷ|KFs6u]SD])aa}ֺs릟P-PIO~f7o)?a7W_z;0,ǣk+$)a}Xo.Kz)Q }J m3m-O ꡽R{O,^>*bĈnXBɐ0ν{p!}4Rۥ[{ 1sg+X˂`N`TALo[.V? ufځB\'f]}k佊@彊}?mGY֨i}yRE^gG S凹GItrQ{YVH1F0c۲ǞggPf~ tbdw1hbw~癮l|0긌2hz8000W1a0&Ďkh<6Aw Y~3& YbɈE* 0âc:vse<޺le0wsex(1GP'to\!KI0d6!{+L@s3Uebaf0r YZLY2dS|=sN8yv<7xq:e踜2w|Ց~|ۀcmc&=׷ {o̶]Gxg3C}d*zFFTFY E:3j4e3c*fTFlb: m7SVall3fhm.}mNa~ބ-ő W"B8g:NtygXa:=YwKiTX>Fn\w6 jy s18]`xJD u'mu]d3mmSi7#G^]lO9nh3o$Z(e*=r &qϬ%*5;L tԮg;˫YK&ϋT;hvҧw hq`6>^ +b+h7T >V5A✢)n zZOR O|bGZe'S]Y>.?15K[7ֵP$uJ+>eɧ\GW*kZ}E(lnCQ1OA^m智`6OpnֽL yj:Ww^ t̠66]53֓]C ڷoi}%(mĮ6i;!87.}?îu^XJSt+a'upb%vqg8X1m6 a#7MmI (MY^%-X/faI;+RI`q7+muw݇kr~4g[mae#ŴQ5>qgNpN51GymKV&C:-յNӴ$shF]A675חn{&wu; R4]9DLȳ;k>VLJ,6g=yt͊4y|qgY>#o[3Ogy;uy훂)1kcUCaoSs]Z6dl~ƳOFϞiC e:4|0ƧneBDT}x˪GyQ'7FlxYi5/{7,7epB}*8/pf%-ӮyWCdT0ERGGNƪGCsruRȭ==!M# !kVi1}CGo/ą^@#O+V*T=Sbt*Bn6TA6Ę!G9۾cvyodO1*݃<:ñ;þ;öú÷:̻!:dn\n07X~eny-so3s/ӕ;z-&^$tʮ!͂&mܜRp2p'2C 8m3# SeHxqhW@L]+Ы\UZ?yԀ 7 hoE]`4|W;H Wlb!8QpK\lۀ$of&|Z*`f¿8Z M,|yaqML>Y&#E'Ѷ`;a!4hv "> ʝK_r[7si0|8uލ }3n7c;:F;0pflĠwE1)CvrwwehX2ٕQq(C8e[Qv1dOޞJY,ʐ=UeȞp;r9<8>xoYyno{ozo|ڞc-l#V2|qf5^3Jap𵶳EaEQQi<72a>A8w>QV+3nvc02dtǐ'aQcnNs[W)3Xono]a~-"CvwFa1|ysps|%zq;e踟2wLsl8I &bWU$m,o>8)XD+hUL %Faw7y1 ۽pT1G>V`VKm3}2c7>3l]fʱ8G}[^9LO!z#ua0|/Τid|Z~+@&B2ߩuG|%})s_QmkdWLW1 uo5WR"XIޓjLcܥٸmا910_)FeD3Qn:&FdLj {l%G+@7Z!zS$iQ4am{ h նF(fRR3sjSk[آi'nc:qk]&m؈븢De5긃2ڢ' cYluC}aNepMvh!*ㄳWq;TeДqZ,)7~82AbTń̾!e=!Q)w e2dS'SPW$ 2dLY2 SU)Cԕ!Eq sP9 ~Nʐ1geȘrVʐ1eMeX2d,I23`9^ܜwz,%*7o,+cF~M9uuT[y}|ͻͩrLUљr=1Us9T37ﵸ2ǚ<sX+g!)3Q9ek)9pg,1)s̪ʧ=3YkXHof2&=s9نp;c3yWS ЂrQVx>Y<*&U蜴Iw. v1Ə Q]mm K<m0Q7;ѵ;JNvk,J@eY ZQ0k88ɑ4Ep!s=2u1RƙyR2ʱY%c2u7R+8n?pcTY}gR師xvl>k+߃#5 ӆCfU+.R {F4%Qf\RZw:oO핂sɉtH5}T-3,15xz-A09vI 6H}-6&Zrv,YۧT#YCk֐G9ԃX֞`ܶ؝Ywki*<1s/ Pyw =zƍm5<[~/.'Z$YY3Oĭs96b-t06CCX7WÑ*Pu{ `F8m8`m m>9rW n qd;nEpvchܜ!݇2ڽ !2"&͐p  ǐp  ǐp > d{9CqfpO3I#tdw2픡cwtex3Hͥ:ugn睎ɛKW9S穋59i*CF[Cԕ!cjʐM8(Ce SRXd\ ϐ1e2dM2ƪ cQ1)C!c ʐ1La0!cʐ14e2d\ ϐq' Hp )^$At 0) C$ڎ+8+sI_3+coSmfTqgaSmܕml m2T1dchSmǐѦڎ!MCFj C!ڎ!MCFj;Ħڎ+8+pU Mj;,LôcSm![g2lP1ͶFLU2uTPNM:(S''e1hAMcPQ9eCcnS[9&eAs!9hʜce12As9US未(sN9 :] ?ܜsd~s ڎsBZmqgܕq,Oe;R3V+wT5*Cƚ!cʐveX2dlQ2, Y[9+C6!cʐgeث2d] GT# #9V!ʐqLe82dY2Ϊ gWs*d+0T<pTNYoUe~)[]9Gܩ_sy>voZy|9mu9y]W%}^G?o>O|c~J_~O}R'O?oqe^%O׿/g?Gw_y '{4˺yp??g._3gdz+ /~oV~2^?ѯ/ݯ_|%'/z?1ۿ|藿?o_ů) ]9gV曮2xjn/_J߬7i?endstream endobj 5 0 obj 18260 endobj 3 0 obj << /Type /Page /MediaBox [0 0 517 296] /Parent 2 0 R /Resources << /ProcSet [/PDF /ImageB /Text] /Font << /A 7 0 R >> >> /Contents 4 0 R >> endobj 7 0 obj <>/FontBBox[0 -20 146 146]/FontMatrix[1 0 0 1 0 0]/Widths[ 0 144 0 0 0 52 0 54 0 50 0 53 0 0 0 59 0 47 0 49 0 0 48 0 57 46 58 0 56 55 0 0 0 60 0 0 51 0 0 0 0 0]>> endobj 2 0 obj << /Type /Pages /Kids [ 3 0 R ] /Count 1 >> endobj 1 0 obj << /Type /Catalog /Pages 2 0 R >> endobj 50 0 obj << /CreationDate (D:20010718182310) /Producer (GNU Ghostscript 5.50) >> endobj 6 0 obj <> endobj 8 0 obj <> stream 0 0 0 0 146 146 d1 146 0 0 146 0 0 cm BI /IM true/W 146/H 146/BPC 1/F/CCF/DP<> ID @ EI endstream endobj 9 0 obj <> stream 144 0 0 0 0 0 d1 endstream endobj 10 0 obj <> stream 0 0 0 0 144 144 d1 144 0 0 144 0 0 cm BI /IM true/W 144/H 144/BPC 1/F/CCF/DP<> ID 8 '4@4 @4 jpNi&i 8A?恖hfhH&i 8A?pNieYe 4 ӟ2Ni 94 @4 @A4 ӟ4p,2,2ɫi 8A?ȘA4YeY A4 Fi 8A?恖hfh$| ӄpN 8A42,2y ӄpNpNIi4 @4 @&A4"a ӄshfhfDa ӄsA4YeY Ni 9C/4 ӟ@4 @4 pNi 9Ii8 '2,2, ӄspNieYe pNia ӄshfhfH7 8A4 ӄpN,2,7i 8A4 EI endstream endobj 11 0 obj <> stream 0 0 0 0 47 65 d1 47 0 0 65 0 0 cm BI /IM true/W 47/H 65/BPC 1/F/CCF/DP<> ID &Ah dA^N]@ ?A? F_2Oaoadif/ EI endstream endobj 12 0 obj <> stream 0 0 0 20 46 63 d1 46 0 0 43 0 20 cm BI /IM true/W 46/H 43/BPC 1/F/CCF/DP<> ID &pCdO k8\ojMT@€ EI endstream endobj 13 0 obj <> stream 52 0 0 0 0 0 d1 endstream endobj 14 0 obj <> stream 0 0 0 20 43 63 d1 43 0 0 43 0 20 cm BI /IM true/W 43/H 43/BPC 1/F/CCF/DP<> ID & 1<x@E z>o}oOiv0K %_ P EI endstream endobj 15 0 obj <> stream 54 0 0 0 0 0 d1 endstream endobj 16 0 obj <> stream 0 0 0 20 50 63 d1 50 0 0 43 0 20 cm BI /IM true/W 50/H 43/BPC 1/F/CCF/DP<> ID &@`|<'t:\.h3 ЇPɪj  EI endstream endobj 17 0 obj <> stream 50 0 0 0 0 0 d1 endstream endobj 18 0 obj <> stream 0 0 0 20 47 85 d1 47 0 0 65 0 20 cm BI /IM true/W 47/H 65/BPC 1/F/CCF/DP<> ID &)>MP[_g|_0O놽sY_XRړU` EI endstream endobj 19 0 obj <> stream 53 0 0 0 0 0 d1 endstream endobj 20 0 obj <> stream 0 0 0 0 46 61 d1 46 0 0 61 0 0 cm BI /IM true/W 46/H 61/BPC 1/F/CCF/DP<> ID &&,A/ c=?@( EI endstream endobj 21 0 obj <> stream 0 0 0 20 50 63 d1 50 0 0 43 0 20 cm BI /IM true/W 50/H 43/BPC 1/F/CCF/DP<> ID &(-4COT[L,2/8:&[@€ EI endstream endobj 22 0 obj <> stream 0 0 0 20 40 63 d1 40 0 0 43 0 20 cm BI /IM true/W 40/H 43/BPC 1/F/CCF/DP<> ID & ,zxAz4 =nkQU4 'c5A EI endstream endobj 23 0 obj <> stream 59 0 0 0 0 0 d1 endstream endobj 24 0 obj <> stream 0 0 0 8 43 63 d1 43 0 0 55 0 8 cm BI /IM true/W 43/H 55/BPC 1/F/CCF/DP<> ID &ܠ$ |>OxP_ɪᬇ EI endstream endobj 25 0 obj <> stream 47 0 0 0 0 0 d1 endstream endobj 26 0 obj <> stream 0 0 0 0 38 63 d1 38 0 0 63 0 0 cm BI /IM true/W 38/H 63/BPC 1/F/CCF/DP<> ID &(5K ɪᅏO  EI endstream endobj 27 0 obj <> stream 49 0 0 0 0 0 d1 endstream endobj 28 0 obj <> stream 0 0 0 0 45 65 d1 45 0 0 65 0 0 cm BI /IM true/W 45/H 65/BPC 1/F/CCF/DP<> ID &OA> zOWH?Z}&4g4}ߵ[ w``CA  EI endstream endobj 29 0 obj <> stream 0 0 0 20 39 63 d1 39 0 0 43 0 20 cm BI /IM true/W 39/H 43/BPC 1/F/CCF/DP<> ID &ا@"\QB ORj2W24KXD@1^th]'}U /c>|Ի EI endstream endobj 30 0 obj <> stream 48 0 0 0 0 0 d1 endstream endobj 31 0 obj <> stream 0 0 0 20 48 63 d1 48 0 0 43 0 20 cm BI /IM true/W 48/H 43/BPC 1/F/CCF/DP<> ID &"Nku֊:a ?a!N'c:hOi?M-5+XfP  EI endstream endobj 32 0 obj <> stream 57 0 0 0 0 0 d1 endstream endobj 33 0 obj <> stream 46 0 0 0 0 0 d1 endstream endobj 34 0 obj <> stream 58 0 0 0 0 0 d1 endstream endobj 35 0 obj <> stream 0 0 0 0 43 65 d1 43 0 0 65 0 0 cm BI /IM true/W 43/H 65/BPC 1/F/CCF/DP<> ID &@OOS0`>O kK\!fAp}d* XD c)Emx]uOׇa24x}Aݯ 5@ EI endstream endobj 36 0 obj <> stream 56 0 0 0 0 0 d1 endstream endobj 37 0 obj <> stream 55 0 0 0 0 0 d1 endstream endobj 38 0 obj <> stream 0 0 0 20 43 63 d1 43 0 0 43 0 20 cm BI /IM true/W 43/H 43/BPC 1/F/CCF/DP<> ID &C0=$zOAG\-|2}~  @ EI endstream endobj 39 0 obj <> stream 0 0 0 0 42 63 d1 42 0 0 63 0 0 cm BI /IM true/W 42/H 63/BPC 1/F/CCF/DP<> ID &?ȣ0zz ]F[P EI endstream endobj 40 0 obj <> stream 0 0 0 2 47 63 d1 47 0 0 61 0 2 cm BI /IM true/W 47/H 61/BPC 1/F/CCF/DP<> ID &M1L<*|_0O놽sY3K >MWj  EI endstream endobj 41 0 obj <> stream 60 0 0 0 0 0 d1 endstream endobj 42 0 obj <> stream 0 0 0 0 37 61 d1 37 0 0 61 0 0 cm BI /IM true/W 37/H 61/BPC 1/F/CCF/DP<> ID &EjC)ɪP EI endstream endobj 43 0 obj <> stream 0 0 0 18 49 86 d1 49 0 0 68 0 18 cm BI /IM true/W 49/H 68/BPC 1/F/CCF/DP<> ID &0D0[@hxA x?.װ\0`ap0N{z =oo_'}z 8bu ab_ EI endstream endobj 44 0 obj <> stream 51 0 0 0 0 0 d1 endstream endobj 45 0 obj <> stream 0 0 0 20 55 63 d1 55 0 0 43 0 20 cm BI /IM true/W 55/H 43/BPC 1/F/CCF/DP<> ID &Љi馟M5Yx98a08u]䄚݄  EI endstream endobj 46 0 obj <> stream 0 0 0 2 42 63 d1 42 0 0 61 0 2 cm BI /IM true/W 42/H 61/BPC 1/F/CCF/DP<> ID &Zz~@]} EI endstream endobj 47 0 obj <> stream 0 0 0 2 50 65 d1 50 0 0 63 0 2 cm BI /IM true/W 50/H 63/BPC 1/F/CCF/DP<> ID &|RtZ]>ɪS%05/|/7 /I$@ EI endstream endobj 48 0 obj <> stream 0 0 0 0 45 61 d1 45 0 0 61 0 0 cm BI /IM true/W 45/H 61/BPC 1/F/CCF/DP<> ID & Bq|9 Bo0p߃~zׅ-&a @ EI endstream endobj 49 0 obj <> stream 0 0 0 0 41 65 d1 41 0 0 65 0 0 cm BI /IM true/W 41/H 65/BPC 1/F/CCF/DP<> ID &p" ?0htOXad: EI endstream endobj xref 0 51 0000000000 65535 f 0000019292 00000 n 0000019233 00000 n 0000018366 00000 n 0000000015 00000 n 0000018345 00000 n 0000019429 00000 n 0000018521 00000 n 0000020666 00000 n 0000020859 00000 n 0000020923 00000 n 0000021673 00000 n 0000021925 00000 n 0000022144 00000 n 0000022208 00000 n 0000022440 00000 n 0000022504 00000 n 0000022730 00000 n 0000022794 00000 n 0000023042 00000 n 0000023106 00000 n 0000023328 00000 n 0000023556 00000 n 0000023783 00000 n 0000023847 00000 n 0000024066 00000 n 0000024130 00000 n 0000024345 00000 n 0000024409 00000 n 0000024654 00000 n 0000024897 00000 n 0000024961 00000 n 0000025204 00000 n 0000025268 00000 n 0000025332 00000 n 0000025396 00000 n 0000025662 00000 n 0000025726 00000 n 0000025790 00000 n 0000026023 00000 n 0000026246 00000 n 0000026486 00000 n 0000026550 00000 n 0000026756 00000 n 0000027032 00000 n 0000027096 00000 n 0000027338 00000 n 0000027545 00000 n 0000027793 00000 n 0000028026 00000 n 0000019341 00000 n trailer << /Size 51 /Root 1 0 R /Info 50 0 R >> startxref 28260 %%EOF getdp-2.4.2-source/doc/texinfo/objects.tex000644 001750 001750 00000003334 11266605602 022203 0ustar00geuzainegeuzaine000000 000000 \begin{picture}(0,0)% \includegraphics{objects}% \end{picture}% \setlength{\unitlength}{3947sp}% % \begingroup\makeatletter\ifx\SetFigFont\undefined% \gdef\SetFigFont#1#2#3#4#5{% \reset@font\fontsize{#1}{#2pt}% \fontfamily{#3}\fontseries{#4}\fontshape{#5}% \selectfont}% \fi\endgroup% \begin{picture}(8552,4875)(300,-6512) \put(1126,-3361){\makebox(0,0)[b]{\smash{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}{\color[rgb]{0,0,0}\code{Group}}% }}} \put(2851,-2686){\makebox(0,0)[b]{\smash{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}{\color[rgb]{0,0,0}\code{Function}}% }}} \put(2851,-3361){\makebox(0,0)[b]{\smash{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}{\color[rgb]{0,0,0}\code{Constraint}}% }}} \put(2851,-4036){\makebox(0,0)[b]{\smash{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}{\color[rgb]{0,0,0}\code{FunctionSpace}}% }}} \put(2851,-5386){\makebox(0,0)[b]{\smash{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}{\color[rgb]{0,0,0}\code{Jacobian}}% }}} \put(4576,-4711){\makebox(0,0)[b]{\smash{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}{\color[rgb]{0,0,0}\code{Integration}}% }}} \put(4576,-4036){\makebox(0,0)[b]{\smash{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}{\color[rgb]{0,0,0}\code{Formulation}}% }}} \put(6301,-4036){\makebox(0,0)[b]{\smash{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}{\color[rgb]{0,0,0}\code{Resolution}}% }}} \put(8026,-3361){\makebox(0,0)[b]{\smash{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}{\color[rgb]{0,0,0}\code{PostOperation}}% }}} \put(8026,-4036){\makebox(0,0)[b]{\smash{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}{\color[rgb]{0,0,0}\code{PostProcessing}}% }}} \end{picture} getdp-2.4.2-source/doc/texinfo/Integration_Lib.pro000644 001750 001750 00000002044 11266605602 023620 0ustar00geuzainegeuzaine000000 000000 /* ------------------------------------------------------------------- File "Integration_Lib.pro" Definition of integration methods ------------------------------------------------------------------- */ Integration { { Name GradGrad ; Case { {Type Gauss ; Case { { GeoElement Triangle ; NumberOfPoints 4 ; } { GeoElement Quadrangle ; NumberOfPoints 4 ; } { GeoElement Tetrahedron ; NumberOfPoints 4 ; } { GeoElement Hexahedron ; NumberOfPoints 6 ; } { GeoElement Prism ; NumberOfPoints 9 ; } } } } } { Name CurlCurl ; Case { {Type Gauss ; Case { { GeoElement Triangle ; NumberOfPoints 4 ; } { GeoElement Quadrangle ; NumberOfPoints 4 ; } { GeoElement Tetrahedron ; NumberOfPoints 4 ; } { GeoElement Hexahedron ; NumberOfPoints 6 ; } { GeoElement Prism ; NumberOfPoints 9 ; } } } } } } getdp-2.4.2-source/doc/texinfo/Strip.jpg000644 001750 001750 00000044415 11266605602 021640 0ustar00geuzainegeuzaine000000 000000 JFIFHHExifMM*JR(iZHHWCCW }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( ( ( (O'O17 | ?g|  ]NH~߳X-? ( ( (>)M?य़_I ( ( ( (&o>)c{~kj~? ( ( (>)M?य़_I ( ( ( (3{O+ះk_>1k?@e Ng+ RSW¿VO'>/_{~,|+x|iŞ;~g|G[k7Ci:&Tѵ.N4k+V( ( (+ Yfd:F ( ( (>#Sc0)gWv> ( ( ( (>)%5^>տ>:?дSn_ǯz|@7mZ~#?5_ګ6M7f ( (+ Yfd:F ( ( (>#Sc0)gWv> ( ( ( (Yx_BO+/^?gz'$#>;Yxw^< Ú@? #jzG~jݗ4,|R_<~?|,|S_ů'oϟ;~;;=]A$fை:~e? ,Bcÿ 5 tozO_n|:7ߌڧW>?|qìBӒ}^Gge}di?c^<5>6x'_Q㟉_I  ?i'PƓZO%xT>Nmyo_ h5Oxgퟌ<] Q𖣧ۺoOeR|?w?d ߂O¾?Kk5 f ~ׄg<\;'C"3\o~!iZ( (+ Yfd:F ( ( (>#Sc0)gWv> ( ( (G~_?g_%Kh_? O_j-Ǹ4?Q_xOW{Sg/k6~/>| V|Vu1ULy_^|r~zO mW8v߇5[x2].CǿcΟ fx'c|.5 Ş*Uw<;_tOBqۭGTt W|<ҭ{lO |+_>~|M~s)ҿf>xwXawI3V?dI Nw5^Fk(G|q j5sosT_?|_ ~'|B=ػZ5x~KCś?s}kOz_eo¿كCWk?f7xW\JXxO=sqox ]c4kqj,F</ '_h_OIǿ ~,~Go bf_zoV?bQm ׯ&ڟ> ~>xw Ϗ~1Y>$O|9ٗaFt[D4{u{ _Kv@P@X_R0#Y5}@P@P@P@|RـK?P@P@P@P@P@|KB]O/f]\{JšƝuOӇ/)\Ңj74𦅫HP@|bYK??lg_P@P@P@oJoof,֊NP@P@P@P@P@P*:W| 7|W>|r> ~C/O٧R񦝮x/ ڎI-ŏ}oIǽ&.I⟆>~>3P@X_R0#Y5}@P@P@P@|RـK?P@P@P@P@P@Pk)_^еC'|Ak㟅 ui> |LWI~$6ֵm+^lAgĺK{| >!A|WZ5Fj0|3x{^xZOOK 4oj_^4{~־7l~  (ـ~ο( ( ( ( Y ( ( ( ( ( Y? ¾&/5x'ƞ|'xFӼG_xWzuΏ xŵ擯x^o/4gF-.SNyb`?~psbwOڟZ" ~4_W/(k_@>Wş _h?ŝ?xw_oY_?U+|?w;E|Gae (ـ~ο( ( ( ( Y ( ( ~):%K㏈< \-o<{[3j![m|;'; /~=Ҽ?@<ox읬~~,}>-Ui։~?~~ >$I/([?; x=.~!Ɲg^p4`;ؿ9S4㿌u|G_O?:/k^^]4uvytfۻgof|@/|?ߊ?hO 'obN%A']~ʿw_x#0~7?Ox¾ |=>N|.g& x2ĺ oZw<'i^ h?eكd ~v_7 _?gOw_OmN߅~h_5C_5 tM.J/iPx¿ <}CuiI,txW~sx&sg^д;SYuK];Kӭno`YT[ggh_ |Kᗊ?^Obku/xOR?dIt-O53P.+# ( Y ( ( ( ( ( (>,य़`Gj ? ;gĿE|/_|Mku/x]Wjٚg.'q¯7MIUkZ7ǯVM#/\ ?h/ hoE,$`@= _c~ u?*_+mGɿ¯7%I]t_ túAz֋v/17 k@z_?ek_*/'ޫ?ڇٳᇈ2|1߱²m|sew/s{h?xy4* ؋Wy~~`-Qg`}eQWφxo~_,_i/|;G|BhZ fO-c7|g;nj ?bc> 7ïx'➣Ԟ>Ş(Ư&?m ůk:w~V?O?᷏4 C9+|5\|1v 6]Ϳ<+P)Z+ ;@@P@P@P@P@P@P@|bYK??lg_P@Pa!h*2F}X>>$v~L|oƶP@|RـK?P@P@P@P@P@P@PV/Eu@@P@/ٿXӼw߳6'}y;ҿgZGcíOxKؓH| ?h/כ>x/|?e ~##:ό >/|=@oJoof,֊NP@P@P@P@P@P@P@X_R0#Y5}@P@P@o'ǏEWXoÿk;}c?ZE֡imK?x_,_>8Vÿ?Dvaf ~:|S/_'o |R[Q'K)4-?E>~úŽOR~,}j 9D~v_?i=wP@|F`Rh$}@P@P@<+yg&׍9 x>tUxWƚ4xYW/~f/i~o ӵG~,n|9EfP@P@P@P@PV/Eu@@P@P@K?ώ>~ki/fM◃|;"4h۾fWkgq cL;_*x>@U׿b_7G߳oxtڏK׼9{ 7/\i!)^SAmwm |2oX ¾=𯆼u_xƞ ox;>tWŞmx{sy״MSFt˭;TӮg)X>#Sc0)gWv> ( ??V|K +*U_ea+D2)GY!J~Mυ~ w5`JGo˞( q^о>۟>|[׀};\?' ῀N?u/wz~7_ROڛSكR>j_?aToO/CǍ1᭵™|'~1L^rMbO\/oF?lOxcgLM_x=&7`~&~š/_mf;Lu@Jwao?e⟁ d/_N|K/6Y뿵׀|MxgKWӼy⯌~iO[P@P@P@P@X_R0#Y5}@P@P@P,KMOP'wok?~4~ƛ?񦷨^9/T?|`sk?~"x>__G]I-sK?<Géq}.h>~0|/ ~׿_}Ś>+x-K>3|z#Sc0)gWv> ( +C3.x <;Tt ߅| >ſ_h}'VxKԧӾ",य़`Gj ( ( (Ş|+o^|ig~1w4m;~g|G\!׉=[^i:&KtmRN4뫛+i&oaҿ?cώ>{-߳]sƞ|q>4/ן煴(+/ kׇF🃼=N|'_i?5hzN ImKӴ: h"@: ( ( ( ( (?_/)g> ( ( (>)M?य़_I (</|Y/_-w__fk#KŞ.; |?fjz˦im(~ɿ |wBK@^᫽OG ~_fYuYiD/x/_"|"~3~_~ xP/  ( ( ( (  (ـ~ο( ( ( ( Y (+,य़`Gj ( ( ( 777E'h(?8?Vu&|)'O_`еGմ7:N?QGRh~𯂵T<b~ +3_k>ӵ+ោUO#F ]]ƿY>3|g5G'C?~_?@P@P@P@P@P@X_R0#Y5}@P@P@P@~ Gw*?ᬾ)>gƏ&Dk?m_g|k A] /?G|T?#_R.\/)_@.O 'do W 7+Yt,?fj??4((oW^$7%g$b~οNoT7ހygDNS ~οNoT7ހygDNS ~οNoT7ހygDNS ~οNoT7ހygDNS ~οNoT7ހygDNS ~οNoT7ހygDNS ~οNoT7ހygDNS ~οNoT7ހygDNS ~οNoT7ހygDNS ~οNoT7ހygDNS )7?Poh~2ञ𭮣|esoxP|.nYg|CxWÚr!t&( ( ( ( Y ( ( ( (ѼY_>,=oڿAm?iz6jUy_ x^,Þ O<mXQ¾,׈b}'^.: //~*__~T?/3x;Ŀ_T4txc[5x K]VNڏAd-΍lY Og,_; i¬Y𯿴- oRd; I?Ѩ( (?_/)g> ( ( (>)M?य़_I ( ( ( ( _^I_3qwg*y_ _&I¿K_/JwKo%j Y 'ljf;0|ygٟYSؿ|9Oj~!E͟ :> |VsN'o#Xb?\~ľ{LeME?O7uЀ9&wSa~ҟ}cŸR؃=Ǐ1?hڃM𮿠xV'ğ0n|D)|D|=Z/t}6G>y'7G>%)}#  ׏<<݇uo17m.~o )_τ!|LU!돎Xy;,lc/\-U {X~*>,V.xV+ xOzƳ{]w߃$.d>W0xំR?__)AiO7 ~?w|?/zP@P@P@P@P@P@P@P@P@P@G5߆t/H<%mVcO7]xkP[On_ïþ97?͈|-㿆~;пfS]ž Ӄy4Pi x'}[ğ~xoI>7"f^gOOswd_سſ_Ǎ)B'k㯉So[~/li ~hZv15 _j^~ %O_ VO?x߄.sOA/ 񧊤tS[O?RO_ |U|؃ofSº|y|5gߍ_׈8:5m'|A\iKQᏇ,W5,~@P@P@P@P@P@P@P@P@bH5~. i/A㬟5σ~;şxK~3ڇÿ9Ὲ<9>ֳ u:u~-B.<(؟?m࿄`OI mGOo٢Ǎo0~?@/~.W/46~#Oxz=OI]Gl?|? [Q|>!x¿+]*%sxĽoF4 Ly|)wtYu,~G9T4^> iN<;*>xw7OiO¤oo~~v?Ozvx.^,-[K_ߋ~, uE3-,Þie ;e_wĀYsG9⟊m~2~LJ~~;|'|67>о&O{:iƿm㿅=-7|9u/;S?'kcoZeO"uw_ٷg;g~">{Z~/|O¾q  ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( getdp-2.4.2-source/doc/texinfo/texinfo.tex000644 001750 001750 00001052340 11266605602 022230 0ustar00geuzainegeuzaine000000 000000 % texinfo.tex -- TeX macros to handle Texinfo files. % % Load plain if necessary, i.e., if running under initex. \expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi % \def\texinfoversion{2007-09-03.05} % % Copyright (C) 1985, 1986, 1988, 1990, 1991, 1992, 1993, 1994, 1995, 2007, % 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, % 2007 Free Software Foundation, Inc. % % This texinfo.tex file is free software: you can redistribute it and/or % modify it under the terms of the GNU General Public License as % published by the Free Software Foundation, either version 3 of the % License, or (at your option) any later version. % % This texinfo.tex file is distributed in the hope that it will be % useful, but WITHOUT ANY WARRANTY; without even the implied warranty % of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU % General Public License for more details. % % You should have received a copy of the GNU General Public License % along with this program. If not, see . % % As a special exception, when this file is read by TeX when processing % a Texinfo source document, you may use the result without % restriction. (This has been our intent since Texinfo was invented.) % % Please try the latest version of texinfo.tex before submitting bug % reports; you can get the latest version from: % http://www.gnu.org/software/texinfo/ (the Texinfo home page), or % ftp://tug.org/tex/texinfo.tex % (and all CTAN mirrors, see http://www.ctan.org). % The texinfo.tex in any given distribution could well be out % of date, so if that's what you're using, please check. % % Send bug reports to bug-texinfo@gnu.org. Please include including a % complete document in each bug report with which we can reproduce the % problem. Patches are, of course, greatly appreciated. % % To process a Texinfo manual with TeX, it's most reliable to use the % texi2dvi shell script that comes with the distribution. For a simple % manual foo.texi, however, you can get away with this: % tex foo.texi % texindex foo.?? % tex foo.texi % tex foo.texi % dvips foo.dvi -o # or whatever; this makes foo.ps. % The extra TeX runs get the cross-reference information correct. % Sometimes one run after texindex suffices, and sometimes you need more % than two; texi2dvi does it as many times as necessary. % % It is possible to adapt texinfo.tex for other languages, to some % extent. You can get the existing language-specific files from the % full Texinfo distribution. % % The GNU Texinfo home page is http://www.gnu.org/software/texinfo. \message{Loading texinfo [version \texinfoversion]:} % If in a .fmt file, print the version number % and turn on active characters that we couldn't do earlier because % they might have appeared in the input file name. \everyjob{\message{[Texinfo version \texinfoversion]}% \catcode`+=\active \catcode`\_=\active} \chardef\other=12 % We never want plain's \outer definition of \+ in Texinfo. % For @tex, we can use \tabalign. \let\+ = \relax % Save some plain tex macros whose names we will redefine. \let\ptexb=\b \let\ptexbullet=\bullet \let\ptexc=\c \let\ptexcomma=\, \let\ptexdot=\. \let\ptexdots=\dots \let\ptexend=\end \let\ptexequiv=\equiv \let\ptexexclam=\! \let\ptexfootnote=\footnote \let\ptexgtr=> \let\ptexhat=^ \let\ptexi=\i \let\ptexindent=\indent \let\ptexinsert=\insert \let\ptexlbrace=\{ \let\ptexless=< \let\ptexnewwrite\newwrite \let\ptexnoindent=\noindent \let\ptexplus=+ \let\ptexrbrace=\} \let\ptexslash=\/ \let\ptexstar=\* \let\ptext=\t % If this character appears in an error message or help string, it % starts a new line in the output. \newlinechar = `^^J % Use TeX 3.0's \inputlineno to get the line number, for better error % messages, but if we're using an old version of TeX, don't do anything. % \ifx\inputlineno\thisisundefined \let\linenumber = \empty % Pre-3.0. \else \def\linenumber{l.\the\inputlineno:\space} \fi % Set up fixed words for English if not already set. \ifx\putwordAppendix\undefined \gdef\putwordAppendix{Appendix}\fi \ifx\putwordChapter\undefined \gdef\putwordChapter{Chapter}\fi \ifx\putwordfile\undefined \gdef\putwordfile{file}\fi \ifx\putwordin\undefined \gdef\putwordin{in}\fi \ifx\putwordIndexIsEmpty\undefined \gdef\putwordIndexIsEmpty{(Index is empty)}\fi \ifx\putwordIndexNonexistent\undefined \gdef\putwordIndexNonexistent{(Index is nonexistent)}\fi \ifx\putwordInfo\undefined \gdef\putwordInfo{Info}\fi \ifx\putwordInstanceVariableof\undefined \gdef\putwordInstanceVariableof{Instance Variable of}\fi \ifx\putwordMethodon\undefined \gdef\putwordMethodon{Method on}\fi \ifx\putwordNoTitle\undefined \gdef\putwordNoTitle{No Title}\fi \ifx\putwordof\undefined \gdef\putwordof{of}\fi \ifx\putwordon\undefined \gdef\putwordon{on}\fi \ifx\putwordpage\undefined \gdef\putwordpage{page}\fi \ifx\putwordsection\undefined \gdef\putwordsection{section}\fi \ifx\putwordSection\undefined \gdef\putwordSection{Section}\fi \ifx\putwordsee\undefined \gdef\putwordsee{see}\fi \ifx\putwordSee\undefined \gdef\putwordSee{See}\fi \ifx\putwordShortTOC\undefined \gdef\putwordShortTOC{Short Contents}\fi \ifx\putwordTOC\undefined \gdef\putwordTOC{Table of Contents}\fi % \ifx\putwordMJan\undefined \gdef\putwordMJan{January}\fi \ifx\putwordMFeb\undefined \gdef\putwordMFeb{February}\fi \ifx\putwordMMar\undefined \gdef\putwordMMar{March}\fi \ifx\putwordMApr\undefined \gdef\putwordMApr{April}\fi \ifx\putwordMMay\undefined \gdef\putwordMMay{May}\fi \ifx\putwordMJun\undefined \gdef\putwordMJun{June}\fi \ifx\putwordMJul\undefined \gdef\putwordMJul{July}\fi \ifx\putwordMAug\undefined \gdef\putwordMAug{August}\fi \ifx\putwordMSep\undefined \gdef\putwordMSep{September}\fi \ifx\putwordMOct\undefined \gdef\putwordMOct{October}\fi \ifx\putwordMNov\undefined \gdef\putwordMNov{November}\fi \ifx\putwordMDec\undefined \gdef\putwordMDec{December}\fi % \ifx\putwordDefmac\undefined \gdef\putwordDefmac{Macro}\fi \ifx\putwordDefspec\undefined \gdef\putwordDefspec{Special Form}\fi \ifx\putwordDefvar\undefined \gdef\putwordDefvar{Variable}\fi \ifx\putwordDefopt\undefined \gdef\putwordDefopt{User Option}\fi \ifx\putwordDeffunc\undefined \gdef\putwordDeffunc{Function}\fi % Since the category of space is not known, we have to be careful. \chardef\spacecat = 10 \def\spaceisspace{\catcode`\ =\spacecat} % sometimes characters are active, so we need control sequences. \chardef\colonChar = `\: \chardef\commaChar = `\, \chardef\dashChar = `\- \chardef\dotChar = `\. \chardef\exclamChar= `\! \chardef\lquoteChar= `\` \chardef\questChar = `\? \chardef\rquoteChar= `\' \chardef\semiChar = `\; \chardef\underChar = `\_ % Ignore a token. % \def\gobble#1{} % The following is used inside several \edef's. \def\makecsname#1{\expandafter\noexpand\csname#1\endcsname} % Hyphenation fixes. \hyphenation{ Flor-i-da Ghost-script Ghost-view Mac-OS Post-Script ap-pen-dix bit-map bit-maps data-base data-bases eshell fall-ing half-way long-est man-u-script man-u-scripts mini-buf-fer mini-buf-fers over-view par-a-digm par-a-digms rath-er rec-tan-gu-lar ro-bot-ics se-vere-ly set-up spa-ces spell-ing spell-ings stand-alone strong-est time-stamp time-stamps which-ever white-space wide-spread wrap-around } % Margin to add to right of even pages, to left of odd pages. \newdimen\bindingoffset \newdimen\normaloffset \newdimen\pagewidth \newdimen\pageheight % For a final copy, take out the rectangles % that mark overfull boxes (in case you have decided % that the text looks ok even though it passes the margin). % \def\finalout{\overfullrule=0pt} % @| inserts a changebar to the left of the current line. It should % surround any changed text. This approach does *not* work if the % change spans more than two lines of output. To handle that, we would % have adopt a much more difficult approach (putting marks into the main % vertical list for the beginning and end of each change). % \def\|{% % \vadjust can only be used in horizontal mode. \leavevmode % % Append this vertical mode material after the current line in the output. \vadjust{% % We want to insert a rule with the height and depth of the current % leading; that is exactly what \strutbox is supposed to record. \vskip-\baselineskip % % \vadjust-items are inserted at the left edge of the type. So % the \llap here moves out into the left-hand margin. \llap{% % % For a thicker or thinner bar, change the `1pt'. \vrule height\baselineskip width1pt % % This is the space between the bar and the text. \hskip 12pt }% }% } % Sometimes it is convenient to have everything in the transcript file % and nothing on the terminal. We don't just call \tracingall here, % since that produces some useless output on the terminal. We also make % some effort to order the tracing commands to reduce output in the log % file; cf. trace.sty in LaTeX. % \def\gloggingall{\begingroup \globaldefs = 1 \loggingall \endgroup}% \def\loggingall{% \tracingstats2 \tracingpages1 \tracinglostchars2 % 2 gives us more in etex \tracingparagraphs1 \tracingoutput1 \tracingmacros2 \tracingrestores1 \showboxbreadth\maxdimen \showboxdepth\maxdimen \ifx\eTeXversion\undefined\else % etex gives us more logging \tracingscantokens1 \tracingifs1 \tracinggroups1 \tracingnesting2 \tracingassigns1 \fi \tracingcommands3 % 3 gives us more in etex \errorcontextlines16 }% % add check for \lastpenalty to plain's definitions. If the last thing % we did was a \nobreak, we don't want to insert more space. % \def\smallbreak{\ifnum\lastpenalty<10000\par\ifdim\lastskip<\smallskipamount \removelastskip\penalty-50\smallskip\fi\fi} \def\medbreak{\ifnum\lastpenalty<10000\par\ifdim\lastskip<\medskipamount \removelastskip\penalty-100\medskip\fi\fi} \def\bigbreak{\ifnum\lastpenalty<10000\par\ifdim\lastskip<\bigskipamount \removelastskip\penalty-200\bigskip\fi\fi} % For @cropmarks command. % Do @cropmarks to get crop marks. % \newif\ifcropmarks \let\cropmarks = \cropmarkstrue % % Dimensions to add cropmarks at corners. % Added by P. A. MacKay, 12 Nov. 1986 % \newdimen\outerhsize \newdimen\outervsize % set by the paper size routines \newdimen\cornerlong \cornerlong=1pc \newdimen\cornerthick \cornerthick=.3pt \newdimen\topandbottommargin \topandbottommargin=.75in % Output a mark which sets \thischapter, \thissection and \thiscolor. % We dump everything together because we only have one kind of mark. % This works because we only use \botmark / \topmark, not \firstmark. % % A mark contains a subexpression of the \ifcase ... \fi construct. % \get*marks macros below extract the needed part using \ifcase. % % Another complication is to let the user choose whether \thischapter % (\thissection) refers to the chapter (section) in effect at the top % of a page, or that at the bottom of a page. The solution is % described on page 260 of The TeXbook. It involves outputting two % marks for the sectioning macros, one before the section break, and % one after. I won't pretend I can describe this better than DEK... \def\domark{% \toks0=\expandafter{\lastchapterdefs}% \toks2=\expandafter{\lastsectiondefs}% \toks4=\expandafter{\prevchapterdefs}% \toks6=\expandafter{\prevsectiondefs}% \toks8=\expandafter{\lastcolordefs}% \mark{% \the\toks0 \the\toks2 \noexpand\or \the\toks4 \the\toks6 \noexpand\else \the\toks8 }% } % \topmark doesn't work for the very first chapter (after the title % page or the contents), so we use \firstmark there -- this gets us % the mark with the chapter defs, unless the user sneaks in, e.g., % @setcolor (or @url, or @link, etc.) between @contents and the very % first @chapter. \def\gettopheadingmarks{% \ifcase0\topmark\fi \ifx\thischapter\empty \ifcase0\firstmark\fi \fi } \def\getbottomheadingmarks{\ifcase1\botmark\fi} \def\getcolormarks{\ifcase2\topmark\fi} % Avoid "undefined control sequence" errors. \def\lastchapterdefs{} \def\lastsectiondefs{} \def\prevchapterdefs{} \def\prevsectiondefs{} \def\lastcolordefs{} % Main output routine. \chardef\PAGE = 255 \output = {\onepageout{\pagecontents\PAGE}} \newbox\headlinebox \newbox\footlinebox % \onepageout takes a vbox as an argument. Note that \pagecontents % does insertions, but you have to call it yourself. \def\onepageout#1{% \ifcropmarks \hoffset=0pt \else \hoffset=\normaloffset \fi % \ifodd\pageno \advance\hoffset by \bindingoffset \else \advance\hoffset by -\bindingoffset\fi % % Do this outside of the \shipout so @code etc. will be expanded in % the headline as they should be, not taken literally (outputting ''code). \ifodd\pageno \getoddheadingmarks \else \getevenheadingmarks \fi \setbox\headlinebox = \vbox{\let\hsize=\pagewidth \makeheadline}% \ifodd\pageno \getoddfootingmarks \else \getevenfootingmarks \fi \setbox\footlinebox = \vbox{\let\hsize=\pagewidth \makefootline}% % {% % Have to do this stuff outside the \shipout because we want it to % take effect in \write's, yet the group defined by the \vbox ends % before the \shipout runs. % \indexdummies % don't expand commands in the output. \normalturnoffactive % \ in index entries must not stay \, e.g., if % the page break happens to be in the middle of an example. % We don't want .vr (or whatever) entries like this: % \entry{{\tt \indexbackslash }acronym}{32}{\code {\acronym}} % "\acronym" won't work when it's read back in; % it needs to be % {\code {{\tt \backslashcurfont }acronym} \shipout\vbox{% % Do this early so pdf references go to the beginning of the page. \ifpdfmakepagedest \pdfdest name{\the\pageno} xyz\fi % \ifcropmarks \vbox to \outervsize\bgroup \hsize = \outerhsize \vskip-\topandbottommargin \vtop to0pt{% \line{\ewtop\hfil\ewtop}% \nointerlineskip \line{% \vbox{\moveleft\cornerthick\nstop}% \hfill \vbox{\moveright\cornerthick\nstop}% }% \vss}% \vskip\topandbottommargin \line\bgroup \hfil % center the page within the outer (page) hsize. \ifodd\pageno\hskip\bindingoffset\fi \vbox\bgroup \fi % \unvbox\headlinebox \pagebody{#1}% \ifdim\ht\footlinebox > 0pt % Only leave this space if the footline is nonempty. % (We lessened \vsize for it in \oddfootingyyy.) % The \baselineskip=24pt in plain's \makefootline has no effect. \vskip 24pt \unvbox\footlinebox \fi % \ifcropmarks \egroup % end of \vbox\bgroup \hfil\egroup % end of (centering) \line\bgroup \vskip\topandbottommargin plus1fill minus1fill \boxmaxdepth = \cornerthick \vbox to0pt{\vss \line{% \vbox{\moveleft\cornerthick\nsbot}% \hfill \vbox{\moveright\cornerthick\nsbot}% }% \nointerlineskip \line{\ewbot\hfil\ewbot}% }% \egroup % \vbox from first cropmarks clause \fi }% end of \shipout\vbox }% end of group with \indexdummies \advancepageno \ifnum\outputpenalty>-20000 \else\dosupereject\fi } \newinsert\margin \dimen\margin=\maxdimen \def\pagebody#1{\vbox to\pageheight{\boxmaxdepth=\maxdepth #1}} {\catcode`\@ =11 \gdef\pagecontents#1{\ifvoid\topins\else\unvbox\topins\fi % marginal hacks, juha@viisa.uucp (Juha Takala) \ifvoid\margin\else % marginal info is present \rlap{\kern\hsize\vbox to\z@{\kern1pt\box\margin \vss}}\fi \dimen@=\dp#1\relax \unvbox#1\relax \ifvoid\footins\else\vskip\skip\footins\footnoterule \unvbox\footins\fi \ifr@ggedbottom \kern-\dimen@ \vfil \fi} } % Here are the rules for the cropmarks. Note that they are % offset so that the space between them is truly \outerhsize or \outervsize % (P. A. MacKay, 12 November, 1986) % \def\ewtop{\vrule height\cornerthick depth0pt width\cornerlong} \def\nstop{\vbox {\hrule height\cornerthick depth\cornerlong width\cornerthick}} \def\ewbot{\vrule height0pt depth\cornerthick width\cornerlong} \def\nsbot{\vbox {\hrule height\cornerlong depth\cornerthick width\cornerthick}} % Parse an argument, then pass it to #1. The argument is the rest of % the input line (except we remove a trailing comment). #1 should be a % macro which expects an ordinary undelimited TeX argument. % \def\parsearg{\parseargusing{}} \def\parseargusing#1#2{% \def\argtorun{#2}% \begingroup \obeylines \spaceisspace #1% \parseargline\empty% Insert the \empty token, see \finishparsearg below. } {\obeylines % \gdef\parseargline#1^^M{% \endgroup % End of the group started in \parsearg. \argremovecomment #1\comment\ArgTerm% }% } % First remove any @comment, then any @c comment. \def\argremovecomment#1\comment#2\ArgTerm{\argremovec #1\c\ArgTerm} \def\argremovec#1\c#2\ArgTerm{\argcheckspaces#1\^^M\ArgTerm} % Each occurence of `\^^M' or `\^^M' is replaced by a single space. % % \argremovec might leave us with trailing space, e.g., % @end itemize @c foo % This space token undergoes the same procedure and is eventually removed % by \finishparsearg. % \def\argcheckspaces#1\^^M{\argcheckspacesX#1\^^M \^^M} \def\argcheckspacesX#1 \^^M{\argcheckspacesY#1\^^M} \def\argcheckspacesY#1\^^M#2\^^M#3\ArgTerm{% \def\temp{#3}% \ifx\temp\empty % Do not use \next, perhaps the caller of \parsearg uses it; reuse \temp: \let\temp\finishparsearg \else \let\temp\argcheckspaces \fi % Put the space token in: \temp#1 #3\ArgTerm } % If a _delimited_ argument is enclosed in braces, they get stripped; so % to get _exactly_ the rest of the line, we had to prevent such situation. % We prepended an \empty token at the very beginning and we expand it now, % just before passing the control to \argtorun. % (Similarily, we have to think about #3 of \argcheckspacesY above: it is % either the null string, or it ends with \^^M---thus there is no danger % that a pair of braces would be stripped. % % But first, we have to remove the trailing space token. % \def\finishparsearg#1 \ArgTerm{\expandafter\argtorun\expandafter{#1}} % \parseargdef\foo{...} % is roughly equivalent to % \def\foo{\parsearg\Xfoo} % \def\Xfoo#1{...} % % Actually, I use \csname\string\foo\endcsname, ie. \\foo, as it is my % favourite TeX trick. --kasal, 16nov03 \def\parseargdef#1{% \expandafter \doparseargdef \csname\string#1\endcsname #1% } \def\doparseargdef#1#2{% \def#2{\parsearg#1}% \def#1##1% } % Several utility definitions with active space: { \obeyspaces \gdef\obeyedspace{ } % Make each space character in the input produce a normal interword % space in the output. Don't allow a line break at this space, as this % is used only in environments like @example, where each line of input % should produce a line of output anyway. % \gdef\sepspaces{\obeyspaces\let =\tie} % If an index command is used in an @example environment, any spaces % therein should become regular spaces in the raw index file, not the % expansion of \tie (\leavevmode \penalty \@M \ ). \gdef\unsepspaces{\let =\space} } \def\flushcr{\ifx\par\lisppar \def\next##1{}\else \let\next=\relax \fi \next} % Define the framework for environments in texinfo.tex. It's used like this: % % \envdef\foo{...} % \def\Efoo{...} % % It's the responsibility of \envdef to insert \begingroup before the % actual body; @end closes the group after calling \Efoo. \envdef also % defines \thisenv, so the current environment is known; @end checks % whether the environment name matches. The \checkenv macro can also be % used to check whether the current environment is the one expected. % % Non-false conditionals (@iftex, @ifset) don't fit into this, so they % are not treated as enviroments; they don't open a group. (The % implementation of @end takes care not to call \endgroup in this % special case.) % At runtime, environments start with this: \def\startenvironment#1{\begingroup\def\thisenv{#1}} % initialize \let\thisenv\empty % ... but they get defined via ``\envdef\foo{...}'': \long\def\envdef#1#2{\def#1{\startenvironment#1#2}} \def\envparseargdef#1#2{\parseargdef#1{\startenvironment#1#2}} % Check whether we're in the right environment: \def\checkenv#1{% \def\temp{#1}% \ifx\thisenv\temp \else \badenverr \fi } % Evironment mismatch, #1 expected: \def\badenverr{% \errhelp = \EMsimple \errmessage{This command can appear only \inenvironment\temp, not \inenvironment\thisenv}% } \def\inenvironment#1{% \ifx#1\empty out of any environment% \else in environment \expandafter\string#1% \fi } % @end foo executes the definition of \Efoo. % But first, it executes a specialized version of \checkenv % \parseargdef\end{% \if 1\csname iscond.#1\endcsname \else % The general wording of \badenverr may not be ideal, but... --kasal, 06nov03 \expandafter\checkenv\csname#1\endcsname \csname E#1\endcsname \endgroup \fi } \newhelp\EMsimple{Press RETURN to continue.} %% Simple single-character @ commands % @@ prints an @ % Kludge this until the fonts are right (grr). \def\@{{\tt\char64}} % This is turned off because it was never documented % and you can use @w{...} around a quote to suppress ligatures. %% Define @` and @' to be the same as ` and ' %% but suppressing ligatures. %\def\`{{`}} %\def\'{{'}} % Used to generate quoted braces. \def\mylbrace {{\tt\char123}} \def\myrbrace {{\tt\char125}} \let\{=\mylbrace \let\}=\myrbrace \begingroup % Definitions to produce \{ and \} commands for indices, % and @{ and @} for the aux/toc files. \catcode`\{ = \other \catcode`\} = \other \catcode`\[ = 1 \catcode`\] = 2 \catcode`\! = 0 \catcode`\\ = \other !gdef!lbracecmd[\{]% !gdef!rbracecmd[\}]% !gdef!lbraceatcmd[@{]% !gdef!rbraceatcmd[@}]% !endgroup % @comma{} to avoid , parsing problems. \let\comma = , % Accents: @, @dotaccent @ringaccent @ubaraccent @udotaccent % Others are defined by plain TeX: @` @' @" @^ @~ @= @u @v @H. \let\, = \c \let\dotaccent = \. \def\ringaccent#1{{\accent23 #1}} \let\tieaccent = \t \let\ubaraccent = \b \let\udotaccent = \d % Other special characters: @questiondown @exclamdown @ordf @ordm % Plain TeX defines: @AA @AE @O @OE @L (plus lowercase versions) @ss. \def\questiondown{?`} \def\exclamdown{!`} \def\ordf{\leavevmode\raise1ex\hbox{\selectfonts\lllsize \underbar{a}}} \def\ordm{\leavevmode\raise1ex\hbox{\selectfonts\lllsize \underbar{o}}} % Dotless i and dotless j, used for accents. \def\imacro{i} \def\jmacro{j} \def\dotless#1{% \def\temp{#1}% \ifx\temp\imacro \ptexi \else\ifx\temp\jmacro \j \else \errmessage{@dotless can be used only with i or j}% \fi\fi } % The \TeX{} logo, as in plain, but resetting the spacing so that a % period following counts as ending a sentence. (Idea found in latex.) % \edef\TeX{\TeX \spacefactor=1000 } % @LaTeX{} logo. Not quite the same results as the definition in % latex.ltx, since we use a different font for the raised A; it's most % convenient for us to use an explicitly smaller font, rather than using % the \scriptstyle font (since we don't reset \scriptstyle and % \scriptscriptstyle). % \def\LaTeX{% L\kern-.36em {\setbox0=\hbox{T}% \vbox to \ht0{\hbox{\selectfonts\lllsize A}\vss}}% \kern-.15em \TeX } % Be sure we're in horizontal mode when doing a tie, since we make space % equivalent to this in @example-like environments. Otherwise, a space % at the beginning of a line will start with \penalty -- and % since \penalty is valid in vertical mode, we'd end up putting the % penalty on the vertical list instead of in the new paragraph. {\catcode`@ = 11 % Avoid using \@M directly, because that causes trouble % if the definition is written into an index file. \global\let\tiepenalty = \@M \gdef\tie{\leavevmode\penalty\tiepenalty\ } } % @: forces normal size whitespace following. \def\:{\spacefactor=1000 } % @* forces a line break. \def\*{\hfil\break\hbox{}\ignorespaces} % @/ allows a line break. \let\/=\allowbreak % @. is an end-of-sentence period. \def\.{.\spacefactor=\endofsentencespacefactor\space} % @! is an end-of-sentence bang. \def\!{!\spacefactor=\endofsentencespacefactor\space} % @? is an end-of-sentence query. \def\?{?\spacefactor=\endofsentencespacefactor\space} % @frenchspacing on|off says whether to put extra space after punctuation. % \def\onword{on} \def\offword{off} % \parseargdef\frenchspacing{% \def\temp{#1}% \ifx\temp\onword \plainfrenchspacing \else\ifx\temp\offword \plainnonfrenchspacing \else \errhelp = \EMsimple \errmessage{Unknown @frenchspacing option `\temp', must be on/off}% \fi\fi } % @w prevents a word break. Without the \leavevmode, @w at the % beginning of a paragraph, when TeX is still in vertical mode, would % produce a whole line of output instead of starting the paragraph. \def\w#1{\leavevmode\hbox{#1}} % @group ... @end group forces ... to be all on one page, by enclosing % it in a TeX vbox. We use \vtop instead of \vbox to construct the box % to keep its height that of a normal line. According to the rules for % \topskip (p.114 of the TeXbook), the glue inserted is % max (\topskip - \ht (first item), 0). If that height is large, % therefore, no glue is inserted, and the space between the headline and % the text is small, which looks bad. % % Another complication is that the group might be very large. This can % cause the glue on the previous page to be unduly stretched, because it % does not have much material. In this case, it's better to add an % explicit \vfill so that the extra space is at the bottom. The % threshold for doing this is if the group is more than \vfilllimit % percent of a page (\vfilllimit can be changed inside of @tex). % \newbox\groupbox \def\vfilllimit{0.7} % \envdef\group{% \ifnum\catcode`\^^M=\active \else \errhelp = \groupinvalidhelp \errmessage{@group invalid in context where filling is enabled}% \fi \startsavinginserts % \setbox\groupbox = \vtop\bgroup % Do @comment since we are called inside an environment such as % @example, where each end-of-line in the input causes an % end-of-line in the output. We don't want the end-of-line after % the `@group' to put extra space in the output. Since @group % should appear on a line by itself (according to the Texinfo % manual), we don't worry about eating any user text. \comment } % % The \vtop produces a box with normal height and large depth; thus, TeX puts % \baselineskip glue before it, and (when the next line of text is done) % \lineskip glue after it. Thus, space below is not quite equal to space % above. But it's pretty close. \def\Egroup{% % To get correct interline space between the last line of the group % and the first line afterwards, we have to propagate \prevdepth. \endgraf % Not \par, as it may have been set to \lisppar. \global\dimen1 = \prevdepth \egroup % End the \vtop. % \dimen0 is the vertical size of the group's box. \dimen0 = \ht\groupbox \advance\dimen0 by \dp\groupbox % \dimen2 is how much space is left on the page (more or less). \dimen2 = \pageheight \advance\dimen2 by -\pagetotal % if the group doesn't fit on the current page, and it's a big big % group, force a page break. \ifdim \dimen0 > \dimen2 \ifdim \pagetotal < \vfilllimit\pageheight \page \fi \fi \box\groupbox \prevdepth = \dimen1 \checkinserts } % % TeX puts in an \escapechar (i.e., `@') at the beginning of the help % message, so this ends up printing `@group can only ...'. % \newhelp\groupinvalidhelp{% group can only be used in environments such as @example,^^J% where each line of input produces a line of output.} % @need space-in-mils % forces a page break if there is not space-in-mils remaining. \newdimen\mil \mil=0.001in % Old definition--didn't work. %\parseargdef\need{\par % %% This method tries to make TeX break the page naturally %% if the depth of the box does not fit. %{\baselineskip=0pt% %\vtop to #1\mil{\vfil}\kern -#1\mil\nobreak %\prevdepth=-1000pt %}} \parseargdef\need{% % Ensure vertical mode, so we don't make a big box in the middle of a % paragraph. \par % % If the @need value is less than one line space, it's useless. \dimen0 = #1\mil \dimen2 = \ht\strutbox \advance\dimen2 by \dp\strutbox \ifdim\dimen0 > \dimen2 % % Do a \strut just to make the height of this box be normal, so the % normal leading is inserted relative to the preceding line. % And a page break here is fine. \vtop to #1\mil{\strut\vfil}% % % TeX does not even consider page breaks if a penalty added to the % main vertical list is 10000 or more. But in order to see if the % empty box we just added fits on the page, we must make it consider % page breaks. On the other hand, we don't want to actually break the % page after the empty box. So we use a penalty of 9999. % % There is an extremely small chance that TeX will actually break the % page at this \penalty, if there are no other feasible breakpoints in % sight. (If the user is using lots of big @group commands, which % almost-but-not-quite fill up a page, TeX will have a hard time doing % good page breaking, for example.) However, I could not construct an % example where a page broke at this \penalty; if it happens in a real % document, then we can reconsider our strategy. \penalty9999 % % Back up by the size of the box, whether we did a page break or not. \kern -#1\mil % % Do not allow a page break right after this kern. \nobreak \fi } % @br forces paragraph break (and is undocumented). \let\br = \par % @page forces the start of a new page. % \def\page{\par\vfill\supereject} % @exdent text.... % outputs text on separate line in roman font, starting at standard page margin % This records the amount of indent in the innermost environment. % That's how much \exdent should take out. \newskip\exdentamount % This defn is used inside fill environments such as @defun. \parseargdef\exdent{\hfil\break\hbox{\kern -\exdentamount{\rm#1}}\hfil\break} % This defn is used inside nofill environments such as @example. \parseargdef\nofillexdent{{\advance \leftskip by -\exdentamount \leftline{\hskip\leftskip{\rm#1}}}} % @inmargin{WHICH}{TEXT} puts TEXT in the WHICH margin next to the current % paragraph. For more general purposes, use the \margin insertion % class. WHICH is `l' or `r'. % \newskip\inmarginspacing \inmarginspacing=1cm \def\strutdepth{\dp\strutbox} % \def\doinmargin#1#2{\strut\vadjust{% \nobreak \kern-\strutdepth \vtop to \strutdepth{% \baselineskip=\strutdepth \vss % if you have multiple lines of stuff to put here, you'll need to % make the vbox yourself of the appropriate size. \ifx#1l% \llap{\ignorespaces #2\hskip\inmarginspacing}% \else \rlap{\hskip\hsize \hskip\inmarginspacing \ignorespaces #2}% \fi \null }% }} \def\inleftmargin{\doinmargin l} \def\inrightmargin{\doinmargin r} % % @inmargin{TEXT [, RIGHT-TEXT]} % (if RIGHT-TEXT is given, use TEXT for left page, RIGHT-TEXT for right; % else use TEXT for both). % \def\inmargin#1{\parseinmargin #1,,\finish} \def\parseinmargin#1,#2,#3\finish{% not perfect, but better than nothing. \setbox0 = \hbox{\ignorespaces #2}% \ifdim\wd0 > 0pt \def\lefttext{#1}% have both texts \def\righttext{#2}% \else \def\lefttext{#1}% have only one text \def\righttext{#1}% \fi % \ifodd\pageno \def\temp{\inrightmargin\righttext}% odd page -> outside is right margin \else \def\temp{\inleftmargin\lefttext}% \fi \temp } % @include file insert text of that file as input. % \def\include{\parseargusing\filenamecatcodes\includezzz} \def\includezzz#1{% \pushthisfilestack \def\thisfile{#1}% {% \makevalueexpandable \def\temp{\input #1 }% \expandafter }\temp \popthisfilestack } \def\filenamecatcodes{% \catcode`\\=\other \catcode`~=\other \catcode`^=\other \catcode`_=\other \catcode`|=\other \catcode`<=\other \catcode`>=\other \catcode`+=\other \catcode`-=\other } \def\pushthisfilestack{% \expandafter\pushthisfilestackX\popthisfilestack\StackTerm } \def\pushthisfilestackX{% \expandafter\pushthisfilestackY\thisfile\StackTerm } \def\pushthisfilestackY #1\StackTerm #2\StackTerm {% \gdef\popthisfilestack{\gdef\thisfile{#1}\gdef\popthisfilestack{#2}}% } \def\popthisfilestack{\errthisfilestackempty} \def\errthisfilestackempty{\errmessage{Internal error: the stack of filenames is empty.}} \def\thisfile{} % @center line % outputs that line, centered. % \parseargdef\center{% \ifhmode \let\next\centerH \else \let\next\centerV \fi \next{\hfil \ignorespaces#1\unskip \hfil}% } \def\centerH#1{% {% \hfil\break \advance\hsize by -\leftskip \advance\hsize by -\rightskip \line{#1}% \break }% } \def\centerV#1{\line{\kern\leftskip #1\kern\rightskip}} % @sp n outputs n lines of vertical space \parseargdef\sp{\vskip #1\baselineskip} % @comment ...line which is ignored... % @c is the same as @comment % @ignore ... @end ignore is another way to write a comment \def\comment{\begingroup \catcode`\^^M=\other% \catcode`\@=\other \catcode`\{=\other \catcode`\}=\other% \commentxxx} {\catcode`\^^M=\other \gdef\commentxxx#1^^M{\endgroup}} \let\c=\comment % @paragraphindent NCHARS % We'll use ems for NCHARS, close enough. % NCHARS can also be the word `asis' or `none'. % We cannot feasibly implement @paragraphindent asis, though. % \def\asisword{asis} % no translation, these are keywords \def\noneword{none} % \parseargdef\paragraphindent{% \def\temp{#1}% \ifx\temp\asisword \else \ifx\temp\noneword \defaultparindent = 0pt \else \defaultparindent = #1em \fi \fi \parindent = \defaultparindent } % @exampleindent NCHARS % We'll use ems for NCHARS like @paragraphindent. % It seems @exampleindent asis isn't necessary, but % I preserve it to make it similar to @paragraphindent. \parseargdef\exampleindent{% \def\temp{#1}% \ifx\temp\asisword \else \ifx\temp\noneword \lispnarrowing = 0pt \else \lispnarrowing = #1em \fi \fi } % @firstparagraphindent WORD % If WORD is `none', then suppress indentation of the first paragraph % after a section heading. If WORD is `insert', then do indent at such % paragraphs. % % The paragraph indentation is suppressed or not by calling % \suppressfirstparagraphindent, which the sectioning commands do. % We switch the definition of this back and forth according to WORD. % By default, we suppress indentation. % \def\suppressfirstparagraphindent{\dosuppressfirstparagraphindent} \def\insertword{insert} % \parseargdef\firstparagraphindent{% \def\temp{#1}% \ifx\temp\noneword \let\suppressfirstparagraphindent = \dosuppressfirstparagraphindent \else\ifx\temp\insertword \let\suppressfirstparagraphindent = \relax \else \errhelp = \EMsimple \errmessage{Unknown @firstparagraphindent option `\temp'}% \fi\fi } % Here is how we actually suppress indentation. Redefine \everypar to % \kern backwards by \parindent, and then reset itself to empty. % % We also make \indent itself not actually do anything until the next % paragraph. % \gdef\dosuppressfirstparagraphindent{% \gdef\indent{% \restorefirstparagraphindent \indent }% \gdef\noindent{% \restorefirstparagraphindent \noindent }% \global\everypar = {% \kern -\parindent \restorefirstparagraphindent }% } \gdef\restorefirstparagraphindent{% \global \let \indent = \ptexindent \global \let \noindent = \ptexnoindent \global \everypar = {}% } % @asis just yields its argument. Used with @table, for example. % \def\asis#1{#1} % @math outputs its argument in math mode. % % One complication: _ usually means subscripts, but it could also mean % an actual _ character, as in @math{@var{some_variable} + 1}. So make % _ active, and distinguish by seeing if the current family is \slfam, % which is what @var uses. { \catcode`\_ = \active \gdef\mathunderscore{% \catcode`\_=\active \def_{\ifnum\fam=\slfam \_\else\sb\fi}% } } % Another complication: we want \\ (and @\) to output a \ character. % FYI, plain.tex uses \\ as a temporary control sequence (why?), but % this is not advertised and we don't care. Texinfo does not % otherwise define @\. % % The \mathchar is class=0=ordinary, family=7=ttfam, position=5C=\. \def\mathbackslash{\ifnum\fam=\ttfam \mathchar"075C \else\backslash \fi} % \def\math{% \tex \mathunderscore \let\\ = \mathbackslash \mathactive $\finishmath } \def\finishmath#1{#1$\endgroup} % Close the group opened by \tex. % Some active characters (such as <) are spaced differently in math. % We have to reset their definitions in case the @math was an argument % to a command which sets the catcodes (such as @item or @section). % { \catcode`^ = \active \catcode`< = \active \catcode`> = \active \catcode`+ = \active \gdef\mathactive{% \let^ = \ptexhat \let< = \ptexless \let> = \ptexgtr \let+ = \ptexplus } } % @bullet and @minus need the same treatment as @math, just above. \def\bullet{$\ptexbullet$} \def\minus{$-$} % @dots{} outputs an ellipsis using the current font. % We do .5em per period so that it has the same spacing in the cm % typewriter fonts as three actual period characters; on the other hand, % in other typewriter fonts three periods are wider than 1.5em. So do % whichever is larger. % \def\dots{% \leavevmode \setbox0=\hbox{...}% get width of three periods \ifdim\wd0 > 1.5em \dimen0 = \wd0 \else \dimen0 = 1.5em \fi \hbox to \dimen0{% \hskip 0pt plus.25fil .\hskip 0pt plus1fil .\hskip 0pt plus1fil .\hskip 0pt plus.5fil }% } % @enddots{} is an end-of-sentence ellipsis. % \def\enddots{% \dots \spacefactor=\endofsentencespacefactor } % @comma{} is so commas can be inserted into text without messing up % Texinfo's parsing. % \let\comma = , % @refill is a no-op. \let\refill=\relax % If working on a large document in chapters, it is convenient to % be able to disable indexing, cross-referencing, and contents, for test runs. % This is done with @novalidate (before @setfilename). % \newif\iflinks \linkstrue % by default we want the aux files. \let\novalidate = \linksfalse % @setfilename is done at the beginning of every texinfo file. % So open here the files we need to have open while reading the input. % This makes it possible to make a .fmt file for texinfo. \def\setfilename{% \fixbackslash % Turn off hack to swallow `\input texinfo'. \iflinks \tryauxfile % Open the new aux file. TeX will close it automatically at exit. \immediate\openout\auxfile=\jobname.aux \fi % \openindices needs to do some work in any case. \openindices \let\setfilename=\comment % Ignore extra @setfilename cmds. % % If texinfo.cnf is present on the system, read it. % Useful for site-wide @afourpaper, etc. \openin 1 texinfo.cnf \ifeof 1 \else \input texinfo.cnf \fi \closein 1 % \comment % Ignore the actual filename. } % Called from \setfilename. % \def\openindices{% \newindex{cp}% \newcodeindex{fn}% \newcodeindex{vr}% \newcodeindex{tp}% \newcodeindex{ky}% \newcodeindex{pg}% } % @bye. \outer\def\bye{\pagealignmacro\tracingstats=1\ptexend} \message{pdf,} % adobe `portable' document format \newcount\tempnum \newcount\lnkcount \newtoks\filename \newcount\filenamelength \newcount\pgn \newtoks\toksA \newtoks\toksB \newtoks\toksC \newtoks\toksD \newbox\boxA \newcount\countA \newif\ifpdf \newif\ifpdfmakepagedest % when pdftex is run in dvi mode, \pdfoutput is defined (so \pdfoutput=1 % can be set). So we test for \relax and 0 as well as \undefined, % borrowed from ifpdf.sty. \ifx\pdfoutput\undefined \else \ifx\pdfoutput\relax \else \ifcase\pdfoutput \else \pdftrue \fi \fi \fi % PDF uses PostScript string constants for the names of xref targets, % for display in the outlines, and in other places. Thus, we have to % double any backslashes. Otherwise, a name like "\node" will be % interpreted as a newline (\n), followed by o, d, e. Not good. % http://www.ntg.nl/pipermail/ntg-pdftex/2004-July/000654.html % (and related messages, the final outcome is that it is up to the TeX % user to double the backslashes and otherwise make the string valid, so % that's what we do). % double active backslashes. % {\catcode`\@=0 \catcode`\\=\active @gdef@activebackslashdouble{% @catcode`@\=@active @let\=@doublebackslash} } % To handle parens, we must adopt a different approach, since parens are % not active characters. hyperref.dtx (which has the same problem as % us) handles it with this amazing macro to replace tokens, with minor % changes for Texinfo. It is included here under the GPL by permission % from the author, Heiko Oberdiek. % % #1 is the tokens to replace. % #2 is the replacement. % #3 is the control sequence with the string. % \def\HyPsdSubst#1#2#3{% \def\HyPsdReplace##1#1##2\END{% ##1% \ifx\\##2\\% \else #2% \HyReturnAfterFi{% \HyPsdReplace##2\END }% \fi }% \xdef#3{\expandafter\HyPsdReplace#3#1\END}% } \long\def\HyReturnAfterFi#1\fi{\fi#1} % #1 is a control sequence in which to do the replacements. \def\backslashparens#1{% \xdef#1{#1}% redefine it as its expansion; the definition is simply % \lastnode when called from \setref -> \pdfmkdest. \HyPsdSubst{(}{\realbackslash(}{#1}% \HyPsdSubst{)}{\realbackslash)}{#1}% } \newhelp\nopdfimagehelp{Texinfo supports .png, .jpg, .jpeg, and .pdf images with PDF output, and none of those formats could be found. (.eps cannot be supported due to the design of the PDF format; use regular TeX (DVI output) for that.)} \ifpdf % % Color manipulation macros based on pdfcolor.tex. \def\cmykDarkRed{0.28 1 1 0.35} \def\cmykBlack{0 0 0 1} % \def\pdfsetcolor#1{\pdfliteral{#1 k}} % Set color, and create a mark which defines \thiscolor accordingly, % so that \makeheadline knows which color to restore. \def\setcolor#1{% \xdef\lastcolordefs{\gdef\noexpand\thiscolor{#1}}% \domark \pdfsetcolor{#1}% } % \def\maincolor{\cmykBlack} \pdfsetcolor{\maincolor} \edef\thiscolor{\maincolor} \def\lastcolordefs{} % \def\makefootline{% \baselineskip24pt \line{\pdfsetcolor{\maincolor}\the\footline}% } % \def\makeheadline{% \vbox to 0pt{% \vskip-22.5pt \line{% \vbox to8.5pt{}% % Extract \thiscolor definition from the marks. \getcolormarks % Typeset the headline with \maincolor, then restore the color. \pdfsetcolor{\maincolor}\the\headline\pdfsetcolor{\thiscolor}% }% \vss }% \nointerlineskip } % % \pdfcatalog{/PageMode /UseOutlines} % % #1 is image name, #2 width (might be empty/whitespace), #3 height (ditto). \def\dopdfimage#1#2#3{% \def\imagewidth{#2}\setbox0 = \hbox{\ignorespaces #2}% \def\imageheight{#3}\setbox2 = \hbox{\ignorespaces #3}% % % pdftex (and the PDF format) support .png, .jpg, .pdf (among % others). Let's try in that order. \let\pdfimgext=\empty \begingroup \openin 1 #1.png \ifeof 1 \openin 1 #1.jpg \ifeof 1 \openin 1 #1.jpeg \ifeof 1 \openin 1 #1.JPG \ifeof 1 \openin 1 #1.pdf \ifeof 1 \errhelp = \nopdfimagehelp \errmessage{Could not find image file #1 for pdf}% \else \gdef\pdfimgext{pdf}% \fi \else \gdef\pdfimgext{JPG}% \fi \else \gdef\pdfimgext{jpeg}% \fi \else \gdef\pdfimgext{jpg}% \fi \else \gdef\pdfimgext{png}% \fi \closein 1 \endgroup % % without \immediate, pdftex seg faults when the same image is % included twice. (Version 3.14159-pre-1.0-unofficial-20010704.) \ifnum\pdftexversion < 14 \immediate\pdfimage \else \immediate\pdfximage \fi \ifdim \wd0 >0pt width \imagewidth \fi \ifdim \wd2 >0pt height \imageheight \fi \ifnum\pdftexversion<13 #1.\pdfimgext \else {#1.\pdfimgext}% \fi \ifnum\pdftexversion < 14 \else \pdfrefximage \pdflastximage \fi} % \def\pdfmkdest#1{{% % We have to set dummies so commands such as @code, and characters % such as \, aren't expanded when present in a section title. \indexnofonts \turnoffactive \activebackslashdouble \makevalueexpandable \def\pdfdestname{#1}% \backslashparens\pdfdestname \safewhatsit{\pdfdest name{\pdfdestname} xyz}% }} % % used to mark target names; must be expandable. \def\pdfmkpgn#1{#1} % % by default, use a color that is dark enough to print on paper as % nearly black, but still distinguishable for online viewing. \def\urlcolor{\cmykDarkRed} \def\linkcolor{\cmykDarkRed} \def\endlink{\setcolor{\maincolor}\pdfendlink} % % Adding outlines to PDF; macros for calculating structure of outlines % come from Petr Olsak \def\expnumber#1{\expandafter\ifx\csname#1\endcsname\relax 0% \else \csname#1\endcsname \fi} \def\advancenumber#1{\tempnum=\expnumber{#1}\relax \advance\tempnum by 1 \expandafter\xdef\csname#1\endcsname{\the\tempnum}} % % #1 is the section text, which is what will be displayed in the % outline by the pdf viewer. #2 is the pdf expression for the number % of subentries (or empty, for subsubsections). #3 is the node text, % which might be empty if this toc entry had no corresponding node. % #4 is the page number % \def\dopdfoutline#1#2#3#4{% % Generate a link to the node text if that exists; else, use the % page number. We could generate a destination for the section % text in the case where a section has no node, but it doesn't % seem worth the trouble, since most documents are normally structured. \def\pdfoutlinedest{#3}% \ifx\pdfoutlinedest\empty \def\pdfoutlinedest{#4}% \else % Doubled backslashes in the name. {\activebackslashdouble \xdef\pdfoutlinedest{#3}% \backslashparens\pdfoutlinedest}% \fi % % Also double the backslashes in the display string. {\activebackslashdouble \xdef\pdfoutlinetext{#1}% \backslashparens\pdfoutlinetext}% % \pdfoutline goto name{\pdfmkpgn{\pdfoutlinedest}}#2{\pdfoutlinetext}% } % \def\pdfmakeoutlines{% \begingroup % Thanh's hack / proper braces in bookmarks \edef\mylbrace{\iftrue \string{\else}\fi}\let\{=\mylbrace \edef\myrbrace{\iffalse{\else\string}\fi}\let\}=\myrbrace % % Read toc silently, to get counts of subentries for \pdfoutline. \def\numchapentry##1##2##3##4{% \def\thischapnum{##2}% \def\thissecnum{0}% \def\thissubsecnum{0}% }% \def\numsecentry##1##2##3##4{% \advancenumber{chap\thischapnum}% \def\thissecnum{##2}% \def\thissubsecnum{0}% }% \def\numsubsecentry##1##2##3##4{% \advancenumber{sec\thissecnum}% \def\thissubsecnum{##2}% }% \def\numsubsubsecentry##1##2##3##4{% \advancenumber{subsec\thissubsecnum}% }% \def\thischapnum{0}% \def\thissecnum{0}% \def\thissubsecnum{0}% % % use \def rather than \let here because we redefine \chapentry et % al. a second time, below. \def\appentry{\numchapentry}% \def\appsecentry{\numsecentry}% \def\appsubsecentry{\numsubsecentry}% \def\appsubsubsecentry{\numsubsubsecentry}% \def\unnchapentry{\numchapentry}% \def\unnsecentry{\numsecentry}% \def\unnsubsecentry{\numsubsecentry}% \def\unnsubsubsecentry{\numsubsubsecentry}% \readdatafile{toc}% % % Read toc second time, this time actually producing the outlines. % The `-' means take the \expnumber as the absolute number of % subentries, which we calculated on our first read of the .toc above. % % We use the node names as the destinations. \def\numchapentry##1##2##3##4{% \dopdfoutline{##1}{count-\expnumber{chap##2}}{##3}{##4}}% \def\numsecentry##1##2##3##4{% \dopdfoutline{##1}{count-\expnumber{sec##2}}{##3}{##4}}% \def\numsubsecentry##1##2##3##4{% \dopdfoutline{##1}{count-\expnumber{subsec##2}}{##3}{##4}}% \def\numsubsubsecentry##1##2##3##4{% count is always zero \dopdfoutline{##1}{}{##3}{##4}}% % % PDF outlines are displayed using system fonts, instead of % document fonts. Therefore we cannot use special characters, % since the encoding is unknown. For example, the eogonek from % Latin 2 (0xea) gets translated to a | character. Info from % Staszek Wawrykiewicz, 19 Jan 2004 04:09:24 +0100. % % xx to do this right, we have to translate 8-bit characters to % their "best" equivalent, based on the @documentencoding. Right % now, I guess we'll just let the pdf reader have its way. \indexnofonts \setupdatafile \catcode`\\=\active \otherbackslash \input \tocreadfilename \endgroup } % \def\skipspaces#1{\def\PP{#1}\def\D{|}% \ifx\PP\D\let\nextsp\relax \else\let\nextsp\skipspaces \ifx\p\space\else\addtokens{\filename}{\PP}% \advance\filenamelength by 1 \fi \fi \nextsp} \def\getfilename#1{\filenamelength=0\expandafter\skipspaces#1|\relax} \ifnum\pdftexversion < 14 \let \startlink \pdfannotlink \else \let \startlink \pdfstartlink \fi % make a live url in pdf output. \def\pdfurl#1{% \begingroup % it seems we really need yet another set of dummies; have not % tried to figure out what each command should do in the context % of @url. for now, just make @/ a no-op, that's the only one % people have actually reported a problem with. % \normalturnoffactive \def\@{@}% \let\/=\empty \makevalueexpandable \leavevmode\setcolor{\urlcolor}% \startlink attr{/Border [0 0 0]}% user{/Subtype /Link /A << /S /URI /URI (#1) >>}% \endgroup} \def\pdfgettoks#1.{\setbox\boxA=\hbox{\toksA={#1.}\toksB={}\maketoks}} \def\addtokens#1#2{\edef\addtoks{\noexpand#1={\the#1#2}}\addtoks} \def\adn#1{\addtokens{\toksC}{#1}\global\countA=1\let\next=\maketoks} \def\poptoks#1#2|ENDTOKS|{\let\first=#1\toksD={#1}\toksA={#2}} \def\maketoks{% \expandafter\poptoks\the\toksA|ENDTOKS|\relax \ifx\first0\adn0 \else\ifx\first1\adn1 \else\ifx\first2\adn2 \else\ifx\first3\adn3 \else\ifx\first4\adn4 \else\ifx\first5\adn5 \else\ifx\first6\adn6 \else\ifx\first7\adn7 \else\ifx\first8\adn8 \else\ifx\first9\adn9 \else \ifnum0=\countA\else\makelink\fi \ifx\first.\let\next=\done\else \let\next=\maketoks \addtokens{\toksB}{\the\toksD} \ifx\first,\addtokens{\toksB}{\space}\fi \fi \fi\fi\fi\fi\fi\fi\fi\fi\fi\fi \next} \def\makelink{\addtokens{\toksB}% {\noexpand\pdflink{\the\toksC}}\toksC={}\global\countA=0} \def\pdflink#1{% \startlink attr{/Border [0 0 0]} goto name{\pdfmkpgn{#1}} \setcolor{\linkcolor}#1\endlink} \def\done{\edef\st{\global\noexpand\toksA={\the\toksB}}\st} \else \let\pdfmkdest = \gobble \let\pdfurl = \gobble \let\endlink = \relax \let\setcolor = \gobble \let\pdfsetcolor = \gobble \let\pdfmakeoutlines = \relax \fi % \ifx\pdfoutput \message{fonts,} % Change the current font style to #1, remembering it in \curfontstyle. % For now, we do not accumulate font styles: @b{@i{foo}} prints foo in % italics, not bold italics. % \def\setfontstyle#1{% \def\curfontstyle{#1}% not as a control sequence, because we are \edef'd. \csname ten#1\endcsname % change the current font } % Select #1 fonts with the current style. % \def\selectfonts#1{\csname #1fonts\endcsname \csname\curfontstyle\endcsname} \def\rm{\fam=0 \setfontstyle{rm}} \def\it{\fam=\itfam \setfontstyle{it}} \def\sl{\fam=\slfam \setfontstyle{sl}} \def\bf{\fam=\bffam \setfontstyle{bf}}\def\bfstylename{bf} \def\tt{\fam=\ttfam \setfontstyle{tt}} % Texinfo sort of supports the sans serif font style, which plain TeX does not. % So we set up a \sf. \newfam\sffam \def\sf{\fam=\sffam \setfontstyle{sf}} \let\li = \sf % Sometimes we call it \li, not \sf. % We don't need math for this font style. \def\ttsl{\setfontstyle{ttsl}} % Default leading. \newdimen\textleading \textleading = 13.2pt % Set the baselineskip to #1, and the lineskip and strut size % correspondingly. There is no deep meaning behind these magic numbers % used as factors; they just match (closely enough) what Knuth defined. % \def\lineskipfactor{.08333} \def\strutheightpercent{.70833} \def\strutdepthpercent {.29167} % % can get a sort of poor man's double spacing by redefining this. \def\baselinefactor{1} % \def\setleading#1{% \dimen0 = #1\relax \normalbaselineskip = \baselinefactor\dimen0 \normallineskip = \lineskipfactor\normalbaselineskip \normalbaselines \setbox\strutbox =\hbox{% \vrule width0pt height\strutheightpercent\baselineskip depth \strutdepthpercent \baselineskip }% } % % PDF CMaps. See also LaTeX's t1.cmap. % % \cmapOT1 \ifpdf \begingroup \catcode`\^^M=\active \def^^M{^^J}% Output line endings as the ^^J char. \catcode`\%=12 \immediate\pdfobj stream {%!PS-Adobe-3.0 Resource-CMap %%DocumentNeededResources: ProcSet (CIDInit) %%IncludeResource: ProcSet (CIDInit) %%BeginResource: CMap (TeX-OT1-0) %%Title: (TeX-OT1-0 TeX OT1 0) %%Version: 1.000 %%EndComments /CIDInit /ProcSet findresource begin 12 dict begin begincmap /CIDSystemInfo << /Registry (TeX) /Ordering (OT1) /Supplement 0 >> def /CMapName /TeX-OT1-0 def /CMapType 2 def 1 begincodespacerange <00> <7F> endcodespacerange 8 beginbfrange <00> <01> <0393> <09> <0A> <03A8> <23> <26> <0023> <28> <3B> <0028> <3F> <5B> <003F> <5D> <5E> <005D> <61> <7A> <0061> <7B> <7C> <2013> endbfrange 40 beginbfchar <02> <0398> <03> <039B> <04> <039E> <05> <03A0> <06> <03A3> <07> <03D2> <08> <03A6> <0B> <00660066> <0C> <00660069> <0D> <0066006C> <0E> <006600660069> <0F> <00660066006C> <10> <0131> <11> <0237> <12> <0060> <13> <00B4> <14> <02C7> <15> <02D8> <16> <00AF> <17> <02DA> <18> <00B8> <19> <00DF> <1A> <00E6> <1B> <0153> <1C> <00F8> <1D> <00C6> <1E> <0152> <1F> <00D8> <21> <0021> <22> <201D> <27> <2019> <3C> <00A1> <3D> <003D> <3E> <00BF> <5C> <201C> <5F> <02D9> <60> <2018> <7D> <02DD> <7E> <007E> <7F> <00A8> endbfchar endcmap CMapName currentdict /CMap defineresource pop end end %%EndResource %%EOF }\endgroup \expandafter\edef\csname cmapOT1\endcsname#1{% \pdffontattr#1{/ToUnicode \the\pdflastobj\space 0 R}% }% % % \cmapOT1IT \begingroup \catcode`\^^M=\active \def^^M{^^J}% Output line endings as the ^^J char. \catcode`\%=12 \immediate\pdfobj stream {%!PS-Adobe-3.0 Resource-CMap %%DocumentNeededResources: ProcSet (CIDInit) %%IncludeResource: ProcSet (CIDInit) %%BeginResource: CMap (TeX-OT1IT-0) %%Title: (TeX-OT1IT-0 TeX OT1IT 0) %%Version: 1.000 %%EndComments /CIDInit /ProcSet findresource begin 12 dict begin begincmap /CIDSystemInfo << /Registry (TeX) /Ordering (OT1IT) /Supplement 0 >> def /CMapName /TeX-OT1IT-0 def /CMapType 2 def 1 begincodespacerange <00> <7F> endcodespacerange 8 beginbfrange <00> <01> <0393> <09> <0A> <03A8> <25> <26> <0025> <28> <3B> <0028> <3F> <5B> <003F> <5D> <5E> <005D> <61> <7A> <0061> <7B> <7C> <2013> endbfrange 42 beginbfchar <02> <0398> <03> <039B> <04> <039E> <05> <03A0> <06> <03A3> <07> <03D2> <08> <03A6> <0B> <00660066> <0C> <00660069> <0D> <0066006C> <0E> <006600660069> <0F> <00660066006C> <10> <0131> <11> <0237> <12> <0060> <13> <00B4> <14> <02C7> <15> <02D8> <16> <00AF> <17> <02DA> <18> <00B8> <19> <00DF> <1A> <00E6> <1B> <0153> <1C> <00F8> <1D> <00C6> <1E> <0152> <1F> <00D8> <21> <0021> <22> <201D> <23> <0023> <24> <00A3> <27> <2019> <3C> <00A1> <3D> <003D> <3E> <00BF> <5C> <201C> <5F> <02D9> <60> <2018> <7D> <02DD> <7E> <007E> <7F> <00A8> endbfchar endcmap CMapName currentdict /CMap defineresource pop end end %%EndResource %%EOF }\endgroup \expandafter\edef\csname cmapOT1IT\endcsname#1{% \pdffontattr#1{/ToUnicode \the\pdflastobj\space 0 R}% }% % % \cmapOT1TT \begingroup \catcode`\^^M=\active \def^^M{^^J}% Output line endings as the ^^J char. \catcode`\%=12 \immediate\pdfobj stream {%!PS-Adobe-3.0 Resource-CMap %%DocumentNeededResources: ProcSet (CIDInit) %%IncludeResource: ProcSet (CIDInit) %%BeginResource: CMap (TeX-OT1TT-0) %%Title: (TeX-OT1TT-0 TeX OT1TT 0) %%Version: 1.000 %%EndComments /CIDInit /ProcSet findresource begin 12 dict begin begincmap /CIDSystemInfo << /Registry (TeX) /Ordering (OT1TT) /Supplement 0 >> def /CMapName /TeX-OT1TT-0 def /CMapType 2 def 1 begincodespacerange <00> <7F> endcodespacerange 5 beginbfrange <00> <01> <0393> <09> <0A> <03A8> <21> <26> <0021> <28> <5F> <0028> <61> <7E> <0061> endbfrange 32 beginbfchar <02> <0398> <03> <039B> <04> <039E> <05> <03A0> <06> <03A3> <07> <03D2> <08> <03A6> <0B> <2191> <0C> <2193> <0D> <0027> <0E> <00A1> <0F> <00BF> <10> <0131> <11> <0237> <12> <0060> <13> <00B4> <14> <02C7> <15> <02D8> <16> <00AF> <17> <02DA> <18> <00B8> <19> <00DF> <1A> <00E6> <1B> <0153> <1C> <00F8> <1D> <00C6> <1E> <0152> <1F> <00D8> <20> <2423> <27> <2019> <60> <2018> <7F> <00A8> endbfchar endcmap CMapName currentdict /CMap defineresource pop end end %%EndResource %%EOF }\endgroup \expandafter\edef\csname cmapOT1TT\endcsname#1{% \pdffontattr#1{/ToUnicode \the\pdflastobj\space 0 R}% }% \else \expandafter\let\csname cmapOT1\endcsname\gobble \expandafter\let\csname cmapOT1IT\endcsname\gobble \expandafter\let\csname cmapOT1TT\endcsname\gobble \fi % Set the font macro #1 to the font named #2, adding on the % specified font prefix (normally `cm'). % #3 is the font's design size, #4 is a scale factor, #5 is the CMap % encoding (currently only OT1, OT1IT and OT1TT are allowed, pass % empty to omit). \def\setfont#1#2#3#4#5{% \font#1=\fontprefix#2#3 scaled #4 \csname cmap#5\endcsname#1% } % This is what gets called when #5 of \setfont is empty. \let\cmap\gobble % Use cm as the default font prefix. % To specify the font prefix, you must define \fontprefix % before you read in texinfo.tex. \ifx\fontprefix\undefined \def\fontprefix{cm} \fi % Support font families that don't use the same naming scheme as CM. \def\rmshape{r} \def\rmbshape{bx} %where the normal face is bold \def\bfshape{b} \def\bxshape{bx} \def\ttshape{tt} \def\ttbshape{tt} \def\ttslshape{sltt} \def\itshape{ti} \def\itbshape{bxti} \def\slshape{sl} \def\slbshape{bxsl} \def\sfshape{ss} \def\sfbshape{ss} \def\scshape{csc} \def\scbshape{csc} % Definitions for a main text size of 11pt. This is the default in % Texinfo. % \def\definetextfontsizexi{% % Text fonts (11.2pt, magstep1). \def\textnominalsize{11pt} \edef\mainmagstep{\magstephalf} \setfont\textrm\rmshape{10}{\mainmagstep}{OT1} \setfont\texttt\ttshape{10}{\mainmagstep}{OT1TT} \setfont\textbf\bfshape{10}{\mainmagstep}{OT1} \setfont\textit\itshape{10}{\mainmagstep}{OT1IT} \setfont\textsl\slshape{10}{\mainmagstep}{OT1} \setfont\textsf\sfshape{10}{\mainmagstep}{OT1} \setfont\textsc\scshape{10}{\mainmagstep}{OT1} \setfont\textttsl\ttslshape{10}{\mainmagstep}{OT1TT} \font\texti=cmmi10 scaled \mainmagstep \font\textsy=cmsy10 scaled \mainmagstep \def\textecsize{1095} % A few fonts for @defun names and args. \setfont\defbf\bfshape{10}{\magstep1}{OT1} \setfont\deftt\ttshape{10}{\magstep1}{OT1TT} \setfont\defttsl\ttslshape{10}{\magstep1}{OT1TT} \def\df{\let\tentt=\deftt \let\tenbf = \defbf \let\tenttsl=\defttsl \bf} % Fonts for indices, footnotes, small examples (9pt). \def\smallnominalsize{9pt} \setfont\smallrm\rmshape{9}{1000}{OT1} \setfont\smalltt\ttshape{9}{1000}{OT1TT} \setfont\smallbf\bfshape{10}{900}{OT1} \setfont\smallit\itshape{9}{1000}{OT1IT} \setfont\smallsl\slshape{9}{1000}{OT1} \setfont\smallsf\sfshape{9}{1000}{OT1} \setfont\smallsc\scshape{10}{900}{OT1} \setfont\smallttsl\ttslshape{10}{900}{OT1TT} \font\smalli=cmmi9 \font\smallsy=cmsy9 \def\smallecsize{0900} % Fonts for small examples (8pt). \def\smallernominalsize{8pt} \setfont\smallerrm\rmshape{8}{1000}{OT1} \setfont\smallertt\ttshape{8}{1000}{OT1TT} \setfont\smallerbf\bfshape{10}{800}{OT1} \setfont\smallerit\itshape{8}{1000}{OT1IT} \setfont\smallersl\slshape{8}{1000}{OT1} \setfont\smallersf\sfshape{8}{1000}{OT1} \setfont\smallersc\scshape{10}{800}{OT1} \setfont\smallerttsl\ttslshape{10}{800}{OT1TT} \font\smalleri=cmmi8 \font\smallersy=cmsy8 \def\smallerecsize{0800} % Fonts for title page (20.4pt): \def\titlenominalsize{20pt} \setfont\titlerm\rmbshape{12}{\magstep3}{OT1} \setfont\titleit\itbshape{10}{\magstep4}{OT1IT} \setfont\titlesl\slbshape{10}{\magstep4}{OT1} \setfont\titlett\ttbshape{12}{\magstep3}{OT1TT} \setfont\titlettsl\ttslshape{10}{\magstep4}{OT1TT} \setfont\titlesf\sfbshape{17}{\magstep1}{OT1} \let\titlebf=\titlerm \setfont\titlesc\scbshape{10}{\magstep4}{OT1} \font\titlei=cmmi12 scaled \magstep3 \font\titlesy=cmsy10 scaled \magstep4 \def\authorrm{\secrm} \def\authortt{\sectt} \def\titleecsize{2074} % Chapter (and unnumbered) fonts (17.28pt). \def\chapnominalsize{17pt} \setfont\chaprm\rmbshape{12}{\magstep2}{OT1} \setfont\chapit\itbshape{10}{\magstep3}{OT1IT} \setfont\chapsl\slbshape{10}{\magstep3}{OT1} \setfont\chaptt\ttbshape{12}{\magstep2}{OT1TT} \setfont\chapttsl\ttslshape{10}{\magstep3}{OT1TT} \setfont\chapsf\sfbshape{17}{1000}{OT1} \let\chapbf=\chaprm \setfont\chapsc\scbshape{10}{\magstep3}{OT1} \font\chapi=cmmi12 scaled \magstep2 \font\chapsy=cmsy10 scaled \magstep3 \def\chapecsize{1728} % Section fonts (14.4pt). \def\secnominalsize{14pt} \setfont\secrm\rmbshape{12}{\magstep1}{OT1} \setfont\secit\itbshape{10}{\magstep2}{OT1IT} \setfont\secsl\slbshape{10}{\magstep2}{OT1} \setfont\sectt\ttbshape{12}{\magstep1}{OT1TT} \setfont\secttsl\ttslshape{10}{\magstep2}{OT1TT} \setfont\secsf\sfbshape{12}{\magstep1}{OT1} \let\secbf\secrm \setfont\secsc\scbshape{10}{\magstep2}{OT1} \font\seci=cmmi12 scaled \magstep1 \font\secsy=cmsy10 scaled \magstep2 \def\sececsize{1440} % Subsection fonts (13.15pt). \def\ssecnominalsize{13pt} \setfont\ssecrm\rmbshape{12}{\magstephalf}{OT1} \setfont\ssecit\itbshape{10}{1315}{OT1IT} \setfont\ssecsl\slbshape{10}{1315}{OT1} \setfont\ssectt\ttbshape{12}{\magstephalf}{OT1TT} \setfont\ssecttsl\ttslshape{10}{1315}{OT1TT} \setfont\ssecsf\sfbshape{12}{\magstephalf}{OT1} \let\ssecbf\ssecrm \setfont\ssecsc\scbshape{10}{1315}{OT1} \font\sseci=cmmi12 scaled \magstephalf \font\ssecsy=cmsy10 scaled 1315 \def\ssececsize{1200} % Reduced fonts for @acro in text (10pt). \def\reducednominalsize{10pt} \setfont\reducedrm\rmshape{10}{1000}{OT1} \setfont\reducedtt\ttshape{10}{1000}{OT1TT} \setfont\reducedbf\bfshape{10}{1000}{OT1} \setfont\reducedit\itshape{10}{1000}{OT1IT} \setfont\reducedsl\slshape{10}{1000}{OT1} \setfont\reducedsf\sfshape{10}{1000}{OT1} \setfont\reducedsc\scshape{10}{1000}{OT1} \setfont\reducedttsl\ttslshape{10}{1000}{OT1TT} \font\reducedi=cmmi10 \font\reducedsy=cmsy10 \def\reducedecsize{1000} % reset the current fonts \textfonts \rm } % end of 11pt text font size definitions % Definitions to make the main text be 10pt Computer Modern, with % section, chapter, etc., sizes following suit. This is for the GNU % Press printing of the Emacs 22 manual. Maybe other manuals in the % future. Used with @smallbook, which sets the leading to 12pt. % \def\definetextfontsizex{% % Text fonts (10pt). \def\textnominalsize{10pt} \edef\mainmagstep{1000} \setfont\textrm\rmshape{10}{\mainmagstep}{OT1} \setfont\texttt\ttshape{10}{\mainmagstep}{OT1TT} \setfont\textbf\bfshape{10}{\mainmagstep}{OT1} \setfont\textit\itshape{10}{\mainmagstep}{OT1IT} \setfont\textsl\slshape{10}{\mainmagstep}{OT1} \setfont\textsf\sfshape{10}{\mainmagstep}{OT1} \setfont\textsc\scshape{10}{\mainmagstep}{OT1} \setfont\textttsl\ttslshape{10}{\mainmagstep}{OT1TT} \font\texti=cmmi10 scaled \mainmagstep \font\textsy=cmsy10 scaled \mainmagstep \def\textecsize{1000} % A few fonts for @defun names and args. \setfont\defbf\bfshape{10}{\magstephalf}{OT1} \setfont\deftt\ttshape{10}{\magstephalf}{OT1TT} \setfont\defttsl\ttslshape{10}{\magstephalf}{OT1TT} \def\df{\let\tentt=\deftt \let\tenbf = \defbf \let\tenttsl=\defttsl \bf} % Fonts for indices, footnotes, small examples (9pt). \def\smallnominalsize{9pt} \setfont\smallrm\rmshape{9}{1000}{OT1} \setfont\smalltt\ttshape{9}{1000}{OT1TT} \setfont\smallbf\bfshape{10}{900}{OT1} \setfont\smallit\itshape{9}{1000}{OT1IT} \setfont\smallsl\slshape{9}{1000}{OT1} \setfont\smallsf\sfshape{9}{1000}{OT1} \setfont\smallsc\scshape{10}{900}{OT1} \setfont\smallttsl\ttslshape{10}{900}{OT1TT} \font\smalli=cmmi9 \font\smallsy=cmsy9 \def\smallecsize{0900} % Fonts for small examples (8pt). \def\smallernominalsize{8pt} \setfont\smallerrm\rmshape{8}{1000}{OT1} \setfont\smallertt\ttshape{8}{1000}{OT1TT} \setfont\smallerbf\bfshape{10}{800}{OT1} \setfont\smallerit\itshape{8}{1000}{OT1IT} \setfont\smallersl\slshape{8}{1000}{OT1} \setfont\smallersf\sfshape{8}{1000}{OT1} \setfont\smallersc\scshape{10}{800}{OT1} \setfont\smallerttsl\ttslshape{10}{800}{OT1TT} \font\smalleri=cmmi8 \font\smallersy=cmsy8 \def\smallerecsize{0800} % Fonts for title page (20.4pt): \def\titlenominalsize{20pt} \setfont\titlerm\rmbshape{12}{\magstep3}{OT1} \setfont\titleit\itbshape{10}{\magstep4}{OT1IT} \setfont\titlesl\slbshape{10}{\magstep4}{OT1} \setfont\titlett\ttbshape{12}{\magstep3}{OT1TT} \setfont\titlettsl\ttslshape{10}{\magstep4}{OT1TT} \setfont\titlesf\sfbshape{17}{\magstep1}{OT1} \let\titlebf=\titlerm \setfont\titlesc\scbshape{10}{\magstep4}{OT1} \font\titlei=cmmi12 scaled \magstep3 \font\titlesy=cmsy10 scaled \magstep4 \def\authorrm{\secrm} \def\authortt{\sectt} \def\titleecsize{2074} % Chapter fonts (14.4pt). \def\chapnominalsize{14pt} \setfont\chaprm\rmbshape{12}{\magstep1}{OT1} \setfont\chapit\itbshape{10}{\magstep2}{OT1IT} \setfont\chapsl\slbshape{10}{\magstep2}{OT1} \setfont\chaptt\ttbshape{12}{\magstep1}{OT1TT} \setfont\chapttsl\ttslshape{10}{\magstep2}{OT1TT} \setfont\chapsf\sfbshape{12}{\magstep1}{OT1} \let\chapbf\chaprm \setfont\chapsc\scbshape{10}{\magstep2}{OT1} \font\chapi=cmmi12 scaled \magstep1 \font\chapsy=cmsy10 scaled \magstep2 \def\chapecsize{1440} % Section fonts (12pt). \def\secnominalsize{12pt} \setfont\secrm\rmbshape{12}{1000}{OT1} \setfont\secit\itbshape{10}{\magstep1}{OT1IT} \setfont\secsl\slbshape{10}{\magstep1}{OT1} \setfont\sectt\ttbshape{12}{1000}{OT1TT} \setfont\secttsl\ttslshape{10}{\magstep1}{OT1TT} \setfont\secsf\sfbshape{12}{1000}{OT1} \let\secbf\secrm \setfont\secsc\scbshape{10}{\magstep1}{OT1} \font\seci=cmmi12 \font\secsy=cmsy10 scaled \magstep1 \def\sececsize{1200} % Subsection fonts (10pt). \def\ssecnominalsize{10pt} \setfont\ssecrm\rmbshape{10}{1000}{OT1} \setfont\ssecit\itbshape{10}{1000}{OT1IT} \setfont\ssecsl\slbshape{10}{1000}{OT1} \setfont\ssectt\ttbshape{10}{1000}{OT1TT} \setfont\ssecttsl\ttslshape{10}{1000}{OT1TT} \setfont\ssecsf\sfbshape{10}{1000}{OT1} \let\ssecbf\ssecrm \setfont\ssecsc\scbshape{10}{1000}{OT1} \font\sseci=cmmi10 \font\ssecsy=cmsy10 \def\ssececsize{1000} % Reduced fonts for @acro in text (9pt). \def\reducednominalsize{9pt} \setfont\reducedrm\rmshape{9}{1000}{OT1} \setfont\reducedtt\ttshape{9}{1000}{OT1TT} \setfont\reducedbf\bfshape{10}{900}{OT1} \setfont\reducedit\itshape{9}{1000}{OT1IT} \setfont\reducedsl\slshape{9}{1000}{OT1} \setfont\reducedsf\sfshape{9}{1000}{OT1} \setfont\reducedsc\scshape{10}{900}{OT1} \setfont\reducedttsl\ttslshape{10}{900}{OT1TT} \font\reducedi=cmmi9 \font\reducedsy=cmsy9 \def\reducedecsize{0900} % reduce space between paragraphs \divide\parskip by 2 % reset the current fonts \textfonts \rm } % end of 10pt text font size definitions % We provide the user-level command % @fonttextsize 10 % (or 11) to redefine the text font size. pt is assumed. % \def\xword{10} \def\xiword{11} % \parseargdef\fonttextsize{% \def\textsizearg{#1}% \wlog{doing @fonttextsize \textsizearg}% % % Set \globaldefs so that documents can use this inside @tex, since % makeinfo 4.8 does not support it, but we need it nonetheless. % \begingroup \globaldefs=1 \ifx\textsizearg\xword \definetextfontsizex \else \ifx\textsizearg\xiword \definetextfontsizexi \else \errhelp=\EMsimple \errmessage{@fonttextsize only supports `10' or `11', not `\textsizearg'} \fi\fi \endgroup } % In order for the font changes to affect most math symbols and letters, % we have to define the \textfont of the standard families. Since % texinfo doesn't allow for producing subscripts and superscripts except % in the main text, we don't bother to reset \scriptfont and % \scriptscriptfont (which would also require loading a lot more fonts). % \def\resetmathfonts{% \textfont0=\tenrm \textfont1=\teni \textfont2=\tensy \textfont\itfam=\tenit \textfont\slfam=\tensl \textfont\bffam=\tenbf \textfont\ttfam=\tentt \textfont\sffam=\tensf } % The font-changing commands redefine the meanings of \tenSTYLE, instead % of just \STYLE. We do this because \STYLE needs to also set the % current \fam for math mode. Our \STYLE (e.g., \rm) commands hardwire % \tenSTYLE to set the current font. % % Each font-changing command also sets the names \lsize (one size lower) % and \lllsize (three sizes lower). These relative commands are used in % the LaTeX logo and acronyms. % % This all needs generalizing, badly. % \def\textfonts{% \let\tenrm=\textrm \let\tenit=\textit \let\tensl=\textsl \let\tenbf=\textbf \let\tentt=\texttt \let\smallcaps=\textsc \let\tensf=\textsf \let\teni=\texti \let\tensy=\textsy \let\tenttsl=\textttsl \def\curfontsize{text}% \def\lsize{reduced}\def\lllsize{smaller}% \resetmathfonts \setleading{\textleading}} \def\titlefonts{% \let\tenrm=\titlerm \let\tenit=\titleit \let\tensl=\titlesl \let\tenbf=\titlebf \let\tentt=\titlett \let\smallcaps=\titlesc \let\tensf=\titlesf \let\teni=\titlei \let\tensy=\titlesy \let\tenttsl=\titlettsl \def\curfontsize{title}% \def\lsize{chap}\def\lllsize{subsec}% \resetmathfonts \setleading{25pt}} \def\titlefont#1{{\titlefonts\rm #1}} \def\chapfonts{% \let\tenrm=\chaprm \let\tenit=\chapit \let\tensl=\chapsl \let\tenbf=\chapbf \let\tentt=\chaptt \let\smallcaps=\chapsc \let\tensf=\chapsf \let\teni=\chapi \let\tensy=\chapsy \let\tenttsl=\chapttsl \def\curfontsize{chap}% \def\lsize{sec}\def\lllsize{text}% \resetmathfonts \setleading{19pt}} \def\secfonts{% \let\tenrm=\secrm \let\tenit=\secit \let\tensl=\secsl \let\tenbf=\secbf \let\tentt=\sectt \let\smallcaps=\secsc \let\tensf=\secsf \let\teni=\seci \let\tensy=\secsy \let\tenttsl=\secttsl \def\curfontsize{sec}% \def\lsize{subsec}\def\lllsize{reduced}% \resetmathfonts \setleading{16pt}} \def\subsecfonts{% \let\tenrm=\ssecrm \let\tenit=\ssecit \let\tensl=\ssecsl \let\tenbf=\ssecbf \let\tentt=\ssectt \let\smallcaps=\ssecsc \let\tensf=\ssecsf \let\teni=\sseci \let\tensy=\ssecsy \let\tenttsl=\ssecttsl \def\curfontsize{ssec}% \def\lsize{text}\def\lllsize{small}% \resetmathfonts \setleading{15pt}} \let\subsubsecfonts = \subsecfonts \def\reducedfonts{% \let\tenrm=\reducedrm \let\tenit=\reducedit \let\tensl=\reducedsl \let\tenbf=\reducedbf \let\tentt=\reducedtt \let\reducedcaps=\reducedsc \let\tensf=\reducedsf \let\teni=\reducedi \let\tensy=\reducedsy \let\tenttsl=\reducedttsl \def\curfontsize{reduced}% \def\lsize{small}\def\lllsize{smaller}% \resetmathfonts \setleading{10.5pt}} \def\smallfonts{% \let\tenrm=\smallrm \let\tenit=\smallit \let\tensl=\smallsl \let\tenbf=\smallbf \let\tentt=\smalltt \let\smallcaps=\smallsc \let\tensf=\smallsf \let\teni=\smalli \let\tensy=\smallsy \let\tenttsl=\smallttsl \def\curfontsize{small}% \def\lsize{smaller}\def\lllsize{smaller}% \resetmathfonts \setleading{10.5pt}} \def\smallerfonts{% \let\tenrm=\smallerrm \let\tenit=\smallerit \let\tensl=\smallersl \let\tenbf=\smallerbf \let\tentt=\smallertt \let\smallcaps=\smallersc \let\tensf=\smallersf \let\teni=\smalleri \let\tensy=\smallersy \let\tenttsl=\smallerttsl \def\curfontsize{smaller}% \def\lsize{smaller}\def\lllsize{smaller}% \resetmathfonts \setleading{9.5pt}} % Set the fonts to use with the @small... environments. \let\smallexamplefonts = \smallfonts % About \smallexamplefonts. If we use \smallfonts (9pt), @smallexample % can fit this many characters: % 8.5x11=86 smallbook=72 a4=90 a5=69 % If we use \scriptfonts (8pt), then we can fit this many characters: % 8.5x11=90+ smallbook=80 a4=90+ a5=77 % For me, subjectively, the few extra characters that fit aren't worth % the additional smallness of 8pt. So I'm making the default 9pt. % % By the way, for comparison, here's what fits with @example (10pt): % 8.5x11=71 smallbook=60 a4=75 a5=58 % % I wish the USA used A4 paper. % --karl, 24jan03. % Set up the default fonts, so we can use them for creating boxes. % \definetextfontsizexi % Define these so they can be easily changed for other fonts. \def\angleleft{$\langle$} \def\angleright{$\rangle$} % Count depth in font-changes, for error checks \newcount\fontdepth \fontdepth=0 % Fonts for short table of contents. \setfont\shortcontrm\rmshape{12}{1000}{OT1} \setfont\shortcontbf\bfshape{10}{\magstep1}{OT1} % no cmb12 \setfont\shortcontsl\slshape{12}{1000}{OT1} \setfont\shortconttt\ttshape{12}{1000}{OT1TT} %% Add scribe-like font environments, plus @l for inline lisp (usually sans %% serif) and @ii for TeX italic % \smartitalic{ARG} outputs arg in italics, followed by an italic correction % unless the following character is such as not to need one. \def\smartitalicx{\ifx\next,\else\ifx\next-\else\ifx\next.\else \ptexslash\fi\fi\fi} \def\smartslanted#1{{\ifusingtt\ttsl\sl #1}\futurelet\next\smartitalicx} \def\smartitalic#1{{\ifusingtt\ttsl\it #1}\futurelet\next\smartitalicx} % like \smartslanted except unconditionally uses \ttsl. % @var is set to this for defun arguments. \def\ttslanted#1{{\ttsl #1}\futurelet\next\smartitalicx} % like \smartslanted except unconditionally use \sl. We never want % ttsl for book titles, do we? \def\cite#1{{\sl #1}\futurelet\next\smartitalicx} \let\i=\smartitalic \let\slanted=\smartslanted \let\var=\smartslanted \let\dfn=\smartslanted \let\emph=\smartitalic % @b, explicit bold. \def\b#1{{\bf #1}} \let\strong=\b % @sansserif, explicit sans. \def\sansserif#1{{\sf #1}} % We can't just use \exhyphenpenalty, because that only has effect at % the end of a paragraph. Restore normal hyphenation at the end of the % group within which \nohyphenation is presumably called. % \def\nohyphenation{\hyphenchar\font = -1 \aftergroup\restorehyphenation} \def\restorehyphenation{\hyphenchar\font = `- } % Set sfcode to normal for the chars that usually have another value. % Can't use plain's \frenchspacing because it uses the `\x notation, and % sometimes \x has an active definition that messes things up. % \catcode`@=11 \def\plainfrenchspacing{% \sfcode\dotChar =\@m \sfcode\questChar=\@m \sfcode\exclamChar=\@m \sfcode\colonChar=\@m \sfcode\semiChar =\@m \sfcode\commaChar =\@m \def\endofsentencespacefactor{1000}% for @. and friends } \def\plainnonfrenchspacing{% \sfcode`\.3000\sfcode`\?3000\sfcode`\!3000 \sfcode`\:2000\sfcode`\;1500\sfcode`\,1250 \def\endofsentencespacefactor{3000}% for @. and friends } \catcode`@=\other \def\endofsentencespacefactor{3000}% default \def\t#1{% {\tt \rawbackslash \plainfrenchspacing #1}% \null } \def\samp#1{`\tclose{#1}'\null} \setfont\keyrm\rmshape{8}{1000}{OT1} \font\keysy=cmsy9 \def\key#1{{\keyrm\textfont2=\keysy \leavevmode\hbox{% \raise0.4pt\hbox{\angleleft}\kern-.08em\vtop{% \vbox{\hrule\kern-0.4pt \hbox{\raise0.4pt\hbox{\vphantom{\angleleft}}#1}}% \kern-0.4pt\hrule}% \kern-.06em\raise0.4pt\hbox{\angleright}}}} \def\key #1{{\nohyphenation \uppercase{#1}}\null} % The old definition, with no lozenge: %\def\key #1{{\ttsl \nohyphenation \uppercase{#1}}\null} \def\ctrl #1{{\tt \rawbackslash \hat}#1} % @file, @option are the same as @samp. \let\file=\samp \let\option=\samp % @code is a modification of @t, % which makes spaces the same size as normal in the surrounding text. \def\tclose#1{% {% % Change normal interword space to be same as for the current font. \spaceskip = \fontdimen2\font % % Switch to typewriter. \tt % % But `\ ' produces the large typewriter interword space. \def\ {{\spaceskip = 0pt{} }}% % % Turn off hyphenation. \nohyphenation % \rawbackslash \plainfrenchspacing #1% }% \null } % We *must* turn on hyphenation at `-' and `_' in @code. % Otherwise, it is too hard to avoid overfull hboxes % in the Emacs manual, the Library manual, etc. % Unfortunately, TeX uses one parameter (\hyphenchar) to control % both hyphenation at - and hyphenation within words. % We must therefore turn them both off (\tclose does that) % and arrange explicitly to hyphenate at a dash. % -- rms. { \catcode`\-=\active \catcode`\_=\active \catcode`\'=\active \catcode`\`=\active % \global\def\code{\begingroup \catcode\rquoteChar=\active \catcode\lquoteChar=\active \let'\codequoteright \let`\codequoteleft % \catcode\dashChar=\active \catcode\underChar=\active \ifallowcodebreaks \let-\codedash \let_\codeunder \else \let-\realdash \let_\realunder \fi \codex } } \def\realdash{-} \def\codedash{-\discretionary{}{}{}} \def\codeunder{% % this is all so @math{@code{var_name}+1} can work. In math mode, _ % is "active" (mathcode"8000) and \normalunderscore (or \char95, etc.) % will therefore expand the active definition of _, which is us % (inside @code that is), therefore an endless loop. \ifusingtt{\ifmmode \mathchar"075F % class 0=ordinary, family 7=ttfam, pos 0x5F=_. \else\normalunderscore \fi \discretionary{}{}{}}% {\_}% } \def\codex #1{\tclose{#1}\endgroup} % An additional complication: the above will allow breaks after, e.g., % each of the four underscores in __typeof__. This is undesirable in % some manuals, especially if they don't have long identifiers in % general. @allowcodebreaks provides a way to control this. % \newif\ifallowcodebreaks \allowcodebreakstrue \def\keywordtrue{true} \def\keywordfalse{false} \parseargdef\allowcodebreaks{% \def\txiarg{#1}% \ifx\txiarg\keywordtrue \allowcodebreakstrue \else\ifx\txiarg\keywordfalse \allowcodebreaksfalse \else \errhelp = \EMsimple \errmessage{Unknown @allowcodebreaks option `\txiarg'}% \fi\fi } % @kbd is like @code, except that if the argument is just one @key command, % then @kbd has no effect. % @kbdinputstyle -- arg is `distinct' (@kbd uses slanted tty font always), % `example' (@kbd uses ttsl only inside of @example and friends), % or `code' (@kbd uses normal tty font always). \parseargdef\kbdinputstyle{% \def\txiarg{#1}% \ifx\txiarg\worddistinct \gdef\kbdexamplefont{\ttsl}\gdef\kbdfont{\ttsl}% \else\ifx\txiarg\wordexample \gdef\kbdexamplefont{\ttsl}\gdef\kbdfont{\tt}% \else\ifx\txiarg\wordcode \gdef\kbdexamplefont{\tt}\gdef\kbdfont{\tt}% \else \errhelp = \EMsimple \errmessage{Unknown @kbdinputstyle option `\txiarg'}% \fi\fi\fi } \def\worddistinct{distinct} \def\wordexample{example} \def\wordcode{code} % Default is `distinct.' \kbdinputstyle distinct \def\xkey{\key} \def\kbdfoo#1#2#3\par{\def\one{#1}\def\three{#3}\def\threex{??}% \ifx\one\xkey\ifx\threex\three \key{#2}% \else{\tclose{\kbdfont\look}}\fi \else{\tclose{\kbdfont\look}}\fi} % For @indicateurl, @env, @command quotes seem unnecessary, so use \code. \let\indicateurl=\code \let\env=\code \let\command=\code % @uref (abbreviation for `urlref') takes an optional (comma-separated) % second argument specifying the text to display and an optional third % arg as text to display instead of (rather than in addition to) the url % itself. First (mandatory) arg is the url. Perhaps eventually put in % a hypertex \special here. % \def\uref#1{\douref #1,,,\finish} \def\douref#1,#2,#3,#4\finish{\begingroup \unsepspaces \pdfurl{#1}% \setbox0 = \hbox{\ignorespaces #3}% \ifdim\wd0 > 0pt \unhbox0 % third arg given, show only that \else \setbox0 = \hbox{\ignorespaces #2}% \ifdim\wd0 > 0pt \ifpdf \unhbox0 % PDF: 2nd arg given, show only it \else \unhbox0\ (\code{#1})% DVI: 2nd arg given, show both it and url \fi \else \code{#1}% only url given, so show it \fi \fi \endlink \endgroup} % @url synonym for @uref, since that's how everyone uses it. % \let\url=\uref % rms does not like angle brackets --karl, 17may97. % So now @email is just like @uref, unless we are pdf. % %\def\email#1{\angleleft{\tt #1}\angleright} \ifpdf \def\email#1{\doemail#1,,\finish} \def\doemail#1,#2,#3\finish{\begingroup \unsepspaces \pdfurl{mailto:#1}% \setbox0 = \hbox{\ignorespaces #2}% \ifdim\wd0>0pt\unhbox0\else\code{#1}\fi \endlink \endgroup} \else \let\email=\uref \fi % Check if we are currently using a typewriter font. Since all the % Computer Modern typewriter fonts have zero interword stretch (and % shrink), and it is reasonable to expect all typewriter fonts to have % this property, we can check that font parameter. % \def\ifmonospace{\ifdim\fontdimen3\font=0pt } % Typeset a dimension, e.g., `in' or `pt'. The only reason for the % argument is to make the input look right: @dmn{pt} instead of @dmn{}pt. % \def\dmn#1{\thinspace #1} \def\kbd#1{\def\look{#1}\expandafter\kbdfoo\look??\par} % @l was never documented to mean ``switch to the Lisp font'', % and it is not used as such in any manual I can find. We need it for % Polish suppressed-l. --karl, 22sep96. %\def\l#1{{\li #1}\null} % Explicit font changes: @r, @sc, undocumented @ii. \def\r#1{{\rm #1}} % roman font \def\sc#1{{\smallcaps#1}} % smallcaps font \def\ii#1{{\it #1}} % italic font % @acronym for "FBI", "NATO", and the like. % We print this one point size smaller, since it's intended for % all-uppercase. % \def\acronym#1{\doacronym #1,,\finish} \def\doacronym#1,#2,#3\finish{% {\selectfonts\lsize #1}% \def\temp{#2}% \ifx\temp\empty \else \space ({\unsepspaces \ignorespaces \temp \unskip})% \fi } % @abbr for "Comput. J." and the like. % No font change, but don't do end-of-sentence spacing. % \def\abbr#1{\doabbr #1,,\finish} \def\doabbr#1,#2,#3\finish{% {\plainfrenchspacing #1}% \def\temp{#2}% \ifx\temp\empty \else \space ({\unsepspaces \ignorespaces \temp \unskip})% \fi } % @pounds{} is a sterling sign, which Knuth put in the CM italic font. % \def\pounds{{\it\$}} % @euro{} comes from a separate font, depending on the current style. % We use the free feym* fonts from the eurosym package by Henrik % Theiling, which support regular, slanted, bold and bold slanted (and % "outlined" (blackboard board, sort of) versions, which we don't need). % It is available from http://www.ctan.org/tex-archive/fonts/eurosym. % % Although only regular is the truly official Euro symbol, we ignore % that. The Euro is designed to be slightly taller than the regular % font height. % % feymr - regular % feymo - slanted % feybr - bold % feybo - bold slanted % % There is no good (free) typewriter version, to my knowledge. % A feymr10 euro is ~7.3pt wide, while a normal cmtt10 char is ~5.25pt wide. % Hmm. % % Also doesn't work in math. Do we need to do math with euro symbols? % Hope not. % % \def\euro{{\eurofont e}} \def\eurofont{% % We set the font at each command, rather than predefining it in % \textfonts and the other font-switching commands, so that % installations which never need the symbol don't have to have the % font installed. % % There is only one designed size (nominal 10pt), so we always scale % that to the current nominal size. % % By the way, simply using "at 1em" works for cmr10 and the like, but % does not work for cmbx10 and other extended/shrunken fonts. % \def\eurosize{\csname\curfontsize nominalsize\endcsname}% % \ifx\curfontstyle\bfstylename % bold: \font\thiseurofont = \ifusingit{feybo10}{feybr10} at \eurosize \else % regular: \font\thiseurofont = \ifusingit{feymo10}{feymr10} at \eurosize \fi \thiseurofont } % Hacks for glyphs from the EC fonts similar to \euro. We don't % use \let for the aliases, because sometimes we redefine the original % macro, and the alias should reflect the redefinition. \def\guillemetleft{{\ecfont \char"13}} \def\guillemotleft{\guillemetleft} \def\guillemetright{{\ecfont \char"14}} \def\guillemotright{\guillemetright} \def\guilsinglleft{{\ecfont \char"0E}} \def\guilsinglright{{\ecfont \char"0F}} \def\quotedblbase{{\ecfont \char"12}} \def\quotesinglbase{{\ecfont \char"0D}} % \def\ecfont{% % We can't distinguish serif/sanserif and italic/slanted, but this % is used for crude hacks anyway (like adding French and German % quotes to documents typeset with CM, where we lose kerning), so % hopefully nobody will notice/care. \edef\ecsize{\csname\curfontsize ecsize\endcsname}% \edef\nominalsize{\csname\curfontsize nominalsize\endcsname}% \ifx\curfontstyle\bfstylename % bold: \font\thisecfont = ecb\ifusingit{i}{x}\ecsize \space at \nominalsize \else % regular: \font\thisecfont = ec\ifusingit{ti}{rm}\ecsize \space at \nominalsize \fi \thisecfont } % @registeredsymbol - R in a circle. The font for the R should really % be smaller yet, but lllsize is the best we can do for now. % Adapted from the plain.tex definition of \copyright. % \def\registeredsymbol{% $^{{\ooalign{\hfil\raise.07ex\hbox{\selectfonts\lllsize R}% \hfil\crcr\Orb}}% }$% } % @textdegree - the normal degrees sign. % \def\textdegree{$^\circ$} % Laurent Siebenmann reports \Orb undefined with: % Textures 1.7.7 (preloaded format=plain 93.10.14) (68K) 16 APR 2004 02:38 % so we'll define it if necessary. % \ifx\Orb\undefined \def\Orb{\mathhexbox20D} \fi % Quotes. \chardef\quotedblleft="5C \chardef\quotedblright=`\" \chardef\quoteleft=`\` \chardef\quoteright=`\' \message{page headings,} \newskip\titlepagetopglue \titlepagetopglue = 1.5in \newskip\titlepagebottomglue \titlepagebottomglue = 2pc % First the title page. Must do @settitle before @titlepage. \newif\ifseenauthor \newif\iffinishedtitlepage % Do an implicit @contents or @shortcontents after @end titlepage if the % user says @setcontentsaftertitlepage or @setshortcontentsaftertitlepage. % \newif\ifsetcontentsaftertitlepage \let\setcontentsaftertitlepage = \setcontentsaftertitlepagetrue \newif\ifsetshortcontentsaftertitlepage \let\setshortcontentsaftertitlepage = \setshortcontentsaftertitlepagetrue \parseargdef\shorttitlepage{\begingroup\hbox{}\vskip 1.5in \chaprm \centerline{#1}% \endgroup\page\hbox{}\page} \envdef\titlepage{% % Open one extra group, as we want to close it in the middle of \Etitlepage. \begingroup \parindent=0pt \textfonts % Leave some space at the very top of the page. \vglue\titlepagetopglue % No rule at page bottom unless we print one at the top with @title. \finishedtitlepagetrue % % Most title ``pages'' are actually two pages long, with space % at the top of the second. We don't want the ragged left on the second. \let\oldpage = \page \def\page{% \iffinishedtitlepage\else \finishtitlepage \fi \let\page = \oldpage \page \null }% } \def\Etitlepage{% \iffinishedtitlepage\else \finishtitlepage \fi % It is important to do the page break before ending the group, % because the headline and footline are only empty inside the group. % If we use the new definition of \page, we always get a blank page % after the title page, which we certainly don't want. \oldpage \endgroup % % Need this before the \...aftertitlepage checks so that if they are % in effect the toc pages will come out with page numbers. \HEADINGSon % % If they want short, they certainly want long too. \ifsetshortcontentsaftertitlepage \shortcontents \contents \global\let\shortcontents = \relax \global\let\contents = \relax \fi % \ifsetcontentsaftertitlepage \contents \global\let\contents = \relax \global\let\shortcontents = \relax \fi } \def\finishtitlepage{% \vskip4pt \hrule height 2pt width \hsize \vskip\titlepagebottomglue \finishedtitlepagetrue } %%% Macros to be used within @titlepage: \let\subtitlerm=\tenrm \def\subtitlefont{\subtitlerm \normalbaselineskip = 13pt \normalbaselines} \def\authorfont{\authorrm \normalbaselineskip = 16pt \normalbaselines \let\tt=\authortt} \parseargdef\title{% \checkenv\titlepage \leftline{\titlefonts\rm #1} % print a rule at the page bottom also. \finishedtitlepagefalse \vskip4pt \hrule height 4pt width \hsize \vskip4pt } \parseargdef\subtitle{% \checkenv\titlepage {\subtitlefont \rightline{#1}}% } % @author should come last, but may come many times. % It can also be used inside @quotation. % \parseargdef\author{% \def\temp{\quotation}% \ifx\thisenv\temp \def\quotationauthor{#1}% printed in \Equotation. \else \checkenv\titlepage \ifseenauthor\else \vskip 0pt plus 1filll \seenauthortrue \fi {\authorfont \leftline{#1}}% \fi } %%% Set up page headings and footings. \let\thispage=\folio \newtoks\evenheadline % headline on even pages \newtoks\oddheadline % headline on odd pages \newtoks\evenfootline % footline on even pages \newtoks\oddfootline % footline on odd pages % Now make TeX use those variables \headline={{\textfonts\rm \ifodd\pageno \the\oddheadline \else \the\evenheadline \fi}} \footline={{\textfonts\rm \ifodd\pageno \the\oddfootline \else \the\evenfootline \fi}\HEADINGShook} \let\HEADINGShook=\relax % Commands to set those variables. % For example, this is what @headings on does % @evenheading @thistitle|@thispage|@thischapter % @oddheading @thischapter|@thispage|@thistitle % @evenfooting @thisfile|| % @oddfooting ||@thisfile \def\evenheading{\parsearg\evenheadingxxx} \def\evenheadingxxx #1{\evenheadingyyy #1\|\|\|\|\finish} \def\evenheadingyyy #1\|#2\|#3\|#4\finish{% \global\evenheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} \def\oddheading{\parsearg\oddheadingxxx} \def\oddheadingxxx #1{\oddheadingyyy #1\|\|\|\|\finish} \def\oddheadingyyy #1\|#2\|#3\|#4\finish{% \global\oddheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} \parseargdef\everyheading{\oddheadingxxx{#1}\evenheadingxxx{#1}}% \def\evenfooting{\parsearg\evenfootingxxx} \def\evenfootingxxx #1{\evenfootingyyy #1\|\|\|\|\finish} \def\evenfootingyyy #1\|#2\|#3\|#4\finish{% \global\evenfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} \def\oddfooting{\parsearg\oddfootingxxx} \def\oddfootingxxx #1{\oddfootingyyy #1\|\|\|\|\finish} \def\oddfootingyyy #1\|#2\|#3\|#4\finish{% \global\oddfootline = {\rlap{\centerline{#2}}\line{#1\hfil#3}}% % % Leave some space for the footline. Hopefully ok to assume % @evenfooting will not be used by itself. \global\advance\pageheight by -12pt \global\advance\vsize by -12pt } \parseargdef\everyfooting{\oddfootingxxx{#1}\evenfootingxxx{#1}} % @evenheadingmarks top \thischapter <- chapter at the top of a page % @evenheadingmarks bottom \thischapter <- chapter at the bottom of a page % % The same set of arguments for: % % @oddheadingmarks % @evenfootingmarks % @oddfootingmarks % @everyheadingmarks % @everyfootingmarks \def\evenheadingmarks{\headingmarks{even}{heading}} \def\oddheadingmarks{\headingmarks{odd}{heading}} \def\evenfootingmarks{\headingmarks{even}{footing}} \def\oddfootingmarks{\headingmarks{odd}{footing}} \def\everyheadingmarks#1 {\headingmarks{even}{heading}{#1} \headingmarks{odd}{heading}{#1} } \def\everyfootingmarks#1 {\headingmarks{even}{footing}{#1} \headingmarks{odd}{footing}{#1} } % #1 = even/odd, #2 = heading/footing, #3 = top/bottom. \def\headingmarks#1#2#3 {% \expandafter\let\expandafter\temp \csname get#3headingmarks\endcsname \global\expandafter\let\csname get#1#2marks\endcsname \temp } \everyheadingmarks bottom \everyfootingmarks bottom % @headings double turns headings on for double-sided printing. % @headings single turns headings on for single-sided printing. % @headings off turns them off. % @headings on same as @headings double, retained for compatibility. % @headings after turns on double-sided headings after this page. % @headings doubleafter turns on double-sided headings after this page. % @headings singleafter turns on single-sided headings after this page. % By default, they are off at the start of a document, % and turned `on' after @end titlepage. \def\headings #1 {\csname HEADINGS#1\endcsname} \def\HEADINGSoff{% \global\evenheadline={\hfil} \global\evenfootline={\hfil} \global\oddheadline={\hfil} \global\oddfootline={\hfil}} \HEADINGSoff % When we turn headings on, set the page number to 1. % For double-sided printing, put current file name in lower left corner, % chapter name on inside top of right hand pages, document % title on inside top of left hand pages, and page numbers on outside top % edge of all pages. \def\HEADINGSdouble{% \global\pageno=1 \global\evenfootline={\hfil} \global\oddfootline={\hfil} \global\evenheadline={\line{\folio\hfil\thistitle}} \global\oddheadline={\line{\thischapter\hfil\folio}} \global\let\contentsalignmacro = \chapoddpage } \let\contentsalignmacro = \chappager % For single-sided printing, chapter title goes across top left of page, % page number on top right. \def\HEADINGSsingle{% \global\pageno=1 \global\evenfootline={\hfil} \global\oddfootline={\hfil} \global\evenheadline={\line{\thischapter\hfil\folio}} \global\oddheadline={\line{\thischapter\hfil\folio}} \global\let\contentsalignmacro = \chappager } \def\HEADINGSon{\HEADINGSdouble} \def\HEADINGSafter{\let\HEADINGShook=\HEADINGSdoublex} \let\HEADINGSdoubleafter=\HEADINGSafter \def\HEADINGSdoublex{% \global\evenfootline={\hfil} \global\oddfootline={\hfil} \global\evenheadline={\line{\folio\hfil\thistitle}} \global\oddheadline={\line{\thischapter\hfil\folio}} \global\let\contentsalignmacro = \chapoddpage } \def\HEADINGSsingleafter{\let\HEADINGShook=\HEADINGSsinglex} \def\HEADINGSsinglex{% \global\evenfootline={\hfil} \global\oddfootline={\hfil} \global\evenheadline={\line{\thischapter\hfil\folio}} \global\oddheadline={\line{\thischapter\hfil\folio}} \global\let\contentsalignmacro = \chappager } % Subroutines used in generating headings % This produces Day Month Year style of output. % Only define if not already defined, in case a txi-??.tex file has set % up a different format (e.g., txi-cs.tex does this). \ifx\today\undefined \def\today{% \number\day\space \ifcase\month \or\putwordMJan\or\putwordMFeb\or\putwordMMar\or\putwordMApr \or\putwordMMay\or\putwordMJun\or\putwordMJul\or\putwordMAug \or\putwordMSep\or\putwordMOct\or\putwordMNov\or\putwordMDec \fi \space\number\year} \fi % @settitle line... specifies the title of the document, for headings. % It generates no output of its own. \def\thistitle{\putwordNoTitle} \def\settitle{\parsearg{\gdef\thistitle}} \message{tables,} % Tables -- @table, @ftable, @vtable, @item(x). % default indentation of table text \newdimen\tableindent \tableindent=.8in % default indentation of @itemize and @enumerate text \newdimen\itemindent \itemindent=.3in % margin between end of table item and start of table text. \newdimen\itemmargin \itemmargin=.1in % used internally for \itemindent minus \itemmargin \newdimen\itemmax % Note @table, @ftable, and @vtable define @item, @itemx, etc., with % these defs. % They also define \itemindex % to index the item name in whatever manner is desired (perhaps none). \newif\ifitemxneedsnegativevskip \def\itemxpar{\par\ifitemxneedsnegativevskip\nobreak\vskip-\parskip\nobreak\fi} \def\internalBitem{\smallbreak \parsearg\itemzzz} \def\internalBitemx{\itemxpar \parsearg\itemzzz} \def\itemzzz #1{\begingroup % \advance\hsize by -\rightskip \advance\hsize by -\tableindent \setbox0=\hbox{\itemindicate{#1}}% \itemindex{#1}% \nobreak % This prevents a break before @itemx. % % If the item text does not fit in the space we have, put it on a line % by itself, and do not allow a page break either before or after that % line. We do not start a paragraph here because then if the next % command is, e.g., @kindex, the whatsit would get put into the % horizontal list on a line by itself, resulting in extra blank space. \ifdim \wd0>\itemmax % % Make this a paragraph so we get the \parskip glue and wrapping, % but leave it ragged-right. \begingroup \advance\leftskip by-\tableindent \advance\hsize by\tableindent \advance\rightskip by0pt plus1fil \leavevmode\unhbox0\par \endgroup % % We're going to be starting a paragraph, but we don't want the % \parskip glue -- logically it's part of the @item we just started. \nobreak \vskip-\parskip % % Stop a page break at the \parskip glue coming up. However, if % what follows is an environment such as @example, there will be no % \parskip glue; then the negative vskip we just inserted would % cause the example and the item to crash together. So we use this % bizarre value of 10001 as a signal to \aboveenvbreak to insert % \parskip glue after all. Section titles are handled this way also. % \penalty 10001 \endgroup \itemxneedsnegativevskipfalse \else % The item text fits into the space. Start a paragraph, so that the % following text (if any) will end up on the same line. \noindent % Do this with kerns and \unhbox so that if there is a footnote in % the item text, it can migrate to the main vertical list and % eventually be printed. \nobreak\kern-\tableindent \dimen0 = \itemmax \advance\dimen0 by \itemmargin \advance\dimen0 by -\wd0 \unhbox0 \nobreak\kern\dimen0 \endgroup \itemxneedsnegativevskiptrue \fi } \def\item{\errmessage{@item while not in a list environment}} \def\itemx{\errmessage{@itemx while not in a list environment}} % @table, @ftable, @vtable. \envdef\table{% \let\itemindex\gobble \tablecheck{table}% } \envdef\ftable{% \def\itemindex ##1{\doind {fn}{\code{##1}}}% \tablecheck{ftable}% } \envdef\vtable{% \def\itemindex ##1{\doind {vr}{\code{##1}}}% \tablecheck{vtable}% } \def\tablecheck#1{% \ifnum \the\catcode`\^^M=\active \endgroup \errmessage{This command won't work in this context; perhaps the problem is that we are \inenvironment\thisenv}% \def\next{\doignore{#1}}% \else \let\next\tablex \fi \next } \def\tablex#1{% \def\itemindicate{#1}% \parsearg\tabley } \def\tabley#1{% {% \makevalueexpandable \edef\temp{\noexpand\tablez #1\space\space\space}% \expandafter }\temp \endtablez } \def\tablez #1 #2 #3 #4\endtablez{% \aboveenvbreak \ifnum 0#1>0 \advance \leftskip by #1\mil \fi \ifnum 0#2>0 \tableindent=#2\mil \fi \ifnum 0#3>0 \advance \rightskip by #3\mil \fi \itemmax=\tableindent \advance \itemmax by -\itemmargin \advance \leftskip by \tableindent \exdentamount=\tableindent \parindent = 0pt \parskip = \smallskipamount \ifdim \parskip=0pt \parskip=2pt \fi \let\item = \internalBitem \let\itemx = \internalBitemx } \def\Etable{\endgraf\afterenvbreak} \let\Eftable\Etable \let\Evtable\Etable \let\Eitemize\Etable \let\Eenumerate\Etable % This is the counter used by @enumerate, which is really @itemize \newcount \itemno \envdef\itemize{\parsearg\doitemize} \def\doitemize#1{% \aboveenvbreak \itemmax=\itemindent \advance\itemmax by -\itemmargin \advance\leftskip by \itemindent \exdentamount=\itemindent \parindent=0pt \parskip=\smallskipamount \ifdim\parskip=0pt \parskip=2pt \fi \def\itemcontents{#1}% % @itemize with no arg is equivalent to @itemize @bullet. \ifx\itemcontents\empty\def\itemcontents{\bullet}\fi \let\item=\itemizeitem } % Definition of @item while inside @itemize and @enumerate. % \def\itemizeitem{% \advance\itemno by 1 % for enumerations {\let\par=\endgraf \smallbreak}% reasonable place to break {% % If the document has an @itemize directly after a section title, a % \nobreak will be last on the list, and \sectionheading will have % done a \vskip-\parskip. In that case, we don't want to zero % parskip, or the item text will crash with the heading. On the % other hand, when there is normal text preceding the item (as there % usually is), we do want to zero parskip, or there would be too much % space. In that case, we won't have a \nobreak before. At least % that's the theory. \ifnum\lastpenalty<10000 \parskip=0in \fi \noindent \hbox to 0pt{\hss \itemcontents \kern\itemmargin}% \vadjust{\penalty 1200}}% not good to break after first line of item. \flushcr } % \splitoff TOKENS\endmark defines \first to be the first token in % TOKENS, and \rest to be the remainder. % \def\splitoff#1#2\endmark{\def\first{#1}\def\rest{#2}}% % Allow an optional argument of an uppercase letter, lowercase letter, % or number, to specify the first label in the enumerated list. No % argument is the same as `1'. % \envparseargdef\enumerate{\enumeratey #1 \endenumeratey} \def\enumeratey #1 #2\endenumeratey{% % If we were given no argument, pretend we were given `1'. \def\thearg{#1}% \ifx\thearg\empty \def\thearg{1}\fi % % Detect if the argument is a single token. If so, it might be a % letter. Otherwise, the only valid thing it can be is a number. % (We will always have one token, because of the test we just made. % This is a good thing, since \splitoff doesn't work given nothing at % all -- the first parameter is undelimited.) \expandafter\splitoff\thearg\endmark \ifx\rest\empty % Only one token in the argument. It could still be anything. % A ``lowercase letter'' is one whose \lccode is nonzero. % An ``uppercase letter'' is one whose \lccode is both nonzero, and % not equal to itself. % Otherwise, we assume it's a number. % % We need the \relax at the end of the \ifnum lines to stop TeX from % continuing to look for a . % \ifnum\lccode\expandafter`\thearg=0\relax \numericenumerate % a number (we hope) \else % It's a letter. \ifnum\lccode\expandafter`\thearg=\expandafter`\thearg\relax \lowercaseenumerate % lowercase letter \else \uppercaseenumerate % uppercase letter \fi \fi \else % Multiple tokens in the argument. We hope it's a number. \numericenumerate \fi } % An @enumerate whose labels are integers. The starting integer is % given in \thearg. % \def\numericenumerate{% \itemno = \thearg \startenumeration{\the\itemno}% } % The starting (lowercase) letter is in \thearg. \def\lowercaseenumerate{% \itemno = \expandafter`\thearg \startenumeration{% % Be sure we're not beyond the end of the alphabet. \ifnum\itemno=0 \errmessage{No more lowercase letters in @enumerate; get a bigger alphabet}% \fi \char\lccode\itemno }% } % The starting (uppercase) letter is in \thearg. \def\uppercaseenumerate{% \itemno = \expandafter`\thearg \startenumeration{% % Be sure we're not beyond the end of the alphabet. \ifnum\itemno=0 \errmessage{No more uppercase letters in @enumerate; get a bigger alphabet} \fi \char\uccode\itemno }% } % Call \doitemize, adding a period to the first argument and supplying the % common last two arguments. Also subtract one from the initial value in % \itemno, since @item increments \itemno. % \def\startenumeration#1{% \advance\itemno by -1 \doitemize{#1.}\flushcr } % @alphaenumerate and @capsenumerate are abbreviations for giving an arg % to @enumerate. % \def\alphaenumerate{\enumerate{a}} \def\capsenumerate{\enumerate{A}} \def\Ealphaenumerate{\Eenumerate} \def\Ecapsenumerate{\Eenumerate} % @multitable macros % Amy Hendrickson, 8/18/94, 3/6/96 % % @multitable ... @end multitable will make as many columns as desired. % Contents of each column will wrap at width given in preamble. Width % can be specified either with sample text given in a template line, % or in percent of \hsize, the current width of text on page. % Table can continue over pages but will only break between lines. % To make preamble: % % Either define widths of columns in terms of percent of \hsize: % @multitable @columnfractions .25 .3 .45 % @item ... % % Numbers following @columnfractions are the percent of the total % current hsize to be used for each column. You may use as many % columns as desired. % Or use a template: % @multitable {Column 1 template} {Column 2 template} {Column 3 template} % @item ... % using the widest term desired in each column. % Each new table line starts with @item, each subsequent new column % starts with @tab. Empty columns may be produced by supplying @tab's % with nothing between them for as many times as empty columns are needed, % ie, @tab@tab@tab will produce two empty columns. % @item, @tab do not need to be on their own lines, but it will not hurt % if they are. % Sample multitable: % @multitable {Column 1 template} {Column 2 template} {Column 3 template} % @item first col stuff @tab second col stuff @tab third col % @item % first col stuff % @tab % second col stuff % @tab % third col % @item first col stuff @tab second col stuff % @tab Many paragraphs of text may be used in any column. % % They will wrap at the width determined by the template. % @item@tab@tab This will be in third column. % @end multitable % Default dimensions may be reset by user. % @multitableparskip is vertical space between paragraphs in table. % @multitableparindent is paragraph indent in table. % @multitablecolmargin is horizontal space to be left between columns. % @multitablelinespace is space to leave between table items, baseline % to baseline. % 0pt means it depends on current normal line spacing. % \newskip\multitableparskip \newskip\multitableparindent \newdimen\multitablecolspace \newskip\multitablelinespace \multitableparskip=0pt \multitableparindent=6pt \multitablecolspace=12pt \multitablelinespace=0pt % Macros used to set up halign preamble: % \let\endsetuptable\relax \def\xendsetuptable{\endsetuptable} \let\columnfractions\relax \def\xcolumnfractions{\columnfractions} \newif\ifsetpercent % #1 is the @columnfraction, usually a decimal number like .5, but might % be just 1. We just use it, whatever it is. % \def\pickupwholefraction#1 {% \global\advance\colcount by 1 \expandafter\xdef\csname col\the\colcount\endcsname{#1\hsize}% \setuptable } \newcount\colcount \def\setuptable#1{% \def\firstarg{#1}% \ifx\firstarg\xendsetuptable \let\go = \relax \else \ifx\firstarg\xcolumnfractions \global\setpercenttrue \else \ifsetpercent \let\go\pickupwholefraction \else \global\advance\colcount by 1 \setbox0=\hbox{#1\unskip\space}% Add a normal word space as a % separator; typically that is always in the input, anyway. \expandafter\xdef\csname col\the\colcount\endcsname{\the\wd0}% \fi \fi \ifx\go\pickupwholefraction % Put the argument back for the \pickupwholefraction call, so % we'll always have a period there to be parsed. \def\go{\pickupwholefraction#1}% \else \let\go = \setuptable \fi% \fi \go } % multitable-only commands. % % @headitem starts a heading row, which we typeset in bold. % Assignments have to be global since we are inside the implicit group % of an alignment entry. Note that \everycr resets \everytab. \def\headitem{\checkenv\multitable \crcr \global\everytab={\bf}\the\everytab}% % % A \tab used to include \hskip1sp. But then the space in a template % line is not enough. That is bad. So let's go back to just `&' until % we encounter the problem it was intended to solve again. % --karl, nathan@acm.org, 20apr99. \def\tab{\checkenv\multitable &\the\everytab}% % @multitable ... @end multitable definitions: % \newtoks\everytab % insert after every tab. % \envdef\multitable{% \vskip\parskip \startsavinginserts % % @item within a multitable starts a normal row. % We use \def instead of \let so that if one of the multitable entries % contains an @itemize, we don't choke on the \item (seen as \crcr aka % \endtemplate) expanding \doitemize. \def\item{\crcr}% % \tolerance=9500 \hbadness=9500 \setmultitablespacing \parskip=\multitableparskip \parindent=\multitableparindent \overfullrule=0pt \global\colcount=0 % \everycr = {% \noalign{% \global\everytab={}% \global\colcount=0 % Reset the column counter. % Check for saved footnotes, etc. \checkinserts % Keeps underfull box messages off when table breaks over pages. %\filbreak % Maybe so, but it also creates really weird page breaks when the % table breaks over pages. Wouldn't \vfil be better? Wait until the % problem manifests itself, so it can be fixed for real --karl. }% }% % \parsearg\domultitable } \def\domultitable#1{% % To parse everything between @multitable and @item: \setuptable#1 \endsetuptable % % This preamble sets up a generic column definition, which will % be used as many times as user calls for columns. % \vtop will set a single line and will also let text wrap and % continue for many paragraphs if desired. \halign\bgroup &% \global\advance\colcount by 1 \multistrut \vtop{% % Use the current \colcount to find the correct column width: \hsize=\expandafter\csname col\the\colcount\endcsname % % In order to keep entries from bumping into each other % we will add a \leftskip of \multitablecolspace to all columns after % the first one. % % If a template has been used, we will add \multitablecolspace % to the width of each template entry. % % If the user has set preamble in terms of percent of \hsize we will % use that dimension as the width of the column, and the \leftskip % will keep entries from bumping into each other. Table will start at % left margin and final column will justify at right margin. % % Make sure we don't inherit \rightskip from the outer environment. \rightskip=0pt \ifnum\colcount=1 % The first column will be indented with the surrounding text. \advance\hsize by\leftskip \else \ifsetpercent \else % If user has not set preamble in terms of percent of \hsize % we will advance \hsize by \multitablecolspace. \advance\hsize by \multitablecolspace \fi % In either case we will make \leftskip=\multitablecolspace: \leftskip=\multitablecolspace \fi % Ignoring space at the beginning and end avoids an occasional spurious % blank line, when TeX decides to break the line at the space before the % box from the multistrut, so the strut ends up on a line by itself. % For example: % @multitable @columnfractions .11 .89 % @item @code{#} % @tab Legal holiday which is valid in major parts of the whole country. % Is automatically provided with highlighting sequences respectively % marking characters. \noindent\ignorespaces##\unskip\multistrut }\cr } \def\Emultitable{% \crcr \egroup % end the \halign \global\setpercentfalse } \def\setmultitablespacing{% \def\multistrut{\strut}% just use the standard line spacing % % Compute \multitablelinespace (if not defined by user) for use in % \multitableparskip calculation. We used define \multistrut based on % this, but (ironically) that caused the spacing to be off. % See bug-texinfo report from Werner Lemberg, 31 Oct 2004 12:52:20 +0100. \ifdim\multitablelinespace=0pt \setbox0=\vbox{X}\global\multitablelinespace=\the\baselineskip \global\advance\multitablelinespace by-\ht0 \fi %% Test to see if parskip is larger than space between lines of %% table. If not, do nothing. %% If so, set to same dimension as multitablelinespace. \ifdim\multitableparskip>\multitablelinespace \global\multitableparskip=\multitablelinespace \global\advance\multitableparskip-7pt %% to keep parskip somewhat smaller %% than skip between lines in the table. \fi% \ifdim\multitableparskip=0pt \global\multitableparskip=\multitablelinespace \global\advance\multitableparskip-7pt %% to keep parskip somewhat smaller %% than skip between lines in the table. \fi} \message{conditionals,} % @iftex, @ifnotdocbook, @ifnothtml, @ifnotinfo, @ifnotplaintext, % @ifnotxml always succeed. They currently do nothing; we don't % attempt to check whether the conditionals are properly nested. But we % have to remember that they are conditionals, so that @end doesn't % attempt to close an environment group. % \def\makecond#1{% \expandafter\let\csname #1\endcsname = \relax \expandafter\let\csname iscond.#1\endcsname = 1 } \makecond{iftex} \makecond{ifnotdocbook} \makecond{ifnothtml} \makecond{ifnotinfo} \makecond{ifnotplaintext} \makecond{ifnotxml} % Ignore @ignore, @ifhtml, @ifinfo, and the like. % \def\direntry{\doignore{direntry}} \def\documentdescription{\doignore{documentdescription}} \def\docbook{\doignore{docbook}} \def\html{\doignore{html}} \def\ifdocbook{\doignore{ifdocbook}} \def\ifhtml{\doignore{ifhtml}} \def\ifinfo{\doignore{ifinfo}} \def\ifnottex{\doignore{ifnottex}} \def\ifplaintext{\doignore{ifplaintext}} \def\ifxml{\doignore{ifxml}} \def\ignore{\doignore{ignore}} \def\menu{\doignore{menu}} \def\xml{\doignore{xml}} % Ignore text until a line `@end #1', keeping track of nested conditionals. % % A count to remember the depth of nesting. \newcount\doignorecount \def\doignore#1{\begingroup % Scan in ``verbatim'' mode: \obeylines \catcode`\@ = \other \catcode`\{ = \other \catcode`\} = \other % % Make sure that spaces turn into tokens that match what \doignoretext wants. \spaceisspace % % Count number of #1's that we've seen. \doignorecount = 0 % % Swallow text until we reach the matching `@end #1'. \dodoignore{#1}% } { \catcode`_=11 % We want to use \_STOP_ which cannot appear in texinfo source. \obeylines % % \gdef\dodoignore#1{% % #1 contains the command name as a string, e.g., `ifinfo'. % % Define a command to find the next `@end #1'. \long\def\doignoretext##1^^M@end #1{% \doignoretextyyy##1^^M@#1\_STOP_}% % % And this command to find another #1 command, at the beginning of a % line. (Otherwise, we would consider a line `@c @ifset', for % example, to count as an @ifset for nesting.) \long\def\doignoretextyyy##1^^M@#1##2\_STOP_{\doignoreyyy{##2}\_STOP_}% % % And now expand that command. \doignoretext ^^M% }% } \def\doignoreyyy#1{% \def\temp{#1}% \ifx\temp\empty % Nothing found. \let\next\doignoretextzzz \else % Found a nested condition, ... \advance\doignorecount by 1 \let\next\doignoretextyyy % ..., look for another. % If we're here, #1 ends with ^^M\ifinfo (for example). \fi \next #1% the token \_STOP_ is present just after this macro. } % We have to swallow the remaining "\_STOP_". % \def\doignoretextzzz#1{% \ifnum\doignorecount = 0 % We have just found the outermost @end. \let\next\enddoignore \else % Still inside a nested condition. \advance\doignorecount by -1 \let\next\doignoretext % Look for the next @end. \fi \next } % Finish off ignored text. { \obeylines% % Ignore anything after the last `@end #1'; this matters in verbatim % environments, where otherwise the newline after an ignored conditional % would result in a blank line in the output. \gdef\enddoignore#1^^M{\endgroup\ignorespaces}% } % @set VAR sets the variable VAR to an empty value. % @set VAR REST-OF-LINE sets VAR to the value REST-OF-LINE. % % Since we want to separate VAR from REST-OF-LINE (which might be % empty), we can't just use \parsearg; we have to insert a space of our % own to delimit the rest of the line, and then take it out again if we % didn't need it. % We rely on the fact that \parsearg sets \catcode`\ =10. % \parseargdef\set{\setyyy#1 \endsetyyy} \def\setyyy#1 #2\endsetyyy{% {% \makevalueexpandable \def\temp{#2}% \edef\next{\gdef\makecsname{SET#1}}% \ifx\temp\empty \next{}% \else \setzzz#2\endsetzzz \fi }% } % Remove the trailing space \setxxx inserted. \def\setzzz#1 \endsetzzz{\next{#1}} % @clear VAR clears (i.e., unsets) the variable VAR. % \parseargdef\clear{% {% \makevalueexpandable \global\expandafter\let\csname SET#1\endcsname=\relax }% } % @value{foo} gets the text saved in variable foo. \def\value{\begingroup\makevalueexpandable\valuexxx} \def\valuexxx#1{\expandablevalue{#1}\endgroup} { \catcode`\- = \active \catcode`\_ = \active % \gdef\makevalueexpandable{% \let\value = \expandablevalue % We don't want these characters active, ... \catcode`\-=\other \catcode`\_=\other % ..., but we might end up with active ones in the argument if % we're called from @code, as @code{@value{foo-bar_}}, though. % So \let them to their normal equivalents. \let-\realdash \let_\normalunderscore } } % We have this subroutine so that we can handle at least some @value's % properly in indexes (we call \makevalueexpandable in \indexdummies). % The command has to be fully expandable (if the variable is set), since % the result winds up in the index file. This means that if the % variable's value contains other Texinfo commands, it's almost certain % it will fail (although perhaps we could fix that with sufficient work % to do a one-level expansion on the result, instead of complete). % \def\expandablevalue#1{% \expandafter\ifx\csname SET#1\endcsname\relax {[No value for ``#1'']}% \message{Variable `#1', used in @value, is not set.}% \else \csname SET#1\endcsname \fi } % @ifset VAR ... @end ifset reads the `...' iff VAR has been defined % with @set. % % To get special treatment of `@end ifset,' call \makeond and the redefine. % \makecond{ifset} \def\ifset{\parsearg{\doifset{\let\next=\ifsetfail}}} \def\doifset#1#2{% {% \makevalueexpandable \let\next=\empty \expandafter\ifx\csname SET#2\endcsname\relax #1% If not set, redefine \next. \fi \expandafter }\next } \def\ifsetfail{\doignore{ifset}} % @ifclear VAR ... @end ifclear reads the `...' iff VAR has never been % defined with @set, or has been undefined with @clear. % % The `\else' inside the `\doifset' parameter is a trick to reuse the % above code: if the variable is not set, do nothing, if it is set, % then redefine \next to \ifclearfail. % \makecond{ifclear} \def\ifclear{\parsearg{\doifset{\else \let\next=\ifclearfail}}} \def\ifclearfail{\doignore{ifclear}} % @dircategory CATEGORY -- specify a category of the dir file % which this file should belong to. Ignore this in TeX. \let\dircategory=\comment % @defininfoenclose. \let\definfoenclose=\comment \message{indexing,} % Index generation facilities % Define \newwrite to be identical to plain tex's \newwrite % except not \outer, so it can be used within macros and \if's. \edef\newwrite{\makecsname{ptexnewwrite}} % \newindex {foo} defines an index named foo. % It automatically defines \fooindex such that % \fooindex ...rest of line... puts an entry in the index foo. % It also defines \fooindfile to be the number of the output channel for % the file that accumulates this index. The file's extension is foo. % The name of an index should be no more than 2 characters long % for the sake of vms. % \def\newindex#1{% \iflinks \expandafter\newwrite \csname#1indfile\endcsname \openout \csname#1indfile\endcsname \jobname.#1 % Open the file \fi \expandafter\xdef\csname#1index\endcsname{% % Define @#1index \noexpand\doindex{#1}} } % @defindex foo == \newindex{foo} % \def\defindex{\parsearg\newindex} % Define @defcodeindex, like @defindex except put all entries in @code. % \def\defcodeindex{\parsearg\newcodeindex} % \def\newcodeindex#1{% \iflinks \expandafter\newwrite \csname#1indfile\endcsname \openout \csname#1indfile\endcsname \jobname.#1 \fi \expandafter\xdef\csname#1index\endcsname{% \noexpand\docodeindex{#1}}% } % @synindex foo bar makes index foo feed into index bar. % Do this instead of @defindex foo if you don't want it as a separate index. % % @syncodeindex foo bar similar, but put all entries made for index foo % inside @code. % \def\synindex#1 #2 {\dosynindex\doindex{#1}{#2}} \def\syncodeindex#1 #2 {\dosynindex\docodeindex{#1}{#2}} % #1 is \doindex or \docodeindex, #2 the index getting redefined (foo), % #3 the target index (bar). \def\dosynindex#1#2#3{% % Only do \closeout if we haven't already done it, else we'll end up % closing the target index. \expandafter \ifx\csname donesynindex#2\endcsname \undefined % The \closeout helps reduce unnecessary open files; the limit on the % Acorn RISC OS is a mere 16 files. \expandafter\closeout\csname#2indfile\endcsname \expandafter\let\csname\donesynindex#2\endcsname = 1 \fi % redefine \fooindfile: \expandafter\let\expandafter\temp\expandafter=\csname#3indfile\endcsname \expandafter\let\csname#2indfile\endcsname=\temp % redefine \fooindex: \expandafter\xdef\csname#2index\endcsname{\noexpand#1{#3}}% } % Define \doindex, the driver for all \fooindex macros. % Argument #1 is generated by the calling \fooindex macro, % and it is "foo", the name of the index. % \doindex just uses \parsearg; it calls \doind for the actual work. % This is because \doind is more useful to call from other macros. % There is also \dosubind {index}{topic}{subtopic} % which makes an entry in a two-level index such as the operation index. \def\doindex#1{\edef\indexname{#1}\parsearg\singleindexer} \def\singleindexer #1{\doind{\indexname}{#1}} % like the previous two, but they put @code around the argument. \def\docodeindex#1{\edef\indexname{#1}\parsearg\singlecodeindexer} \def\singlecodeindexer #1{\doind{\indexname}{\code{#1}}} % Take care of Texinfo commands that can appear in an index entry. % Since there are some commands we want to expand, and others we don't, % we have to laboriously prevent expansion for those that we don't. % \def\indexdummies{% \escapechar = `\\ % use backslash in output files. \def\@{@}% change to @@ when we switch to @ as escape char in index files. \def\ {\realbackslash\space }% % % Need these in case \tex is in effect and \{ is a \delimiter again. % But can't use \lbracecmd and \rbracecmd because texindex assumes % braces and backslashes are used only as delimiters. \let\{ = \mylbrace \let\} = \myrbrace % % I don't entirely understand this, but when an index entry is % generated from a macro call, the \endinput which \scanmacro inserts % causes processing to be prematurely terminated. This is, % apparently, because \indexsorttmp is fully expanded, and \endinput % is an expandable command. The redefinition below makes \endinput % disappear altogether for that purpose -- although logging shows that % processing continues to some further point. On the other hand, it % seems \endinput does not hurt in the printed index arg, since that % is still getting written without apparent harm. % % Sample source (mac-idx3.tex, reported by Graham Percival to % help-texinfo, 22may06): % @macro funindex {WORD} % @findex xyz % @end macro % ... % @funindex commtest % % The above is not enough to reproduce the bug, but it gives the flavor. % % Sample whatsit resulting: % .@write3{\entry{xyz}{@folio }{@code {xyz@endinput }}} % % So: \let\endinput = \empty % % Do the redefinitions. \commondummies } % For the aux and toc files, @ is the escape character. So we want to % redefine everything using @ as the escape character (instead of % \realbackslash, still used for index files). When everything uses @, % this will be simpler. % \def\atdummies{% \def\@{@@}% \def\ {@ }% \let\{ = \lbraceatcmd \let\} = \rbraceatcmd % % Do the redefinitions. \commondummies \otherbackslash } % Called from \indexdummies and \atdummies. % \def\commondummies{% % % \definedummyword defines \#1 as \string\#1\space, thus effectively % preventing its expansion. This is used only for control% words, % not control letters, because the \space would be incorrect for % control characters, but is needed to separate the control word % from whatever follows. % % For control letters, we have \definedummyletter, which omits the % space. % % These can be used both for control words that take an argument and % those that do not. If it is followed by {arg} in the input, then % that will dutifully get written to the index (or wherever). % \def\definedummyword ##1{\def##1{\string##1\space}}% \def\definedummyletter##1{\def##1{\string##1}}% \let\definedummyaccent\definedummyletter % \commondummiesnofonts % \definedummyletter\_% % % Non-English letters. \definedummyword\AA \definedummyword\AE \definedummyword\L \definedummyword\OE \definedummyword\O \definedummyword\aa \definedummyword\ae \definedummyword\l \definedummyword\oe \definedummyword\o \definedummyword\ss \definedummyword\exclamdown \definedummyword\questiondown \definedummyword\ordf \definedummyword\ordm % % Although these internal commands shouldn't show up, sometimes they do. \definedummyword\bf \definedummyword\gtr \definedummyword\hat \definedummyword\less \definedummyword\sf \definedummyword\sl \definedummyword\tclose \definedummyword\tt % \definedummyword\LaTeX \definedummyword\TeX % % Assorted special characters. \definedummyword\bullet \definedummyword\comma \definedummyword\copyright \definedummyword\registeredsymbol \definedummyword\dots \definedummyword\enddots \definedummyword\equiv \definedummyword\error \definedummyword\euro \definedummyword\guillemetleft \definedummyword\guillemetright \definedummyword\guilsinglleft \definedummyword\guilsinglright \definedummyword\expansion \definedummyword\minus \definedummyword\pounds \definedummyword\point \definedummyword\print \definedummyword\quotedblbase \definedummyword\quotedblleft \definedummyword\quotedblright \definedummyword\quoteleft \definedummyword\quoteright \definedummyword\quotesinglbase \definedummyword\result \definedummyword\textdegree % % We want to disable all macros so that they are not expanded by \write. \macrolist % \normalturnoffactive % % Handle some cases of @value -- where it does not contain any % (non-fully-expandable) commands. \makevalueexpandable } % \commondummiesnofonts: common to \commondummies and \indexnofonts. % \def\commondummiesnofonts{% % Control letters and accents. \definedummyletter\!% \definedummyaccent\"% \definedummyaccent\'% \definedummyletter\*% \definedummyaccent\,% \definedummyletter\.% \definedummyletter\/% \definedummyletter\:% \definedummyaccent\=% \definedummyletter\?% \definedummyaccent\^% \definedummyaccent\`% \definedummyaccent\~% \definedummyword\u \definedummyword\v \definedummyword\H \definedummyword\dotaccent \definedummyword\ringaccent \definedummyword\tieaccent \definedummyword\ubaraccent \definedummyword\udotaccent \definedummyword\dotless % % Texinfo font commands. \definedummyword\b \definedummyword\i \definedummyword\r \definedummyword\sc \definedummyword\t % % Commands that take arguments. \definedummyword\acronym \definedummyword\cite \definedummyword\code \definedummyword\command \definedummyword\dfn \definedummyword\emph \definedummyword\env \definedummyword\file \definedummyword\kbd \definedummyword\key \definedummyword\math \definedummyword\option \definedummyword\pxref \definedummyword\ref \definedummyword\samp \definedummyword\strong \definedummyword\tie \definedummyword\uref \definedummyword\url \definedummyword\var \definedummyword\verb \definedummyword\w \definedummyword\xref } % \indexnofonts is used when outputting the strings to sort the index % by, and when constructing control sequence names. It eliminates all % control sequences and just writes whatever the best ASCII sort string % would be for a given command (usually its argument). % \def\indexnofonts{% % Accent commands should become @asis. \def\definedummyaccent##1{\let##1\asis}% % We can just ignore other control letters. \def\definedummyletter##1{\let##1\empty}% % Hopefully, all control words can become @asis. \let\definedummyword\definedummyaccent % \commondummiesnofonts % % Don't no-op \tt, since it isn't a user-level command % and is used in the definitions of the active chars like <, >, |, etc. % Likewise with the other plain tex font commands. %\let\tt=\asis % \def\ { }% \def\@{@}% % how to handle braces? \def\_{\normalunderscore}% % % Non-English letters. \def\AA{AA}% \def\AE{AE}% \def\L{L}% \def\OE{OE}% \def\O{O}% \def\aa{aa}% \def\ae{ae}% \def\l{l}% \def\oe{oe}% \def\o{o}% \def\ss{ss}% \def\exclamdown{!}% \def\questiondown{?}% \def\ordf{a}% \def\ordm{o}% % \def\LaTeX{LaTeX}% \def\TeX{TeX}% % % Assorted special characters. % (The following {} will end up in the sort string, but that's ok.) \def\bullet{bullet}% \def\comma{,}% \def\copyright{copyright}% \def\registeredsymbol{R}% \def\dots{...}% \def\enddots{...}% \def\equiv{==}% \def\error{error}% \def\euro{euro}% \def\guillemetleft{<<}% \def\guillemetright{>>}% \def\guilsinglleft{<}% \def\guilsinglright{>}% \def\expansion{==>}% \def\minus{-}% \def\pounds{pounds}% \def\point{.}% \def\print{-|}% \def\quotedblbase{"}% \def\quotedblleft{"}% \def\quotedblright{"}% \def\quoteleft{`}% \def\quoteright{'}% \def\quotesinglbase{,}% \def\result{=>}% \def\textdegree{degrees}% % % We need to get rid of all macros, leaving only the arguments (if present). % Of course this is not nearly correct, but it is the best we can do for now. % makeinfo does not expand macros in the argument to @deffn, which ends up % writing an index entry, and texindex isn't prepared for an index sort entry % that starts with \. % % Since macro invocations are followed by braces, we can just redefine them % to take a single TeX argument. The case of a macro invocation that % goes to end-of-line is not handled. % \macrolist } \let\indexbackslash=0 %overridden during \printindex. \let\SETmarginindex=\relax % put index entries in margin (undocumented)? % Most index entries go through here, but \dosubind is the general case. % #1 is the index name, #2 is the entry text. \def\doind#1#2{\dosubind{#1}{#2}{}} % Workhorse for all \fooindexes. % #1 is name of index, #2 is stuff to put there, #3 is subentry -- % empty if called from \doind, as we usually are (the main exception % is with most defuns, which call us directly). % \def\dosubind#1#2#3{% \iflinks {% % Store the main index entry text (including the third arg). \toks0 = {#2}% % If third arg is present, precede it with a space. \def\thirdarg{#3}% \ifx\thirdarg\empty \else \toks0 = \expandafter{\the\toks0 \space #3}% \fi % \edef\writeto{\csname#1indfile\endcsname}% % \safewhatsit\dosubindwrite }% \fi } % Write the entry in \toks0 to the index file: % \def\dosubindwrite{% % Put the index entry in the margin if desired. \ifx\SETmarginindex\relax\else \insert\margin{\hbox{\vrule height8pt depth3pt width0pt \the\toks0}}% \fi % % Remember, we are within a group. \indexdummies % Must do this here, since \bf, etc expand at this stage \def\backslashcurfont{\indexbackslash}% \indexbackslash isn't defined now % so it will be output as is; and it will print as backslash. % % Process the index entry with all font commands turned off, to % get the string to sort by. {\indexnofonts \edef\temp{\the\toks0}% need full expansion \xdef\indexsorttmp{\temp}% }% % % Set up the complete index entry, with both the sort key and % the original text, including any font commands. We write % three arguments to \entry to the .?? file (four in the % subentry case), texindex reduces to two when writing the .??s % sorted result. \edef\temp{% \write\writeto{% \string\entry{\indexsorttmp}{\noexpand\folio}{\the\toks0}}% }% \temp } % Take care of unwanted page breaks/skips around a whatsit: % % If a skip is the last thing on the list now, preserve it % by backing up by \lastskip, doing the \write, then inserting % the skip again. Otherwise, the whatsit generated by the % \write or \pdfdest will make \lastskip zero. The result is that % sequences like this: % @end defun % @tindex whatever % @defun ... % will have extra space inserted, because the \medbreak in the % start of the @defun won't see the skip inserted by the @end of % the previous defun. % % But don't do any of this if we're not in vertical mode. We % don't want to do a \vskip and prematurely end a paragraph. % % Avoid page breaks due to these extra skips, too. % % But wait, there is a catch there: % We'll have to check whether \lastskip is zero skip. \ifdim is not % sufficient for this purpose, as it ignores stretch and shrink parts % of the skip. The only way seems to be to check the textual % representation of the skip. % % The following is almost like \def\zeroskipmacro{0.0pt} except that % the ``p'' and ``t'' characters have catcode \other, not 11 (letter). % \edef\zeroskipmacro{\expandafter\the\csname z@skip\endcsname} % \newskip\whatsitskip \newcount\whatsitpenalty % % ..., ready, GO: % \def\safewhatsit#1{% \ifhmode #1% \else % \lastskip and \lastpenalty cannot both be nonzero simultaneously. \whatsitskip = \lastskip \edef\lastskipmacro{\the\lastskip}% \whatsitpenalty = \lastpenalty % % If \lastskip is nonzero, that means the last item was a % skip. And since a skip is discardable, that means this % -\whatsitskip glue we're inserting is preceded by a % non-discardable item, therefore it is not a potential % breakpoint, therefore no \nobreak needed. \ifx\lastskipmacro\zeroskipmacro \else \vskip-\whatsitskip \fi % #1% % \ifx\lastskipmacro\zeroskipmacro % If \lastskip was zero, perhaps the last item was a penalty, and % perhaps it was >=10000, e.g., a \nobreak. In that case, we want % to re-insert the same penalty (values >10000 are used for various % signals); since we just inserted a non-discardable item, any % following glue (such as a \parskip) would be a breakpoint. For example: % % @deffn deffn-whatever % @vindex index-whatever % Description. % would allow a break between the index-whatever whatsit % and the "Description." paragraph. \ifnum\whatsitpenalty>9999 \penalty\whatsitpenalty \fi \else % On the other hand, if we had a nonzero \lastskip, % this make-up glue would be preceded by a non-discardable item % (the whatsit from the \write), so we must insert a \nobreak. \nobreak\vskip\whatsitskip \fi \fi } % The index entry written in the file actually looks like % \entry {sortstring}{page}{topic} % or % \entry {sortstring}{page}{topic}{subtopic} % The texindex program reads in these files and writes files % containing these kinds of lines: % \initial {c} % before the first topic whose initial is c % \entry {topic}{pagelist} % for a topic that is used without subtopics % \primary {topic} % for the beginning of a topic that is used with subtopics % \secondary {subtopic}{pagelist} % for each subtopic. % Define the user-accessible indexing commands % @findex, @vindex, @kindex, @cindex. \def\findex {\fnindex} \def\kindex {\kyindex} \def\cindex {\cpindex} \def\vindex {\vrindex} \def\tindex {\tpindex} \def\pindex {\pgindex} \def\cindexsub {\begingroup\obeylines\cindexsub} {\obeylines % \gdef\cindexsub "#1" #2^^M{\endgroup % \dosubind{cp}{#2}{#1}}} % Define the macros used in formatting output of the sorted index material. % @printindex causes a particular index (the ??s file) to get printed. % It does not print any chapter heading (usually an @unnumbered). % \parseargdef\printindex{\begingroup \dobreak \chapheadingskip{10000}% % \smallfonts \rm \tolerance = 9500 \plainfrenchspacing \everypar = {}% don't want the \kern\-parindent from indentation suppression. % % See if the index file exists and is nonempty. % Change catcode of @ here so that if the index file contains % \initial {@} % as its first line, TeX doesn't complain about mismatched braces % (because it thinks @} is a control sequence). \catcode`\@ = 11 \openin 1 \jobname.#1s \ifeof 1 % \enddoublecolumns gets confused if there is no text in the index, % and it loses the chapter title and the aux file entries for the % index. The easiest way to prevent this problem is to make sure % there is some text. \putwordIndexNonexistent \else % % If the index file exists but is empty, then \openin leaves \ifeof % false. We have to make TeX try to read something from the file, so % it can discover if there is anything in it. \read 1 to \temp \ifeof 1 \putwordIndexIsEmpty \else % Index files are almost Texinfo source, but we use \ as the escape % character. It would be better to use @, but that's too big a change % to make right now. \def\indexbackslash{\backslashcurfont}% \catcode`\\ = 0 \escapechar = `\\ \begindoublecolumns \input \jobname.#1s \enddoublecolumns \fi \fi \closein 1 \endgroup} % These macros are used by the sorted index file itself. % Change them to control the appearance of the index. \def\initial#1{{% % Some minor font changes for the special characters. \let\tentt=\sectt \let\tt=\sectt \let\sf=\sectt % % Remove any glue we may have, we'll be inserting our own. \removelastskip % % We like breaks before the index initials, so insert a bonus. \nobreak \vskip 0pt plus 3\baselineskip \penalty 0 \vskip 0pt plus -3\baselineskip % % Typeset the initial. Making this add up to a whole number of % baselineskips increases the chance of the dots lining up from column % to column. It still won't often be perfect, because of the stretch % we need before each entry, but it's better. % % No shrink because it confuses \balancecolumns. \vskip 1.67\baselineskip plus .5\baselineskip \leftline{\secbf #1}% % Do our best not to break after the initial. \nobreak \vskip .33\baselineskip plus .1\baselineskip }} % \entry typesets a paragraph consisting of the text (#1), dot leaders, and % then page number (#2) flushed to the right margin. It is used for index % and table of contents entries. The paragraph is indented by \leftskip. % % A straightforward implementation would start like this: % \def\entry#1#2{... % But this frozes the catcodes in the argument, and can cause problems to % @code, which sets - active. This problem was fixed by a kludge--- % ``-'' was active throughout whole index, but this isn't really right. % % The right solution is to prevent \entry from swallowing the whole text. % --kasal, 21nov03 \def\entry{% \begingroup % % Start a new paragraph if necessary, so our assignments below can't % affect previous text. \par % % Do not fill out the last line with white space. \parfillskip = 0in % % No extra space above this paragraph. \parskip = 0in % % Do not prefer a separate line ending with a hyphen to fewer lines. \finalhyphendemerits = 0 % % \hangindent is only relevant when the entry text and page number % don't both fit on one line. In that case, bob suggests starting the % dots pretty far over on the line. Unfortunately, a large % indentation looks wrong when the entry text itself is broken across % lines. So we use a small indentation and put up with long leaders. % % \hangafter is reset to 1 (which is the value we want) at the start % of each paragraph, so we need not do anything with that. \hangindent = 2em % % When the entry text needs to be broken, just fill out the first line % with blank space. \rightskip = 0pt plus1fil % % A bit of stretch before each entry for the benefit of balancing % columns. \vskip 0pt plus1pt % % Swallow the left brace of the text (first parameter): \afterassignment\doentry \let\temp = } \def\doentry{% \bgroup % Instead of the swallowed brace. \noindent \aftergroup\finishentry % And now comes the text of the entry. } \def\finishentry#1{% % #1 is the page number. % % The following is kludged to not output a line of dots in the index if % there are no page numbers. The next person who breaks this will be % cursed by a Unix daemon. \setbox\boxA = \hbox{#1}% \ifdim\wd\boxA = 0pt \ % \else % % If we must, put the page number on a line of its own, and fill out % this line with blank space. (The \hfil is overwhelmed with the % fill leaders glue in \indexdotfill if the page number does fit.) \hfil\penalty50 \null\nobreak\indexdotfill % Have leaders before the page number. % % The `\ ' here is removed by the implicit \unskip that TeX does as % part of (the primitive) \par. Without it, a spurious underfull % \hbox ensues. \ifpdf \pdfgettoks#1.% \ \the\toksA \else \ #1% \fi \fi \par \endgroup } % Like plain.tex's \dotfill, except uses up at least 1 em. \def\indexdotfill{\cleaders \hbox{$\mathsurround=0pt \mkern1.5mu.\mkern1.5mu$}\hskip 1em plus 1fill} \def\primary #1{\line{#1\hfil}} \newskip\secondaryindent \secondaryindent=0.5cm \def\secondary#1#2{{% \parfillskip=0in \parskip=0in \hangindent=1in \hangafter=1 \noindent\hskip\secondaryindent\hbox{#1}\indexdotfill \ifpdf \pdfgettoks#2.\ \the\toksA % The page number ends the paragraph. \else #2 \fi \par }} % Define two-column mode, which we use to typeset indexes. % Adapted from the TeXbook, page 416, which is to say, % the manmac.tex format used to print the TeXbook itself. \catcode`\@=11 \newbox\partialpage \newdimen\doublecolumnhsize \def\begindoublecolumns{\begingroup % ended by \enddoublecolumns % Grab any single-column material above us. \output = {% % % Here is a possibility not foreseen in manmac: if we accumulate a % whole lot of material, we might end up calling this \output % routine twice in a row (see the doublecol-lose test, which is % essentially a couple of indexes with @setchapternewpage off). In % that case we just ship out what is in \partialpage with the normal % output routine. Generally, \partialpage will be empty when this % runs and this will be a no-op. See the indexspread.tex test case. \ifvoid\partialpage \else \onepageout{\pagecontents\partialpage}% \fi % \global\setbox\partialpage = \vbox{% % Unvbox the main output page. \unvbox\PAGE \kern-\topskip \kern\baselineskip }% }% \eject % run that output routine to set \partialpage % % Use the double-column output routine for subsequent pages. \output = {\doublecolumnout}% % % Change the page size parameters. We could do this once outside this % routine, in each of @smallbook, @afourpaper, and the default 8.5x11 % format, but then we repeat the same computation. Repeating a couple % of assignments once per index is clearly meaningless for the % execution time, so we may as well do it in one place. % % First we halve the line length, less a little for the gutter between % the columns. We compute the gutter based on the line length, so it % changes automatically with the paper format. The magic constant % below is chosen so that the gutter has the same value (well, +-<1pt) % as it did when we hard-coded it. % % We put the result in a separate register, \doublecolumhsize, so we % can restore it in \pagesofar, after \hsize itself has (potentially) % been clobbered. % \doublecolumnhsize = \hsize \advance\doublecolumnhsize by -.04154\hsize \divide\doublecolumnhsize by 2 \hsize = \doublecolumnhsize % % Double the \vsize as well. (We don't need a separate register here, % since nobody clobbers \vsize.) \vsize = 2\vsize } % The double-column output routine for all double-column pages except % the last. % \def\doublecolumnout{% \splittopskip=\topskip \splitmaxdepth=\maxdepth % Get the available space for the double columns -- the normal % (undoubled) page height minus any material left over from the % previous page. \dimen@ = \vsize \divide\dimen@ by 2 \advance\dimen@ by -\ht\partialpage % % box0 will be the left-hand column, box2 the right. \setbox0=\vsplit255 to\dimen@ \setbox2=\vsplit255 to\dimen@ \onepageout\pagesofar \unvbox255 \penalty\outputpenalty } % % Re-output the contents of the output page -- any previous material, % followed by the two boxes we just split, in box0 and box2. \def\pagesofar{% \unvbox\partialpage % \hsize = \doublecolumnhsize \wd0=\hsize \wd2=\hsize \hbox to\pagewidth{\box0\hfil\box2}% } % % All done with double columns. \def\enddoublecolumns{% % The following penalty ensures that the page builder is exercised % _before_ we change the output routine. This is necessary in the % following situation: % % The last section of the index consists only of a single entry. % Before this section, \pagetotal is less than \pagegoal, so no % break occurs before the last section starts. However, the last % section, consisting of \initial and the single \entry, does not % fit on the page and has to be broken off. Without the following % penalty the page builder will not be exercised until \eject % below, and by that time we'll already have changed the output % routine to the \balancecolumns version, so the next-to-last % double-column page will be processed with \balancecolumns, which % is wrong: The two columns will go to the main vertical list, with % the broken-off section in the recent contributions. As soon as % the output routine finishes, TeX starts reconsidering the page % break. The two columns and the broken-off section both fit on the % page, because the two columns now take up only half of the page % goal. When TeX sees \eject from below which follows the final % section, it invokes the new output routine that we've set after % \balancecolumns below; \onepageout will try to fit the two columns % and the final section into the vbox of \pageheight (see % \pagebody), causing an overfull box. % % Note that glue won't work here, because glue does not exercise the % page builder, unlike penalties (see The TeXbook, pp. 280-281). \penalty0 % \output = {% % Split the last of the double-column material. Leave it on the % current page, no automatic page break. \balancecolumns % % If we end up splitting too much material for the current page, % though, there will be another page break right after this \output % invocation ends. Having called \balancecolumns once, we do not % want to call it again. Therefore, reset \output to its normal % definition right away. (We hope \balancecolumns will never be % called on to balance too much material, but if it is, this makes % the output somewhat more palatable.) \global\output = {\onepageout{\pagecontents\PAGE}}% }% \eject \endgroup % started in \begindoublecolumns % % \pagegoal was set to the doubled \vsize above, since we restarted % the current page. We're now back to normal single-column % typesetting, so reset \pagegoal to the normal \vsize (after the % \endgroup where \vsize got restored). \pagegoal = \vsize } % % Called at the end of the double column material. \def\balancecolumns{% \setbox0 = \vbox{\unvbox255}% like \box255 but more efficient, see p.120. \dimen@ = \ht0 \advance\dimen@ by \topskip \advance\dimen@ by-\baselineskip \divide\dimen@ by 2 % target to split to %debug\message{final 2-column material height=\the\ht0, target=\the\dimen@.}% \splittopskip = \topskip % Loop until we get a decent breakpoint. {% \vbadness = 10000 \loop \global\setbox3 = \copy0 \global\setbox1 = \vsplit3 to \dimen@ \ifdim\ht3>\dimen@ \global\advance\dimen@ by 1pt \repeat }% %debug\message{split to \the\dimen@, column heights: \the\ht1, \the\ht3.}% \setbox0=\vbox to\dimen@{\unvbox1}% \setbox2=\vbox to\dimen@{\unvbox3}% % \pagesofar } \catcode`\@ = \other \message{sectioning,} % Chapters, sections, etc. % \unnumberedno is an oxymoron, of course. But we count the unnumbered % sections so that we can refer to them unambiguously in the pdf % outlines by their "section number". We avoid collisions with chapter % numbers by starting them at 10000. (If a document ever has 10000 % chapters, we're in trouble anyway, I'm sure.) \newcount\unnumberedno \unnumberedno = 10000 \newcount\chapno \newcount\secno \secno=0 \newcount\subsecno \subsecno=0 \newcount\subsubsecno \subsubsecno=0 % This counter is funny since it counts through charcodes of letters A, B, ... \newcount\appendixno \appendixno = `\@ % % \def\appendixletter{\char\the\appendixno} % We do the following ugly conditional instead of the above simple % construct for the sake of pdftex, which needs the actual % letter in the expansion, not just typeset. % \def\appendixletter{% \ifnum\appendixno=`A A% \else\ifnum\appendixno=`B B% \else\ifnum\appendixno=`C C% \else\ifnum\appendixno=`D D% \else\ifnum\appendixno=`E E% \else\ifnum\appendixno=`F F% \else\ifnum\appendixno=`G G% \else\ifnum\appendixno=`H H% \else\ifnum\appendixno=`I I% \else\ifnum\appendixno=`J J% \else\ifnum\appendixno=`K K% \else\ifnum\appendixno=`L L% \else\ifnum\appendixno=`M M% \else\ifnum\appendixno=`N N% \else\ifnum\appendixno=`O O% \else\ifnum\appendixno=`P P% \else\ifnum\appendixno=`Q Q% \else\ifnum\appendixno=`R R% \else\ifnum\appendixno=`S S% \else\ifnum\appendixno=`T T% \else\ifnum\appendixno=`U U% \else\ifnum\appendixno=`V V% \else\ifnum\appendixno=`W W% \else\ifnum\appendixno=`X X% \else\ifnum\appendixno=`Y Y% \else\ifnum\appendixno=`Z Z% % The \the is necessary, despite appearances, because \appendixletter is % expanded while writing the .toc file. \char\appendixno is not % expandable, thus it is written literally, thus all appendixes come out % with the same letter (or @) in the toc without it. \else\char\the\appendixno \fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi \fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi} % Each @chapter defines these (using marks) as the number+name, number % and name of the chapter. Page headings and footings can use % these. @section does likewise. \def\thischapter{} \def\thischapternum{} \def\thischaptername{} \def\thissection{} \def\thissectionnum{} \def\thissectionname{} \newcount\absseclevel % used to calculate proper heading level \newcount\secbase\secbase=0 % @raisesections/@lowersections modify this count % @raisesections: treat @section as chapter, @subsection as section, etc. \def\raisesections{\global\advance\secbase by -1} \let\up=\raisesections % original BFox name % @lowersections: treat @chapter as section, @section as subsection, etc. \def\lowersections{\global\advance\secbase by 1} \let\down=\lowersections % original BFox name % we only have subsub. \chardef\maxseclevel = 3 % % A numbered section within an unnumbered changes to unnumbered too. % To achive this, remember the "biggest" unnum. sec. we are currently in: \chardef\unmlevel = \maxseclevel % % Trace whether the current chapter is an appendix or not: % \chapheadtype is "N" or "A", unnumbered chapters are ignored. \def\chapheadtype{N} % Choose a heading macro % #1 is heading type % #2 is heading level % #3 is text for heading \def\genhead#1#2#3{% % Compute the abs. sec. level: \absseclevel=#2 \advance\absseclevel by \secbase % Make sure \absseclevel doesn't fall outside the range: \ifnum \absseclevel < 0 \absseclevel = 0 \else \ifnum \absseclevel > 3 \absseclevel = 3 \fi \fi % The heading type: \def\headtype{#1}% \if \headtype U% \ifnum \absseclevel < \unmlevel \chardef\unmlevel = \absseclevel \fi \else % Check for appendix sections: \ifnum \absseclevel = 0 \edef\chapheadtype{\headtype}% \else \if \headtype A\if \chapheadtype N% \errmessage{@appendix... within a non-appendix chapter}% \fi\fi \fi % Check for numbered within unnumbered: \ifnum \absseclevel > \unmlevel \def\headtype{U}% \else \chardef\unmlevel = 3 \fi \fi % Now print the heading: \if \headtype U% \ifcase\absseclevel \unnumberedzzz{#3}% \or \unnumberedseczzz{#3}% \or \unnumberedsubseczzz{#3}% \or \unnumberedsubsubseczzz{#3}% \fi \else \if \headtype A% \ifcase\absseclevel \appendixzzz{#3}% \or \appendixsectionzzz{#3}% \or \appendixsubseczzz{#3}% \or \appendixsubsubseczzz{#3}% \fi \else \ifcase\absseclevel \chapterzzz{#3}% \or \seczzz{#3}% \or \numberedsubseczzz{#3}% \or \numberedsubsubseczzz{#3}% \fi \fi \fi \suppressfirstparagraphindent } % an interface: \def\numhead{\genhead N} \def\apphead{\genhead A} \def\unnmhead{\genhead U} % @chapter, @appendix, @unnumbered. Increment top-level counter, reset % all lower-level sectioning counters to zero. % % Also set \chaplevelprefix, which we prepend to @float sequence numbers % (e.g., figures), q.v. By default (before any chapter), that is empty. \let\chaplevelprefix = \empty % \outer\parseargdef\chapter{\numhead0{#1}} % normally numhead0 calls chapterzzz \def\chapterzzz#1{% % section resetting is \global in case the chapter is in a group, such % as an @include file. \global\secno=0 \global\subsecno=0 \global\subsubsecno=0 \global\advance\chapno by 1 % % Used for \float. \gdef\chaplevelprefix{\the\chapno.}% \resetallfloatnos % \message{\putwordChapter\space \the\chapno}% % % Write the actual heading. \chapmacro{#1}{Ynumbered}{\the\chapno}% % % So @section and the like are numbered underneath this chapter. \global\let\section = \numberedsec \global\let\subsection = \numberedsubsec \global\let\subsubsection = \numberedsubsubsec } \outer\parseargdef\appendix{\apphead0{#1}} % normally apphead0 calls appendixzzz \def\appendixzzz#1{% \global\secno=0 \global\subsecno=0 \global\subsubsecno=0 \global\advance\appendixno by 1 \gdef\chaplevelprefix{\appendixletter.}% \resetallfloatnos % \def\appendixnum{\putwordAppendix\space \appendixletter}% \message{\appendixnum}% % \chapmacro{#1}{Yappendix}{\appendixletter}% % \global\let\section = \appendixsec \global\let\subsection = \appendixsubsec \global\let\subsubsection = \appendixsubsubsec } \outer\parseargdef\unnumbered{\unnmhead0{#1}} % normally unnmhead0 calls unnumberedzzz \def\unnumberedzzz#1{% \global\secno=0 \global\subsecno=0 \global\subsubsecno=0 \global\advance\unnumberedno by 1 % % Since an unnumbered has no number, no prefix for figures. \global\let\chaplevelprefix = \empty \resetallfloatnos % % This used to be simply \message{#1}, but TeX fully expands the % argument to \message. Therefore, if #1 contained @-commands, TeX % expanded them. For example, in `@unnumbered The @cite{Book}', TeX % expanded @cite (which turns out to cause errors because \cite is meant % to be executed, not expanded). % % Anyway, we don't want the fully-expanded definition of @cite to appear % as a result of the \message, we just want `@cite' itself. We use % \the to achieve this: TeX expands \the only once, % simply yielding the contents of . (We also do this for % the toc entries.) \toks0 = {#1}% \message{(\the\toks0)}% % \chapmacro{#1}{Ynothing}{\the\unnumberedno}% % \global\let\section = \unnumberedsec \global\let\subsection = \unnumberedsubsec \global\let\subsubsection = \unnumberedsubsubsec } % @centerchap is like @unnumbered, but the heading is centered. \outer\parseargdef\centerchap{% % Well, we could do the following in a group, but that would break % an assumption that \chapmacro is called at the outermost level. % Thus we are safer this way: --kasal, 24feb04 \let\centerparametersmaybe = \centerparameters \unnmhead0{#1}% \let\centerparametersmaybe = \relax } % @top is like @unnumbered. \let\top\unnumbered % Sections. \outer\parseargdef\numberedsec{\numhead1{#1}} % normally calls seczzz \def\seczzz#1{% \global\subsecno=0 \global\subsubsecno=0 \global\advance\secno by 1 \sectionheading{#1}{sec}{Ynumbered}{\the\chapno.\the\secno}% } \outer\parseargdef\appendixsection{\apphead1{#1}} % normally calls appendixsectionzzz \def\appendixsectionzzz#1{% \global\subsecno=0 \global\subsubsecno=0 \global\advance\secno by 1 \sectionheading{#1}{sec}{Yappendix}{\appendixletter.\the\secno}% } \let\appendixsec\appendixsection \outer\parseargdef\unnumberedsec{\unnmhead1{#1}} % normally calls unnumberedseczzz \def\unnumberedseczzz#1{% \global\subsecno=0 \global\subsubsecno=0 \global\advance\secno by 1 \sectionheading{#1}{sec}{Ynothing}{\the\unnumberedno.\the\secno}% } % Subsections. \outer\parseargdef\numberedsubsec{\numhead2{#1}} % normally calls numberedsubseczzz \def\numberedsubseczzz#1{% \global\subsubsecno=0 \global\advance\subsecno by 1 \sectionheading{#1}{subsec}{Ynumbered}{\the\chapno.\the\secno.\the\subsecno}% } \outer\parseargdef\appendixsubsec{\apphead2{#1}} % normally calls appendixsubseczzz \def\appendixsubseczzz#1{% \global\subsubsecno=0 \global\advance\subsecno by 1 \sectionheading{#1}{subsec}{Yappendix}% {\appendixletter.\the\secno.\the\subsecno}% } \outer\parseargdef\unnumberedsubsec{\unnmhead2{#1}} %normally calls unnumberedsubseczzz \def\unnumberedsubseczzz#1{% \global\subsubsecno=0 \global\advance\subsecno by 1 \sectionheading{#1}{subsec}{Ynothing}% {\the\unnumberedno.\the\secno.\the\subsecno}% } % Subsubsections. \outer\parseargdef\numberedsubsubsec{\numhead3{#1}} % normally numberedsubsubseczzz \def\numberedsubsubseczzz#1{% \global\advance\subsubsecno by 1 \sectionheading{#1}{subsubsec}{Ynumbered}% {\the\chapno.\the\secno.\the\subsecno.\the\subsubsecno}% } \outer\parseargdef\appendixsubsubsec{\apphead3{#1}} % normally appendixsubsubseczzz \def\appendixsubsubseczzz#1{% \global\advance\subsubsecno by 1 \sectionheading{#1}{subsubsec}{Yappendix}% {\appendixletter.\the\secno.\the\subsecno.\the\subsubsecno}% } \outer\parseargdef\unnumberedsubsubsec{\unnmhead3{#1}} %normally unnumberedsubsubseczzz \def\unnumberedsubsubseczzz#1{% \global\advance\subsubsecno by 1 \sectionheading{#1}{subsubsec}{Ynothing}% {\the\unnumberedno.\the\secno.\the\subsecno.\the\subsubsecno}% } % These macros control what the section commands do, according % to what kind of chapter we are in (ordinary, appendix, or unnumbered). % Define them by default for a numbered chapter. \let\section = \numberedsec \let\subsection = \numberedsubsec \let\subsubsection = \numberedsubsubsec % Define @majorheading, @heading and @subheading % NOTE on use of \vbox for chapter headings, section headings, and such: % 1) We use \vbox rather than the earlier \line to permit % overlong headings to fold. % 2) \hyphenpenalty is set to 10000 because hyphenation in a % heading is obnoxious; this forbids it. % 3) Likewise, headings look best if no \parindent is used, and % if justification is not attempted. Hence \raggedright. \def\majorheading{% {\advance\chapheadingskip by 10pt \chapbreak }% \parsearg\chapheadingzzz } \def\chapheading{\chapbreak \parsearg\chapheadingzzz} \def\chapheadingzzz#1{% {\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 \parindent=0pt\raggedright \rm #1\hfill}}% \bigskip \par\penalty 200\relax \suppressfirstparagraphindent } % @heading, @subheading, @subsubheading. \parseargdef\heading{\sectionheading{#1}{sec}{Yomitfromtoc}{} \suppressfirstparagraphindent} \parseargdef\subheading{\sectionheading{#1}{subsec}{Yomitfromtoc}{} \suppressfirstparagraphindent} \parseargdef\subsubheading{\sectionheading{#1}{subsubsec}{Yomitfromtoc}{} \suppressfirstparagraphindent} % These macros generate a chapter, section, etc. heading only % (including whitespace, linebreaking, etc. around it), % given all the information in convenient, parsed form. %%% Args are the skip and penalty (usually negative) \def\dobreak#1#2{\par\ifdim\lastskip<#1\removelastskip\penalty#2\vskip#1\fi} %%% Define plain chapter starts, and page on/off switching for it % Parameter controlling skip before chapter headings (if needed) \newskip\chapheadingskip \def\chapbreak{\dobreak \chapheadingskip {-4000}} \def\chappager{\par\vfill\supereject} % Because \domark is called before \chapoddpage, the filler page will % get the headings for the next chapter, which is wrong. But we don't % care -- we just disable all headings on the filler page. \def\chapoddpage{% \chappager \ifodd\pageno \else \begingroup \evenheadline={\hfil}\evenfootline={\hfil}% \oddheadline={\hfil}\oddfootline={\hfil}% \hbox to 0pt{}% \chappager \endgroup \fi } \def\setchapternewpage #1 {\csname CHAPPAG#1\endcsname} \def\CHAPPAGoff{% \global\let\contentsalignmacro = \chappager \global\let\pchapsepmacro=\chapbreak \global\let\pagealignmacro=\chappager} \def\CHAPPAGon{% \global\let\contentsalignmacro = \chappager \global\let\pchapsepmacro=\chappager \global\let\pagealignmacro=\chappager \global\def\HEADINGSon{\HEADINGSsingle}} \def\CHAPPAGodd{% \global\let\contentsalignmacro = \chapoddpage \global\let\pchapsepmacro=\chapoddpage \global\let\pagealignmacro=\chapoddpage \global\def\HEADINGSon{\HEADINGSdouble}} \CHAPPAGon % Chapter opening. % % #1 is the text, #2 is the section type (Ynumbered, Ynothing, % Yappendix, Yomitfromtoc), #3 the chapter number. % % To test against our argument. \def\Ynothingkeyword{Ynothing} \def\Yomitfromtockeyword{Yomitfromtoc} \def\Yappendixkeyword{Yappendix} % \def\chapmacro#1#2#3{% % Insert the first mark before the heading break (see notes for \domark). \let\prevchapterdefs=\lastchapterdefs \let\prevsectiondefs=\lastsectiondefs \gdef\lastsectiondefs{\gdef\thissectionname{}\gdef\thissectionnum{}% \gdef\thissection{}}% % \def\temptype{#2}% \ifx\temptype\Ynothingkeyword \gdef\lastchapterdefs{\gdef\thischaptername{#1}\gdef\thischapternum{}% \gdef\thischapter{\thischaptername}}% \else\ifx\temptype\Yomitfromtockeyword \gdef\lastchapterdefs{\gdef\thischaptername{#1}\gdef\thischapternum{}% \gdef\thischapter{}}% \else\ifx\temptype\Yappendixkeyword \toks0={#1}% \xdef\lastchapterdefs{% \gdef\noexpand\thischaptername{\the\toks0}% \gdef\noexpand\thischapternum{\appendixletter}% \gdef\noexpand\thischapter{\putwordAppendix{} \noexpand\thischapternum: \noexpand\thischaptername}% }% \else \toks0={#1}% \xdef\lastchapterdefs{% \gdef\noexpand\thischaptername{\the\toks0}% \gdef\noexpand\thischapternum{\the\chapno}% \gdef\noexpand\thischapter{\putwordChapter{} \noexpand\thischapternum: \noexpand\thischaptername}% }% \fi\fi\fi % % Output the mark. Pass it through \safewhatsit, to take care of % the preceding space. \safewhatsit\domark % % Insert the chapter heading break. \pchapsepmacro % % Now the second mark, after the heading break. No break points % between here and the heading. \let\prevchapterdefs=\lastchapterdefs \let\prevsectiondefs=\lastsectiondefs \domark % {% \chapfonts \rm % % Have to define \lastsection before calling \donoderef, because the % xref code eventually uses it. On the other hand, it has to be called % after \pchapsepmacro, or the headline will change too soon. \gdef\lastsection{#1}% % % Only insert the separating space if we have a chapter/appendix % number, and don't print the unnumbered ``number''. \ifx\temptype\Ynothingkeyword \setbox0 = \hbox{}% \def\toctype{unnchap}% \else\ifx\temptype\Yomitfromtockeyword \setbox0 = \hbox{}% contents like unnumbered, but no toc entry \def\toctype{omit}% \else\ifx\temptype\Yappendixkeyword \setbox0 = \hbox{\putwordAppendix{} #3\enspace}% \def\toctype{app}% \else \setbox0 = \hbox{#3\enspace}% \def\toctype{numchap}% \fi\fi\fi % % Write the toc entry for this chapter. Must come before the % \donoderef, because we include the current node name in the toc % entry, and \donoderef resets it to empty. \writetocentry{\toctype}{#1}{#3}% % % For pdftex, we have to write out the node definition (aka, make % the pdfdest) after any page break, but before the actual text has % been typeset. If the destination for the pdf outline is after the % text, then jumping from the outline may wind up with the text not % being visible, for instance under high magnification. \donoderef{#2}% % % Typeset the actual heading. \nobreak % Avoid page breaks at the interline glue. \vbox{\hyphenpenalty=10000 \tolerance=5000 \parindent=0pt \raggedright \hangindent=\wd0 \centerparametersmaybe \unhbox0 #1\par}% }% \nobreak\bigskip % no page break after a chapter title \nobreak } % @centerchap -- centered and unnumbered. \let\centerparametersmaybe = \relax \def\centerparameters{% \advance\rightskip by 3\rightskip \leftskip = \rightskip \parfillskip = 0pt } % I don't think this chapter style is supported any more, so I'm not % updating it with the new noderef stuff. We'll see. --karl, 11aug03. % \def\setchapterstyle #1 {\csname CHAPF#1\endcsname} % \def\unnchfopen #1{% \chapoddpage {\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 \parindent=0pt\raggedright \rm #1\hfill}}\bigskip \par\nobreak } \def\chfopen #1#2{\chapoddpage {\chapfonts \vbox to 3in{\vfil \hbox to\hsize{\hfil #2} \hbox to\hsize{\hfil #1} \vfil}}% \par\penalty 5000 % } \def\centerchfopen #1{% \chapoddpage {\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 \parindent=0pt \hfill {\rm #1}\hfill}}\bigskip \par\nobreak } \def\CHAPFopen{% \global\let\chapmacro=\chfopen \global\let\centerchapmacro=\centerchfopen} % Section titles. These macros combine the section number parts and % call the generic \sectionheading to do the printing. % \newskip\secheadingskip \def\secheadingbreak{\dobreak \secheadingskip{-1000}} % Subsection titles. \newskip\subsecheadingskip \def\subsecheadingbreak{\dobreak \subsecheadingskip{-500}} % Subsubsection titles. \def\subsubsecheadingskip{\subsecheadingskip} \def\subsubsecheadingbreak{\subsecheadingbreak} % Print any size, any type, section title. % % #1 is the text, #2 is the section level (sec/subsec/subsubsec), #3 is % the section type for xrefs (Ynumbered, Ynothing, Yappendix), #4 is the % section number. % \def\seckeyword{sec} % \def\sectionheading#1#2#3#4{% {% % Switch to the right set of fonts. \csname #2fonts\endcsname \rm % \def\sectionlevel{#2}% \def\temptype{#3}% % % Insert first mark before the heading break (see notes for \domark). \let\prevsectiondefs=\lastsectiondefs \ifx\temptype\Ynothingkeyword \ifx\sectionlevel\seckeyword \gdef\lastsectiondefs{\gdef\thissectionname{#1}\gdef\thissectionnum{}% \gdef\thissection{\thissectionname}}% \fi \else\ifx\temptype\Yomitfromtockeyword % Don't redefine \thissection. \else\ifx\temptype\Yappendixkeyword \ifx\sectionlevel\seckeyword \toks0={#1}% \xdef\lastsectiondefs{% \gdef\noexpand\thissectionname{\the\toks0}% \gdef\noexpand\thissectionnum{#4}% \gdef\noexpand\thissection{\putwordSection{} \noexpand\thissectionnum: \noexpand\thissectionname}% }% \fi \else \ifx\sectionlevel\seckeyword \toks0={#1}% \xdef\lastsectiondefs{% \gdef\noexpand\thissectionname{\the\toks0}% \gdef\noexpand\thissectionnum{#4}% \gdef\noexpand\thissection{\putwordSection{} \noexpand\thissectionnum: \noexpand\thissectionname}% }% \fi \fi\fi\fi % % Output the mark. Pass it through \safewhatsit, to take care of % the preceding space. \safewhatsit\domark % % Insert space above the heading. \csname #2headingbreak\endcsname % % Now the second mark, after the heading break. No break points % between here and the heading. \let\prevsectiondefs=\lastsectiondefs \domark % % Only insert the space after the number if we have a section number. \ifx\temptype\Ynothingkeyword \setbox0 = \hbox{}% \def\toctype{unn}% \gdef\lastsection{#1}% \else\ifx\temptype\Yomitfromtockeyword % for @headings -- no section number, don't include in toc, % and don't redefine \lastsection. \setbox0 = \hbox{}% \def\toctype{omit}% \let\sectionlevel=\empty \else\ifx\temptype\Yappendixkeyword \setbox0 = \hbox{#4\enspace}% \def\toctype{app}% \gdef\lastsection{#1}% \else \setbox0 = \hbox{#4\enspace}% \def\toctype{num}% \gdef\lastsection{#1}% \fi\fi\fi % % Write the toc entry (before \donoderef). See comments in \chapmacro. \writetocentry{\toctype\sectionlevel}{#1}{#4}% % % Write the node reference (= pdf destination for pdftex). % Again, see comments in \chapmacro. \donoderef{#3}% % % Interline glue will be inserted when the vbox is completed. % That glue will be a valid breakpoint for the page, since it'll be % preceded by a whatsit (usually from the \donoderef, or from the % \writetocentry if there was no node). We don't want to allow that % break, since then the whatsits could end up on page n while the % section is on page n+1, thus toc/etc. are wrong. Debian bug 276000. \nobreak % % Output the actual section heading. \vbox{\hyphenpenalty=10000 \tolerance=5000 \parindent=0pt \raggedright \hangindent=\wd0 % zero if no section number \unhbox0 #1}% }% % Add extra space after the heading -- half of whatever came above it. % Don't allow stretch, though. \kern .5 \csname #2headingskip\endcsname % % Do not let the kern be a potential breakpoint, as it would be if it % was followed by glue. \nobreak % % We'll almost certainly start a paragraph next, so don't let that % glue accumulate. (Not a breakpoint because it's preceded by a % discardable item.) \vskip-\parskip % % This is purely so the last item on the list is a known \penalty > % 10000. This is so \startdefun can avoid allowing breakpoints after % section headings. Otherwise, it would insert a valid breakpoint between: % % @section sec-whatever % @deffn def-whatever \penalty 10001 } \message{toc,} % Table of contents. \newwrite\tocfile % Write an entry to the toc file, opening it if necessary. % Called from @chapter, etc. % % Example usage: \writetocentry{sec}{Section Name}{\the\chapno.\the\secno} % We append the current node name (if any) and page number as additional % arguments for the \{chap,sec,...}entry macros which will eventually % read this. The node name is used in the pdf outlines as the % destination to jump to. % % We open the .toc file for writing here instead of at @setfilename (or % any other fixed time) so that @contents can be anywhere in the document. % But if #1 is `omit', then we don't do anything. This is used for the % table of contents chapter openings themselves. % \newif\iftocfileopened \def\omitkeyword{omit}% % \def\writetocentry#1#2#3{% \edef\writetoctype{#1}% \ifx\writetoctype\omitkeyword \else \iftocfileopened\else \immediate\openout\tocfile = \jobname.toc \global\tocfileopenedtrue \fi % \iflinks {\atdummies \edef\temp{% \write\tocfile{@#1entry{#2}{#3}{\lastnode}{\noexpand\folio}}}% \temp }% \fi \fi % % Tell \shipout to create a pdf destination on each page, if we're % writing pdf. These are used in the table of contents. We can't % just write one on every page because the title pages are numbered % 1 and 2 (the page numbers aren't printed), and so are the first % two pages of the document. Thus, we'd have two destinations named % `1', and two named `2'. \ifpdf \global\pdfmakepagedesttrue \fi } % These characters do not print properly in the Computer Modern roman % fonts, so we must take special care. This is more or less redundant % with the Texinfo input format setup at the end of this file. % \def\activecatcodes{% \catcode`\"=\active \catcode`\$=\active \catcode`\<=\active \catcode`\>=\active \catcode`\\=\active \catcode`\^=\active \catcode`\_=\active \catcode`\|=\active \catcode`\~=\active } % Read the toc file, which is essentially Texinfo input. \def\readtocfile{% \setupdatafile \activecatcodes \input \tocreadfilename } \newskip\contentsrightmargin \contentsrightmargin=1in \newcount\savepageno \newcount\lastnegativepageno \lastnegativepageno = -1 % Prepare to read what we've written to \tocfile. % \def\startcontents#1{% % If @setchapternewpage on, and @headings double, the contents should % start on an odd page, unlike chapters. Thus, we maintain % \contentsalignmacro in parallel with \pagealignmacro. % From: Torbjorn Granlund \contentsalignmacro \immediate\closeout\tocfile % % Don't need to put `Contents' or `Short Contents' in the headline. % It is abundantly clear what they are. \chapmacro{#1}{Yomitfromtoc}{}% % \savepageno = \pageno \begingroup % Set up to handle contents files properly. \raggedbottom % Worry more about breakpoints than the bottom. \advance\hsize by -\contentsrightmargin % Don't use the full line length. % % Roman numerals for page numbers. \ifnum \pageno>0 \global\pageno = \lastnegativepageno \fi } % redefined for the two-volume lispref. We always output on % \jobname.toc even if this is redefined. % \def\tocreadfilename{\jobname.toc} % Normal (long) toc. % \def\contents{% \startcontents{\putwordTOC}% \openin 1 \tocreadfilename\space \ifeof 1 \else \readtocfile \fi \vfill \eject \contentsalignmacro % in case @setchapternewpage odd is in effect \ifeof 1 \else \pdfmakeoutlines \fi \closein 1 \endgroup \lastnegativepageno = \pageno \global\pageno = \savepageno } % And just the chapters. \def\summarycontents{% \startcontents{\putwordShortTOC}% % \let\numchapentry = \shortchapentry \let\appentry = \shortchapentry \let\unnchapentry = \shortunnchapentry % We want a true roman here for the page numbers. \secfonts \let\rm=\shortcontrm \let\bf=\shortcontbf \let\sl=\shortcontsl \let\tt=\shortconttt \rm \hyphenpenalty = 10000 \advance\baselineskip by 1pt % Open it up a little. \def\numsecentry##1##2##3##4{} \let\appsecentry = \numsecentry \let\unnsecentry = \numsecentry \let\numsubsecentry = \numsecentry \let\appsubsecentry = \numsecentry \let\unnsubsecentry = \numsecentry \let\numsubsubsecentry = \numsecentry \let\appsubsubsecentry = \numsecentry \let\unnsubsubsecentry = \numsecentry \openin 1 \tocreadfilename\space \ifeof 1 \else \readtocfile \fi \closein 1 \vfill \eject \contentsalignmacro % in case @setchapternewpage odd is in effect \endgroup \lastnegativepageno = \pageno \global\pageno = \savepageno } \let\shortcontents = \summarycontents % Typeset the label for a chapter or appendix for the short contents. % The arg is, e.g., `A' for an appendix, or `3' for a chapter. % \def\shortchaplabel#1{% % This space should be enough, since a single number is .5em, and the % widest letter (M) is 1em, at least in the Computer Modern fonts. % But use \hss just in case. % (This space doesn't include the extra space that gets added after % the label; that gets put in by \shortchapentry above.) % % We'd like to right-justify chapter numbers, but that looks strange % with appendix letters. And right-justifying numbers and % left-justifying letters looks strange when there is less than 10 % chapters. Have to read the whole toc once to know how many chapters % there are before deciding ... \hbox to 1em{#1\hss}% } % These macros generate individual entries in the table of contents. % The first argument is the chapter or section name. % The last argument is the page number. % The arguments in between are the chapter number, section number, ... % Chapters, in the main contents. \def\numchapentry#1#2#3#4{\dochapentry{#2\labelspace#1}{#4}} % % Chapters, in the short toc. % See comments in \dochapentry re vbox and related settings. \def\shortchapentry#1#2#3#4{% \tocentry{\shortchaplabel{#2}\labelspace #1}{\doshortpageno\bgroup#4\egroup}% } % Appendices, in the main contents. % Need the word Appendix, and a fixed-size box. % \def\appendixbox#1{% % We use M since it's probably the widest letter. \setbox0 = \hbox{\putwordAppendix{} M}% \hbox to \wd0{\putwordAppendix{} #1\hss}} % \def\appentry#1#2#3#4{\dochapentry{\appendixbox{#2}\labelspace#1}{#4}} % Unnumbered chapters. \def\unnchapentry#1#2#3#4{\dochapentry{#1}{#4}} \def\shortunnchapentry#1#2#3#4{\tocentry{#1}{\doshortpageno\bgroup#4\egroup}} % Sections. \def\numsecentry#1#2#3#4{\dosecentry{#2\labelspace#1}{#4}} \let\appsecentry=\numsecentry \def\unnsecentry#1#2#3#4{\dosecentry{#1}{#4}} % Subsections. \def\numsubsecentry#1#2#3#4{\dosubsecentry{#2\labelspace#1}{#4}} \let\appsubsecentry=\numsubsecentry \def\unnsubsecentry#1#2#3#4{\dosubsecentry{#1}{#4}} % And subsubsections. \def\numsubsubsecentry#1#2#3#4{\dosubsubsecentry{#2\labelspace#1}{#4}} \let\appsubsubsecentry=\numsubsubsecentry \def\unnsubsubsecentry#1#2#3#4{\dosubsubsecentry{#1}{#4}} % This parameter controls the indentation of the various levels. % Same as \defaultparindent. \newdimen\tocindent \tocindent = 15pt % Now for the actual typesetting. In all these, #1 is the text and #2 is the % page number. % % If the toc has to be broken over pages, we want it to be at chapters % if at all possible; hence the \penalty. \def\dochapentry#1#2{% \penalty-300 \vskip1\baselineskip plus.33\baselineskip minus.25\baselineskip \begingroup \chapentryfonts \tocentry{#1}{\dopageno\bgroup#2\egroup}% \endgroup \nobreak\vskip .25\baselineskip plus.1\baselineskip } \def\dosecentry#1#2{\begingroup \secentryfonts \leftskip=\tocindent \tocentry{#1}{\dopageno\bgroup#2\egroup}% \endgroup} \def\dosubsecentry#1#2{\begingroup \subsecentryfonts \leftskip=2\tocindent \tocentry{#1}{\dopageno\bgroup#2\egroup}% \endgroup} \def\dosubsubsecentry#1#2{\begingroup \subsubsecentryfonts \leftskip=3\tocindent \tocentry{#1}{\dopageno\bgroup#2\egroup}% \endgroup} % We use the same \entry macro as for the index entries. \let\tocentry = \entry % Space between chapter (or whatever) number and the title. \def\labelspace{\hskip1em \relax} \def\dopageno#1{{\rm #1}} \def\doshortpageno#1{{\rm #1}} \def\chapentryfonts{\secfonts \rm} \def\secentryfonts{\textfonts} \def\subsecentryfonts{\textfonts} \def\subsubsecentryfonts{\textfonts} \message{environments,} % @foo ... @end foo. % @point{}, @result{}, @expansion{}, @print{}, @equiv{}. % % Since these characters are used in examples, it should be an even number of % \tt widths. Each \tt character is 1en, so two makes it 1em. % \def\point{$\star$} \def\result{\leavevmode\raise.15ex\hbox to 1em{\hfil$\Rightarrow$\hfil}} \def\expansion{\leavevmode\raise.1ex\hbox to 1em{\hfil$\mapsto$\hfil}} \def\print{\leavevmode\lower.1ex\hbox to 1em{\hfil$\dashv$\hfil}} \def\equiv{\leavevmode\lower.1ex\hbox to 1em{\hfil$\ptexequiv$\hfil}} % The @error{} command. % Adapted from the TeXbook's \boxit. % \newbox\errorbox % {\tentt \global\dimen0 = 3em}% Width of the box. \dimen2 = .55pt % Thickness of rules % The text. (`r' is open on the right, `e' somewhat less so on the left.) \setbox0 = \hbox{\kern-.75pt \reducedsf error\kern-1.5pt} % \setbox\errorbox=\hbox to \dimen0{\hfil \hsize = \dimen0 \advance\hsize by -5.8pt % Space to left+right. \advance\hsize by -2\dimen2 % Rules. \vbox{% \hrule height\dimen2 \hbox{\vrule width\dimen2 \kern3pt % Space to left of text. \vtop{\kern2.4pt \box0 \kern2.4pt}% Space above/below. \kern3pt\vrule width\dimen2}% Space to right. \hrule height\dimen2} \hfil} % \def\error{\leavevmode\lower.7ex\copy\errorbox} % @tex ... @end tex escapes into raw Tex temporarily. % One exception: @ is still an escape character, so that @end tex works. % But \@ or @@ will get a plain tex @ character. \envdef\tex{% \catcode `\\=0 \catcode `\{=1 \catcode `\}=2 \catcode `\$=3 \catcode `\&=4 \catcode `\#=6 \catcode `\^=7 \catcode `\_=8 \catcode `\~=\active \let~=\tie \catcode `\%=14 \catcode `\+=\other \catcode `\"=\other \catcode `\|=\other \catcode `\<=\other \catcode `\>=\other \escapechar=`\\ % \let\b=\ptexb \let\bullet=\ptexbullet \let\c=\ptexc \let\,=\ptexcomma \let\.=\ptexdot \let\dots=\ptexdots \let\equiv=\ptexequiv \let\!=\ptexexclam \let\i=\ptexi \let\indent=\ptexindent \let\noindent=\ptexnoindent \let\{=\ptexlbrace \let\+=\tabalign \let\}=\ptexrbrace \let\/=\ptexslash \let\*=\ptexstar \let\t=\ptext \let\frenchspacing=\plainfrenchspacing % \def\endldots{\mathinner{\ldots\ldots\ldots\ldots}}% \def\enddots{\relax\ifmmode\endldots\else$\mathsurround=0pt \endldots\,$\fi}% \def\@{@}% } % There is no need to define \Etex. % Define @lisp ... @end lisp. % @lisp environment forms a group so it can rebind things, % including the definition of @end lisp (which normally is erroneous). % Amount to narrow the margins by for @lisp. \newskip\lispnarrowing \lispnarrowing=0.4in % This is the definition that ^^M gets inside @lisp, @example, and other % such environments. \null is better than a space, since it doesn't % have any width. \def\lisppar{\null\endgraf} % This space is always present above and below environments. \newskip\envskipamount \envskipamount = 0pt % Make spacing and below environment symmetrical. We use \parskip here % to help in doing that, since in @example-like environments \parskip % is reset to zero; thus the \afterenvbreak inserts no space -- but the % start of the next paragraph will insert \parskip. % \def\aboveenvbreak{{% % =10000 instead of <10000 because of a special case in \itemzzz and % \sectionheading, q.v. \ifnum \lastpenalty=10000 \else \advance\envskipamount by \parskip \endgraf \ifdim\lastskip<\envskipamount \removelastskip % it's not a good place to break if the last penalty was \nobreak % or better ... \ifnum\lastpenalty<10000 \penalty-50 \fi \vskip\envskipamount \fi \fi }} \let\afterenvbreak = \aboveenvbreak % \nonarrowing is a flag. If "set", @lisp etc don't narrow margins; it will % also clear it, so that its embedded environments do the narrowing again. \let\nonarrowing=\relax % @cartouche ... @end cartouche: draw rectangle w/rounded corners around % environment contents. \font\circle=lcircle10 \newdimen\circthick \newdimen\cartouter\newdimen\cartinner \newskip\normbskip\newskip\normpskip\newskip\normlskip \circthick=\fontdimen8\circle % \def\ctl{{\circle\char'013\hskip -6pt}}% 6pt from pl file: 1/2charwidth \def\ctr{{\hskip 6pt\circle\char'010}} \def\cbl{{\circle\char'012\hskip -6pt}} \def\cbr{{\hskip 6pt\circle\char'011}} \def\carttop{\hbox to \cartouter{\hskip\lskip \ctl\leaders\hrule height\circthick\hfil\ctr \hskip\rskip}} \def\cartbot{\hbox to \cartouter{\hskip\lskip \cbl\leaders\hrule height\circthick\hfil\cbr \hskip\rskip}} % \newskip\lskip\newskip\rskip \envdef\cartouche{% \ifhmode\par\fi % can't be in the midst of a paragraph. \startsavinginserts \lskip=\leftskip \rskip=\rightskip \leftskip=0pt\rightskip=0pt % we want these *outside*. \cartinner=\hsize \advance\cartinner by-\lskip \advance\cartinner by-\rskip \cartouter=\hsize \advance\cartouter by 18.4pt % allow for 3pt kerns on either % side, and for 6pt waste from % each corner char, and rule thickness \normbskip=\baselineskip \normpskip=\parskip \normlskip=\lineskip % Flag to tell @lisp, etc., not to narrow margin. \let\nonarrowing = t% \vbox\bgroup \baselineskip=0pt\parskip=0pt\lineskip=0pt \carttop \hbox\bgroup \hskip\lskip \vrule\kern3pt \vbox\bgroup \kern3pt \hsize=\cartinner \baselineskip=\normbskip \lineskip=\normlskip \parskip=\normpskip \vskip -\parskip \comment % For explanation, see the end of \def\group. } \def\Ecartouche{% \ifhmode\par\fi \kern3pt \egroup \kern3pt\vrule \hskip\rskip \egroup \cartbot \egroup \checkinserts } % This macro is called at the beginning of all the @example variants, % inside a group. \def\nonfillstart{% \aboveenvbreak \hfuzz = 12pt % Don't be fussy \sepspaces % Make spaces be word-separators rather than space tokens. \let\par = \lisppar % don't ignore blank lines \obeylines % each line of input is a line of output \parskip = 0pt \parindent = 0pt \emergencystretch = 0pt % don't try to avoid overfull boxes \ifx\nonarrowing\relax \advance \leftskip by \lispnarrowing \exdentamount=\lispnarrowing \else \let\nonarrowing = \relax \fi \let\exdent=\nofillexdent } % If you want all examples etc. small: @set dispenvsize small. % If you want even small examples the full size: @set dispenvsize nosmall. % This affects the following displayed environments: % @example, @display, @format, @lisp % \def\smallword{small} \def\nosmallword{nosmall} \let\SETdispenvsize\relax \def\setnormaldispenv{% \ifx\SETdispenvsize\smallword % end paragraph for sake of leading, in case document has no blank % line. This is redundant with what happens in \aboveenvbreak, but % we need to do it before changing the fonts, and it's inconvenient % to change the fonts afterward. \ifnum \lastpenalty=10000 \else \endgraf \fi \smallexamplefonts \rm \fi } \def\setsmalldispenv{% \ifx\SETdispenvsize\nosmallword \else \ifnum \lastpenalty=10000 \else \endgraf \fi \smallexamplefonts \rm \fi } % We often define two environments, @foo and @smallfoo. % Let's do it by one command: \def\makedispenv #1#2{ \expandafter\envdef\csname#1\endcsname {\setnormaldispenv #2} \expandafter\envdef\csname small#1\endcsname {\setsmalldispenv #2} \expandafter\let\csname E#1\endcsname \afterenvbreak \expandafter\let\csname Esmall#1\endcsname \afterenvbreak } % Define two synonyms: \def\maketwodispenvs #1#2#3{ \makedispenv{#1}{#3} \makedispenv{#2}{#3} } % @lisp: indented, narrowed, typewriter font; @example: same as @lisp. % % @smallexample and @smalllisp: use smaller fonts. % Originally contributed by Pavel@xerox. % \maketwodispenvs {lisp}{example}{% \nonfillstart \tt\quoteexpand \let\kbdfont = \kbdexamplefont % Allow @kbd to do something special. \gobble % eat return } % @display/@smalldisplay: same as @lisp except keep current font. % \makedispenv {display}{% \nonfillstart \gobble } % @format/@smallformat: same as @display except don't narrow margins. % \makedispenv{format}{% \let\nonarrowing = t% \nonfillstart \gobble } % @flushleft: same as @format, but doesn't obey \SETdispenvsize. \envdef\flushleft{% \let\nonarrowing = t% \nonfillstart \gobble } \let\Eflushleft = \afterenvbreak % @flushright. % \envdef\flushright{% \let\nonarrowing = t% \nonfillstart \advance\leftskip by 0pt plus 1fill \gobble } \let\Eflushright = \afterenvbreak % @quotation does normal linebreaking (hence we can't use \nonfillstart) % and narrows the margins. We keep \parskip nonzero in general, since % we're doing normal filling. So, when using \aboveenvbreak and % \afterenvbreak, temporarily make \parskip 0. % \envdef\quotation{% {\parskip=0pt \aboveenvbreak}% because \aboveenvbreak inserts \parskip \parindent=0pt % % @cartouche defines \nonarrowing to inhibit narrowing at next level down. \ifx\nonarrowing\relax \advance\leftskip by \lispnarrowing \advance\rightskip by \lispnarrowing \exdentamount = \lispnarrowing \else \let\nonarrowing = \relax \fi \parsearg\quotationlabel } % We have retained a nonzero parskip for the environment, since we're % doing normal filling. % \def\Equotation{% \par \ifx\quotationauthor\undefined\else % indent a bit. \leftline{\kern 2\leftskip \sl ---\quotationauthor}% \fi {\parskip=0pt \afterenvbreak}% } % If we're given an argument, typeset it in bold with a colon after. \def\quotationlabel#1{% \def\temp{#1}% \ifx\temp\empty \else {\bf #1: }% \fi } % LaTeX-like @verbatim...@end verbatim and @verb{...} % If we want to allow any as delimiter, % we need the curly braces so that makeinfo sees the @verb command, eg: % `@verbx...x' would look like the '@verbx' command. --janneke@gnu.org % % [Knuth]: Donald Ervin Knuth, 1996. The TeXbook. % % [Knuth] p.344; only we need to do the other characters Texinfo sets % active too. Otherwise, they get lost as the first character on a % verbatim line. \def\dospecials{% \do\ \do\\\do\{\do\}\do\$\do\&% \do\#\do\^\do\^^K\do\_\do\^^A\do\%\do\~% \do\<\do\>\do\|\do\@\do+\do\"% } % % [Knuth] p. 380 \def\uncatcodespecials{% \def\do##1{\catcode`##1=\other}\dospecials} % % [Knuth] pp. 380,381,391 % Disable Spanish ligatures ?` and !` of \tt font \begingroup \catcode`\`=\active\gdef`{\relax\lq} \endgroup % % Setup for the @verb command. % % Eight spaces for a tab \begingroup \catcode`\^^I=\active \gdef\tabeightspaces{\catcode`\^^I=\active\def^^I{\ \ \ \ \ \ \ \ }} \endgroup % \def\setupverb{% \tt % easiest (and conventionally used) font for verbatim \def\par{\leavevmode\endgraf}% \catcode`\`=\active \tabeightspaces % Respect line breaks, % print special symbols as themselves, and % make each space count % must do in this order: \obeylines \uncatcodespecials \sepspaces } % Setup for the @verbatim environment % % Real tab expansion \newdimen\tabw \setbox0=\hbox{\tt\space} \tabw=8\wd0 % tab amount % \def\starttabbox{\setbox0=\hbox\bgroup} % Allow an option to not replace quotes with a regular directed right % quote/apostrophe (char 0x27), but instead use the undirected quote % from cmtt (char 0x0d). The undirected quote is ugly, so don't make it % the default, but it works for pasting with more pdf viewers (at least % evince), the lilypond developers report. xpdf does work with the % regular 0x27. % \def\codequoteright{% \expandafter\ifx\csname SETtxicodequoteundirected\endcsname\relax \expandafter\ifx\csname SETcodequoteundirected\endcsname\relax '% \else \char'15 \fi \else \char'15 \fi } % % and a similar option for the left quote char vs. a grave accent. % Modern fonts display ASCII 0x60 as a grave accent, so some people like % the code environments to do likewise. % \def\codequoteleft{% \expandafter\ifx\csname SETtxicodequotebacktick\endcsname\relax \expandafter\ifx\csname SETcodequotebacktick\endcsname\relax `% \else \char'22 \fi \else \char'22 \fi } % \begingroup \catcode`\^^I=\active \gdef\tabexpand{% \catcode`\^^I=\active \def^^I{\leavevmode\egroup \dimen0=\wd0 % the width so far, or since the previous tab \divide\dimen0 by\tabw \multiply\dimen0 by\tabw % compute previous multiple of \tabw \advance\dimen0 by\tabw % advance to next multiple of \tabw \wd0=\dimen0 \box0 \starttabbox }% } \catcode`\'=\active \gdef\rquoteexpand{\catcode\rquoteChar=\active \def'{\codequoteright}}% % \catcode`\`=\active \gdef\lquoteexpand{\catcode\lquoteChar=\active \def`{\codequoteleft}}% % \gdef\quoteexpand{\rquoteexpand \lquoteexpand}% \endgroup % start the verbatim environment. \def\setupverbatim{% \let\nonarrowing = t% \nonfillstart % Easiest (and conventionally used) font for verbatim \tt \def\par{\leavevmode\egroup\box0\endgraf}% \catcode`\`=\active \tabexpand \quoteexpand % Respect line breaks, % print special symbols as themselves, and % make each space count % must do in this order: \obeylines \uncatcodespecials \sepspaces \everypar{\starttabbox}% } % Do the @verb magic: verbatim text is quoted by unique % delimiter characters. Before first delimiter expect a % right brace, after last delimiter expect closing brace: % % \def\doverb'{'#1'}'{#1} % % [Knuth] p. 382; only eat outer {} \begingroup \catcode`[=1\catcode`]=2\catcode`\{=\other\catcode`\}=\other \gdef\doverb{#1[\def\next##1#1}[##1\endgroup]\next] \endgroup % \def\verb{\begingroup\setupverb\doverb} % % % Do the @verbatim magic: define the macro \doverbatim so that % the (first) argument ends when '@end verbatim' is reached, ie: % % \def\doverbatim#1@end verbatim{#1} % % For Texinfo it's a lot easier than for LaTeX, % because texinfo's \verbatim doesn't stop at '\end{verbatim}': % we need not redefine '\', '{' and '}'. % % Inspired by LaTeX's verbatim command set [latex.ltx] % \begingroup \catcode`\ =\active \obeylines % % ignore everything up to the first ^^M, that's the newline at the end % of the @verbatim input line itself. Otherwise we get an extra blank % line in the output. \xdef\doverbatim#1^^M#2@end verbatim{#2\noexpand\end\gobble verbatim}% % We really want {...\end verbatim} in the body of the macro, but % without the active space; thus we have to use \xdef and \gobble. \endgroup % \envdef\verbatim{% \setupverbatim\doverbatim } \let\Everbatim = \afterenvbreak % @verbatiminclude FILE - insert text of file in verbatim environment. % \def\verbatiminclude{\parseargusing\filenamecatcodes\doverbatiminclude} % \def\doverbatiminclude#1{% {% \makevalueexpandable \setupverbatim \input #1 \afterenvbreak }% } % @copying ... @end copying. % Save the text away for @insertcopying later. % % We save the uninterpreted tokens, rather than creating a box. % Saving the text in a box would be much easier, but then all the % typesetting commands (@smallbook, font changes, etc.) have to be done % beforehand -- and a) we want @copying to be done first in the source % file; b) letting users define the frontmatter in as flexible order as % possible is very desirable. % \def\copying{\checkenv{}\begingroup\scanargctxt\docopying} \def\docopying#1@end copying{\endgroup\def\copyingtext{#1}} % \def\insertcopying{% \begingroup \parindent = 0pt % paragraph indentation looks wrong on title page \scanexp\copyingtext \endgroup } \message{defuns,} % @defun etc. \newskip\defbodyindent \defbodyindent=.4in \newskip\defargsindent \defargsindent=50pt \newskip\deflastargmargin \deflastargmargin=18pt \newcount\defunpenalty % Start the processing of @deffn: \def\startdefun{% \ifnum\lastpenalty<10000 \medbreak \defunpenalty=10003 % Will keep this @deffn together with the % following @def command, see below. \else % If there are two @def commands in a row, we'll have a \nobreak, % which is there to keep the function description together with its % header. But if there's nothing but headers, we need to allow a % break somewhere. Check specifically for penalty 10002, inserted % by \printdefunline, instead of 10000, since the sectioning % commands also insert a nobreak penalty, and we don't want to allow % a break between a section heading and a defun. % % As a minor refinement, we avoid "club" headers by signalling % with penalty of 10003 after the very first @deffn in the % sequence (see above), and penalty of 10002 after any following % @def command. \ifnum\lastpenalty=10002 \penalty2000 \else \defunpenalty=10002 \fi % % Similarly, after a section heading, do not allow a break. % But do insert the glue. \medskip % preceded by discardable penalty, so not a breakpoint \fi % \parindent=0in \advance\leftskip by \defbodyindent \exdentamount=\defbodyindent } \def\dodefunx#1{% % First, check whether we are in the right environment: \checkenv#1% % % As above, allow line break if we have multiple x headers in a row. % It's not a great place, though. \ifnum\lastpenalty=10002 \penalty3000 \else \defunpenalty=10002 \fi % % And now, it's time to reuse the body of the original defun: \expandafter\gobbledefun#1% } \def\gobbledefun#1\startdefun{} % \printdefunline \deffnheader{text} % \def\printdefunline#1#2{% \begingroup % call \deffnheader: #1#2 \endheader % common ending: \interlinepenalty = 10000 \advance\rightskip by 0pt plus 1fil \endgraf \nobreak\vskip -\parskip \penalty\defunpenalty % signal to \startdefun and \dodefunx % Some of the @defun-type tags do not enable magic parentheses, % rendering the following check redundant. But we don't optimize. \checkparencounts \endgroup } \def\Edefun{\endgraf\medbreak} % \makedefun{deffn} creates \deffn, \deffnx and \Edeffn; % the only thing remainnig is to define \deffnheader. % \def\makedefun#1{% \expandafter\let\csname E#1\endcsname = \Edefun \edef\temp{\noexpand\domakedefun \makecsname{#1}\makecsname{#1x}\makecsname{#1header}}% \temp } % \domakedefun \deffn \deffnx \deffnheader % % Define \deffn and \deffnx, without parameters. % \deffnheader has to be defined explicitly. % \def\domakedefun#1#2#3{% \envdef#1{% \startdefun \parseargusing\activeparens{\printdefunline#3}% }% \def#2{\dodefunx#1}% \def#3% } %%% Untyped functions: % @deffn category name args \makedefun{deffn}{\deffngeneral{}} % @deffn category class name args \makedefun{defop}#1 {\defopon{#1\ \putwordon}} % \defopon {category on}class name args \def\defopon#1#2 {\deffngeneral{\putwordon\ \code{#2}}{#1\ \code{#2}} } % \deffngeneral {subind}category name args % \def\deffngeneral#1#2 #3 #4\endheader{% % Remember that \dosubind{fn}{foo}{} is equivalent to \doind{fn}{foo}. \dosubind{fn}{\code{#3}}{#1}% \defname{#2}{}{#3}\magicamp\defunargs{#4\unskip}% } %%% Typed functions: % @deftypefn category type name args \makedefun{deftypefn}{\deftypefngeneral{}} % @deftypeop category class type name args \makedefun{deftypeop}#1 {\deftypeopon{#1\ \putwordon}} % \deftypeopon {category on}class type name args \def\deftypeopon#1#2 {\deftypefngeneral{\putwordon\ \code{#2}}{#1\ \code{#2}} } % \deftypefngeneral {subind}category type name args % \def\deftypefngeneral#1#2 #3 #4 #5\endheader{% \dosubind{fn}{\code{#4}}{#1}% \defname{#2}{#3}{#4}\defunargs{#5\unskip}% } %%% Typed variables: % @deftypevr category type var args \makedefun{deftypevr}{\deftypecvgeneral{}} % @deftypecv category class type var args \makedefun{deftypecv}#1 {\deftypecvof{#1\ \putwordof}} % \deftypecvof {category of}class type var args \def\deftypecvof#1#2 {\deftypecvgeneral{\putwordof\ \code{#2}}{#1\ \code{#2}} } % \deftypecvgeneral {subind}category type var args % \def\deftypecvgeneral#1#2 #3 #4 #5\endheader{% \dosubind{vr}{\code{#4}}{#1}% \defname{#2}{#3}{#4}\defunargs{#5\unskip}% } %%% Untyped variables: % @defvr category var args \makedefun{defvr}#1 {\deftypevrheader{#1} {} } % @defcv category class var args \makedefun{defcv}#1 {\defcvof{#1\ \putwordof}} % \defcvof {category of}class var args \def\defcvof#1#2 {\deftypecvof{#1}#2 {} } %%% Type: % @deftp category name args \makedefun{deftp}#1 #2 #3\endheader{% \doind{tp}{\code{#2}}% \defname{#1}{}{#2}\defunargs{#3\unskip}% } % Remaining @defun-like shortcuts: \makedefun{defun}{\deffnheader{\putwordDeffunc} } \makedefun{defmac}{\deffnheader{\putwordDefmac} } \makedefun{defspec}{\deffnheader{\putwordDefspec} } \makedefun{deftypefun}{\deftypefnheader{\putwordDeffunc} } \makedefun{defvar}{\defvrheader{\putwordDefvar} } \makedefun{defopt}{\defvrheader{\putwordDefopt} } \makedefun{deftypevar}{\deftypevrheader{\putwordDefvar} } \makedefun{defmethod}{\defopon\putwordMethodon} \makedefun{deftypemethod}{\deftypeopon\putwordMethodon} \makedefun{defivar}{\defcvof\putwordInstanceVariableof} \makedefun{deftypeivar}{\deftypecvof\putwordInstanceVariableof} % \defname, which formats the name of the @def (not the args). % #1 is the category, such as "Function". % #2 is the return type, if any. % #3 is the function name. % % We are followed by (but not passed) the arguments, if any. % \def\defname#1#2#3{% % Get the values of \leftskip and \rightskip as they were outside the @def... \advance\leftskip by -\defbodyindent % % How we'll format the type name. Putting it in brackets helps % distinguish it from the body text that may end up on the next line % just below it. \def\temp{#1}% \setbox0=\hbox{\kern\deflastargmargin \ifx\temp\empty\else [\rm\temp]\fi} % % Figure out line sizes for the paragraph shape. % The first line needs space for \box0; but if \rightskip is nonzero, % we need only space for the part of \box0 which exceeds it: \dimen0=\hsize \advance\dimen0 by -\wd0 \advance\dimen0 by \rightskip % The continuations: \dimen2=\hsize \advance\dimen2 by -\defargsindent % (plain.tex says that \dimen1 should be used only as global.) \parshape 2 0in \dimen0 \defargsindent \dimen2 % % Put the type name to the right margin. \noindent \hbox to 0pt{% \hfil\box0 \kern-\hsize % \hsize has to be shortened this way: \kern\leftskip % Intentionally do not respect \rightskip, since we need the space. }% % % Allow all lines to be underfull without complaint: \tolerance=10000 \hbadness=10000 \exdentamount=\defbodyindent {% % defun fonts. We use typewriter by default (used to be bold) because: % . we're printing identifiers, they should be in tt in principle. % . in languages with many accents, such as Czech or French, it's % common to leave accents off identifiers. The result looks ok in % tt, but exceedingly strange in rm. % . we don't want -- and --- to be treated as ligatures. % . this still does not fix the ?` and !` ligatures, but so far no % one has made identifiers using them :). \df \tt \def\temp{#2}% return value type \ifx\temp\empty\else \tclose{\temp} \fi #3% output function name }% {\rm\enskip}% hskip 0.5 em of \tenrm % \boldbrax % arguments will be output next, if any. } % Print arguments in slanted roman (not ttsl), inconsistently with using % tt for the name. This is because literal text is sometimes needed in % the argument list (groff manual), and ttsl and tt are not very % distinguishable. Prevent hyphenation at `-' chars. % \def\defunargs#1{% % use sl by default (not ttsl), % tt for the names. \df \sl \hyphenchar\font=0 % % On the other hand, if an argument has two dashes (for instance), we % want a way to get ttsl. Let's try @var for that. \let\var=\ttslanted #1% \sl\hyphenchar\font=45 } % We want ()&[] to print specially on the defun line. % \def\activeparens{% \catcode`\(=\active \catcode`\)=\active \catcode`\[=\active \catcode`\]=\active \catcode`\&=\active } % Make control sequences which act like normal parenthesis chars. \let\lparen = ( \let\rparen = ) % Be sure that we always have a definition for `(', etc. For example, % if the fn name has parens in it, \boldbrax will not be in effect yet, % so TeX would otherwise complain about undefined control sequence. { \activeparens \global\let(=\lparen \global\let)=\rparen \global\let[=\lbrack \global\let]=\rbrack \global\let& = \& \gdef\boldbrax{\let(=\opnr\let)=\clnr\let[=\lbrb\let]=\rbrb} \gdef\magicamp{\let&=\amprm} } \newcount\parencount % If we encounter &foo, then turn on ()-hacking afterwards \newif\ifampseen \def\amprm#1 {\ampseentrue{\bf\ }} \def\parenfont{% \ifampseen % At the first level, print parens in roman, % otherwise use the default font. \ifnum \parencount=1 \rm \fi \else % The \sf parens (in \boldbrax) actually are a little bolder than % the contained text. This is especially needed for [ and ] . \sf \fi } \def\infirstlevel#1{% \ifampseen \ifnum\parencount=1 #1% \fi \fi } \def\bfafterword#1 {#1 \bf} \def\opnr{% \global\advance\parencount by 1 {\parenfont(}% \infirstlevel \bfafterword } \def\clnr{% {\parenfont)}% \infirstlevel \sl \global\advance\parencount by -1 } \newcount\brackcount \def\lbrb{% \global\advance\brackcount by 1 {\bf[}% } \def\rbrb{% {\bf]}% \global\advance\brackcount by -1 } \def\checkparencounts{% \ifnum\parencount=0 \else \badparencount \fi \ifnum\brackcount=0 \else \badbrackcount \fi } % these should not use \errmessage; the glibc manual, at least, actually % has such constructs (when documenting function pointers). \def\badparencount{% \message{Warning: unbalanced parentheses in @def...}% \global\parencount=0 } \def\badbrackcount{% \message{Warning: unbalanced square brackets in @def...}% \global\brackcount=0 } \message{macros,} % @macro. % To do this right we need a feature of e-TeX, \scantokens, % which we arrange to emulate with a temporary file in ordinary TeX. \ifx\eTeXversion\undefined \newwrite\macscribble \def\scantokens#1{% \toks0={#1}% \immediate\openout\macscribble=\jobname.tmp \immediate\write\macscribble{\the\toks0}% \immediate\closeout\macscribble \input \jobname.tmp } \fi \def\scanmacro#1{% \begingroup \newlinechar`\^^M \let\xeatspaces\eatspaces % Undo catcode changes of \startcontents and \doprintindex % When called from @insertcopying or (short)caption, we need active % backslash to get it printed correctly. Previously, we had % \catcode`\\=\other instead. We'll see whether a problem appears % with macro expansion. --kasal, 19aug04 \catcode`\@=0 \catcode`\\=\active \escapechar=`\@ % ... and \example \spaceisspace % % Append \endinput to make sure that TeX does not see the ending newline. % I've verified that it is necessary both for e-TeX and for ordinary TeX % --kasal, 29nov03 \scantokens{#1\endinput}% \endgroup } \def\scanexp#1{% \edef\temp{\noexpand\scanmacro{#1}}% \temp } \newcount\paramno % Count of parameters \newtoks\macname % Macro name \newif\ifrecursive % Is it recursive? % List of all defined macros in the form % \definedummyword\macro1\definedummyword\macro2... % Currently is also contains all @aliases; the list can be split % if there is a need. \def\macrolist{} % Add the macro to \macrolist \def\addtomacrolist#1{\expandafter \addtomacrolistxxx \csname#1\endcsname} \def\addtomacrolistxxx#1{% \toks0 = \expandafter{\macrolist\definedummyword#1}% \xdef\macrolist{\the\toks0}% } % Utility routines. % This does \let #1 = #2, with \csnames; that is, % \let \csname#1\endcsname = \csname#2\endcsname % (except of course we have to play expansion games). % \def\cslet#1#2{% \expandafter\let \csname#1\expandafter\endcsname \csname#2\endcsname } % Trim leading and trailing spaces off a string. % Concepts from aro-bend problem 15 (see CTAN). {\catcode`\@=11 \gdef\eatspaces #1{\expandafter\trim@\expandafter{#1 }} \gdef\trim@ #1{\trim@@ @#1 @ #1 @ @@} \gdef\trim@@ #1@ #2@ #3@@{\trim@@@\empty #2 @} \def\unbrace#1{#1} \unbrace{\gdef\trim@@@ #1 } #2@{#1} } % Trim a single trailing ^^M off a string. {\catcode`\^^M=\other \catcode`\Q=3% \gdef\eatcr #1{\eatcra #1Q^^MQ}% \gdef\eatcra#1^^MQ{\eatcrb#1Q}% \gdef\eatcrb#1Q#2Q{#1}% } % Macro bodies are absorbed as an argument in a context where % all characters are catcode 10, 11 or 12, except \ which is active % (as in normal texinfo). It is necessary to change the definition of \. % Non-ASCII encodings make 8-bit characters active, so un-activate % them to avoid their expansion. Must do this non-globally, to % confine the change to the current group. % It's necessary to have hard CRs when the macro is executed. This is % done by making ^^M (\endlinechar) catcode 12 when reading the macro % body, and then making it the \newlinechar in \scanmacro. \def\scanctxt{% \catcode`\"=\other \catcode`\+=\other \catcode`\<=\other \catcode`\>=\other \catcode`\@=\other \catcode`\^=\other \catcode`\_=\other \catcode`\|=\other \catcode`\~=\other \ifx\declaredencoding\ascii \else \setnonasciicharscatcodenonglobal\other \fi } \def\scanargctxt{% \scanctxt \catcode`\\=\other \catcode`\^^M=\other } \def\macrobodyctxt{% \scanctxt \catcode`\{=\other \catcode`\}=\other \catcode`\^^M=\other \usembodybackslash } \def\macroargctxt{% \scanctxt \catcode`\\=\other } % \mbodybackslash is the definition of \ in @macro bodies. % It maps \foo\ => \csname macarg.foo\endcsname => #N % where N is the macro parameter number. % We define \csname macarg.\endcsname to be \realbackslash, so % \\ in macro replacement text gets you a backslash. {\catcode`@=0 @catcode`@\=@active @gdef@usembodybackslash{@let\=@mbodybackslash} @gdef@mbodybackslash#1\{@csname macarg.#1@endcsname} } \expandafter\def\csname macarg.\endcsname{\realbackslash} \def\macro{\recursivefalse\parsearg\macroxxx} \def\rmacro{\recursivetrue\parsearg\macroxxx} \def\macroxxx#1{% \getargs{#1}% now \macname is the macname and \argl the arglist \ifx\argl\empty % no arguments \paramno=0% \else \expandafter\parsemargdef \argl;% \fi \if1\csname ismacro.\the\macname\endcsname \message{Warning: redefining \the\macname}% \else \expandafter\ifx\csname \the\macname\endcsname \relax \else \errmessage{Macro name \the\macname\space already defined}\fi \global\cslet{macsave.\the\macname}{\the\macname}% \global\expandafter\let\csname ismacro.\the\macname\endcsname=1% \addtomacrolist{\the\macname}% \fi \begingroup \macrobodyctxt \ifrecursive \expandafter\parsermacbody \else \expandafter\parsemacbody \fi} \parseargdef\unmacro{% \if1\csname ismacro.#1\endcsname \global\cslet{#1}{macsave.#1}% \global\expandafter\let \csname ismacro.#1\endcsname=0% % Remove the macro name from \macrolist: \begingroup \expandafter\let\csname#1\endcsname \relax \let\definedummyword\unmacrodo \xdef\macrolist{\macrolist}% \endgroup \else \errmessage{Macro #1 not defined}% \fi } % Called by \do from \dounmacro on each macro. The idea is to omit any % macro definitions that have been changed to \relax. % \def\unmacrodo#1{% \ifx #1\relax % remove this \else \noexpand\definedummyword \noexpand#1% \fi } % This makes use of the obscure feature that if the last token of a % is #, then the preceding argument is delimited by % an opening brace, and that opening brace is not consumed. \def\getargs#1{\getargsxxx#1{}} \def\getargsxxx#1#{\getmacname #1 \relax\getmacargs} \def\getmacname #1 #2\relax{\macname={#1}} \def\getmacargs#1{\def\argl{#1}} % Parse the optional {params} list. Set up \paramno and \paramlist % so \defmacro knows what to do. Define \macarg.blah for each blah % in the params list, to be ##N where N is the position in that list. % That gets used by \mbodybackslash (above). % We need to get `macro parameter char #' into several definitions. % The technique used is stolen from LaTeX: let \hash be something % unexpandable, insert that wherever you need a #, and then redefine % it to # just before using the token list produced. % % The same technique is used to protect \eatspaces till just before % the macro is used. \def\parsemargdef#1;{\paramno=0\def\paramlist{}% \let\hash\relax\let\xeatspaces\relax\parsemargdefxxx#1,;,} \def\parsemargdefxxx#1,{% \if#1;\let\next=\relax \else \let\next=\parsemargdefxxx \advance\paramno by 1% \expandafter\edef\csname macarg.\eatspaces{#1}\endcsname {\xeatspaces{\hash\the\paramno}}% \edef\paramlist{\paramlist\hash\the\paramno,}% \fi\next} % These two commands read recursive and nonrecursive macro bodies. % (They're different since rec and nonrec macros end differently.) \long\def\parsemacbody#1@end macro% {\xdef\temp{\eatcr{#1}}\endgroup\defmacro}% \long\def\parsermacbody#1@end rmacro% {\xdef\temp{\eatcr{#1}}\endgroup\defmacro}% % This defines the macro itself. There are six cases: recursive and % nonrecursive macros of zero, one, and many arguments. % Much magic with \expandafter here. % \xdef is used so that macro definitions will survive the file % they're defined in; @include reads the file inside a group. \def\defmacro{% \let\hash=##% convert placeholders to macro parameter chars \ifrecursive \ifcase\paramno % 0 \expandafter\xdef\csname\the\macname\endcsname{% \noexpand\scanmacro{\temp}}% \or % 1 \expandafter\xdef\csname\the\macname\endcsname{% \bgroup\noexpand\macroargctxt \noexpand\braceorline \expandafter\noexpand\csname\the\macname xxx\endcsname}% \expandafter\xdef\csname\the\macname xxx\endcsname##1{% \egroup\noexpand\scanmacro{\temp}}% \else % many \expandafter\xdef\csname\the\macname\endcsname{% \bgroup\noexpand\macroargctxt \noexpand\csname\the\macname xx\endcsname}% \expandafter\xdef\csname\the\macname xx\endcsname##1{% \expandafter\noexpand\csname\the\macname xxx\endcsname ##1,}% \expandafter\expandafter \expandafter\xdef \expandafter\expandafter \csname\the\macname xxx\endcsname \paramlist{\egroup\noexpand\scanmacro{\temp}}% \fi \else \ifcase\paramno % 0 \expandafter\xdef\csname\the\macname\endcsname{% \noexpand\norecurse{\the\macname}% \noexpand\scanmacro{\temp}\egroup}% \or % 1 \expandafter\xdef\csname\the\macname\endcsname{% \bgroup\noexpand\macroargctxt \noexpand\braceorline \expandafter\noexpand\csname\the\macname xxx\endcsname}% \expandafter\xdef\csname\the\macname xxx\endcsname##1{% \egroup \noexpand\norecurse{\the\macname}% \noexpand\scanmacro{\temp}\egroup}% \else % many \expandafter\xdef\csname\the\macname\endcsname{% \bgroup\noexpand\macroargctxt \expandafter\noexpand\csname\the\macname xx\endcsname}% \expandafter\xdef\csname\the\macname xx\endcsname##1{% \expandafter\noexpand\csname\the\macname xxx\endcsname ##1,}% \expandafter\expandafter \expandafter\xdef \expandafter\expandafter \csname\the\macname xxx\endcsname \paramlist{% \egroup \noexpand\norecurse{\the\macname}% \noexpand\scanmacro{\temp}\egroup}% \fi \fi} \def\norecurse#1{\bgroup\cslet{#1}{macsave.#1}} % \braceorline decides whether the next nonwhitespace character is a % {. If so it reads up to the closing }, if not, it reads the whole % line. Whatever was read is then fed to the next control sequence % as an argument (by \parsebrace or \parsearg) \def\braceorline#1{\let\macnamexxx=#1\futurelet\nchar\braceorlinexxx} \def\braceorlinexxx{% \ifx\nchar\bgroup\else \expandafter\parsearg \fi \macnamexxx} % @alias. % We need some trickery to remove the optional spaces around the equal % sign. Just make them active and then expand them all to nothing. \def\alias{\parseargusing\obeyspaces\aliasxxx} \def\aliasxxx #1{\aliasyyy#1\relax} \def\aliasyyy #1=#2\relax{% {% \expandafter\let\obeyedspace=\empty \addtomacrolist{#1}% \xdef\next{\global\let\makecsname{#1}=\makecsname{#2}}% }% \next } \message{cross references,} \newwrite\auxfile \newif\ifhavexrefs % True if xref values are known. \newif\ifwarnedxrefs % True if we warned once that they aren't known. % @inforef is relatively simple. \def\inforef #1{\inforefzzz #1,,,,**} \def\inforefzzz #1,#2,#3,#4**{\putwordSee{} \putwordInfo{} \putwordfile{} \file{\ignorespaces #3{}}, node \samp{\ignorespaces#1{}}} % @node's only job in TeX is to define \lastnode, which is used in % cross-references. The @node line might or might not have commas, and % might or might not have spaces before the first comma, like: % @node foo , bar , ... % We don't want such trailing spaces in the node name. % \parseargdef\node{\checkenv{}\donode #1 ,\finishnodeparse} % % also remove a trailing comma, in case of something like this: % @node Help-Cross, , , Cross-refs \def\donode#1 ,#2\finishnodeparse{\dodonode #1,\finishnodeparse} \def\dodonode#1,#2\finishnodeparse{\gdef\lastnode{#1}} \let\nwnode=\node \let\lastnode=\empty % Write a cross-reference definition for the current node. #1 is the % type (Ynumbered, Yappendix, Ynothing). % \def\donoderef#1{% \ifx\lastnode\empty\else \setref{\lastnode}{#1}% \global\let\lastnode=\empty \fi } % @anchor{NAME} -- define xref target at arbitrary point. % \newcount\savesfregister % \def\savesf{\relax \ifhmode \savesfregister=\spacefactor \fi} \def\restoresf{\relax \ifhmode \spacefactor=\savesfregister \fi} \def\anchor#1{\savesf \setref{#1}{Ynothing}\restoresf \ignorespaces} % \setref{NAME}{SNT} defines a cross-reference point NAME (a node or an % anchor), which consists of three parts: % 1) NAME-title - the current sectioning name taken from \lastsection, % or the anchor name. % 2) NAME-snt - section number and type, passed as the SNT arg, or % empty for anchors. % 3) NAME-pg - the page number. % % This is called from \donoderef, \anchor, and \dofloat. In the case of % floats, there is an additional part, which is not written here: % 4) NAME-lof - the text as it should appear in a @listoffloats. % \def\setref#1#2{% \pdfmkdest{#1}% \iflinks {% \atdummies % preserve commands, but don't expand them \edef\writexrdef##1##2{% \write\auxfile{@xrdef{#1-% #1 of \setref, expanded by the \edef ##1}{##2}}% these are parameters of \writexrdef }% \toks0 = \expandafter{\lastsection}% \immediate \writexrdef{title}{\the\toks0 }% \immediate \writexrdef{snt}{\csname #2\endcsname}% \Ynumbered etc. \safewhatsit{\writexrdef{pg}{\folio}}% will be written later, during \shipout }% \fi } % @xref, @pxref, and @ref generate cross-references. For \xrefX, #1 is % the node name, #2 the name of the Info cross-reference, #3 the printed % node name, #4 the name of the Info file, #5 the name of the printed % manual. All but the node name can be omitted. % \def\pxref#1{\putwordsee{} \xrefX[#1,,,,,,,]} \def\xref#1{\putwordSee{} \xrefX[#1,,,,,,,]} \def\ref#1{\xrefX[#1,,,,,,,]} \def\xrefX[#1,#2,#3,#4,#5,#6]{\begingroup \unsepspaces \def\printedmanual{\ignorespaces #5}% \def\printedrefname{\ignorespaces #3}% \setbox1=\hbox{\printedmanual\unskip}% \setbox0=\hbox{\printedrefname\unskip}% \ifdim \wd0 = 0pt % No printed node name was explicitly given. \expandafter\ifx\csname SETxref-automatic-section-title\endcsname\relax % Use the node name inside the square brackets. \def\printedrefname{\ignorespaces #1}% \else % Use the actual chapter/section title appear inside % the square brackets. Use the real section title if we have it. \ifdim \wd1 > 0pt % It is in another manual, so we don't have it. \def\printedrefname{\ignorespaces #1}% \else \ifhavexrefs % We know the real title if we have the xref values. \def\printedrefname{\refx{#1-title}{}}% \else % Otherwise just copy the Info node name. \def\printedrefname{\ignorespaces #1}% \fi% \fi \fi \fi % % Make link in pdf output. \ifpdf \leavevmode \getfilename{#4}% {\indexnofonts \turnoffactive % See comments at \activebackslashdouble. {\activebackslashdouble \xdef\pdfxrefdest{#1}% \backslashparens\pdfxrefdest}% % \ifnum\filenamelength>0 \startlink attr{/Border [0 0 0]}% goto file{\the\filename.pdf} name{\pdfxrefdest}% \else \startlink attr{/Border [0 0 0]}% goto name{\pdfmkpgn{\pdfxrefdest}}% \fi }% \setcolor{\linkcolor}% \fi % % Float references are printed completely differently: "Figure 1.2" % instead of "[somenode], p.3". We distinguish them by the % LABEL-title being set to a magic string. {% % Have to otherify everything special to allow the \csname to % include an _ in the xref name, etc. \indexnofonts \turnoffactive \expandafter\global\expandafter\let\expandafter\Xthisreftitle \csname XR#1-title\endcsname }% \iffloat\Xthisreftitle % If the user specified the print name (third arg) to the ref, % print it instead of our usual "Figure 1.2". \ifdim\wd0 = 0pt \refx{#1-snt}{}% \else \printedrefname \fi % % if the user also gave the printed manual name (fifth arg), append % "in MANUALNAME". \ifdim \wd1 > 0pt \space \putwordin{} \cite{\printedmanual}% \fi \else % node/anchor (non-float) references. % % If we use \unhbox0 and \unhbox1 to print the node names, TeX does not % insert empty discretionaries after hyphens, which means that it will % not find a line break at a hyphen in a node names. Since some manuals % are best written with fairly long node names, containing hyphens, this % is a loss. Therefore, we give the text of the node name again, so it % is as if TeX is seeing it for the first time. \ifdim \wd1 > 0pt \putwordSection{} ``\printedrefname'' \putwordin{} \cite{\printedmanual}% \else % _ (for example) has to be the character _ for the purposes of the % control sequence corresponding to the node, but it has to expand % into the usual \leavevmode...\vrule stuff for purposes of % printing. So we \turnoffactive for the \refx-snt, back on for the % printing, back off for the \refx-pg. {\turnoffactive % Only output a following space if the -snt ref is nonempty; for % @unnumbered and @anchor, it won't be. \setbox2 = \hbox{\ignorespaces \refx{#1-snt}{}}% \ifdim \wd2 > 0pt \refx{#1-snt}\space\fi }% % output the `[mynode]' via a macro so it can be overridden. \xrefprintnodename\printedrefname % % But we always want a comma and a space: ,\space % % output the `page 3'. \turnoffactive \putwordpage\tie\refx{#1-pg}{}% \fi \fi \endlink \endgroup} % This macro is called from \xrefX for the `[nodename]' part of xref % output. It's a separate macro only so it can be changed more easily, % since square brackets don't work well in some documents. Particularly % one that Bob is working on :). % \def\xrefprintnodename#1{[#1]} % Things referred to by \setref. % \def\Ynothing{} \def\Yomitfromtoc{} \def\Ynumbered{% \ifnum\secno=0 \putwordChapter@tie \the\chapno \else \ifnum\subsecno=0 \putwordSection@tie \the\chapno.\the\secno \else \ifnum\subsubsecno=0 \putwordSection@tie \the\chapno.\the\secno.\the\subsecno \else \putwordSection@tie \the\chapno.\the\secno.\the\subsecno.\the\subsubsecno \fi\fi\fi } \def\Yappendix{% \ifnum\secno=0 \putwordAppendix@tie @char\the\appendixno{}% \else \ifnum\subsecno=0 \putwordSection@tie @char\the\appendixno.\the\secno \else \ifnum\subsubsecno=0 \putwordSection@tie @char\the\appendixno.\the\secno.\the\subsecno \else \putwordSection@tie @char\the\appendixno.\the\secno.\the\subsecno.\the\subsubsecno \fi\fi\fi } % Define \refx{NAME}{SUFFIX} to reference a cross-reference string named NAME. % If its value is nonempty, SUFFIX is output afterward. % \def\refx#1#2{% {% \indexnofonts \otherbackslash \expandafter\global\expandafter\let\expandafter\thisrefX \csname XR#1\endcsname }% \ifx\thisrefX\relax % If not defined, say something at least. \angleleft un\-de\-fined\angleright \iflinks \ifhavexrefs \message{\linenumber Undefined cross reference `#1'.}% \else \ifwarnedxrefs\else \global\warnedxrefstrue \message{Cross reference values unknown; you must run TeX again.}% \fi \fi \fi \else % It's defined, so just use it. \thisrefX \fi #2% Output the suffix in any case. } % This is the macro invoked by entries in the aux file. Usually it's % just a \def (we prepend XR to the control sequence name to avoid % collisions). But if this is a float type, we have more work to do. % \def\xrdef#1#2{% {% The node name might contain 8-bit characters, which in our current % implementation are changed to commands like @'e. Don't let these % mess up the control sequence name. \indexnofonts \turnoffactive \xdef\safexrefname{#1}% }% % \expandafter\gdef\csname XR\safexrefname\endcsname{#2}% remember this xref % % Was that xref control sequence that we just defined for a float? \expandafter\iffloat\csname XR\safexrefname\endcsname % it was a float, and we have the (safe) float type in \iffloattype. \expandafter\let\expandafter\floatlist \csname floatlist\iffloattype\endcsname % % Is this the first time we've seen this float type? \expandafter\ifx\floatlist\relax \toks0 = {\do}% yes, so just \do \else % had it before, so preserve previous elements in list. \toks0 = \expandafter{\floatlist\do}% \fi % % Remember this xref in the control sequence \floatlistFLOATTYPE, % for later use in \listoffloats. \expandafter\xdef\csname floatlist\iffloattype\endcsname{\the\toks0 {\safexrefname}}% \fi } % Read the last existing aux file, if any. No error if none exists. % \def\tryauxfile{% \openin 1 \jobname.aux \ifeof 1 \else \readdatafile{aux}% \global\havexrefstrue \fi \closein 1 } \def\setupdatafile{% \catcode`\^^@=\other \catcode`\^^A=\other \catcode`\^^B=\other \catcode`\^^C=\other \catcode`\^^D=\other \catcode`\^^E=\other \catcode`\^^F=\other \catcode`\^^G=\other \catcode`\^^H=\other \catcode`\^^K=\other \catcode`\^^L=\other \catcode`\^^N=\other \catcode`\^^P=\other \catcode`\^^Q=\other \catcode`\^^R=\other \catcode`\^^S=\other \catcode`\^^T=\other \catcode`\^^U=\other \catcode`\^^V=\other \catcode`\^^W=\other \catcode`\^^X=\other \catcode`\^^Z=\other \catcode`\^^[=\other \catcode`\^^\=\other \catcode`\^^]=\other \catcode`\^^^=\other \catcode`\^^_=\other % It was suggested to set the catcode of ^ to 7, which would allow ^^e4 etc. % in xref tags, i.e., node names. But since ^^e4 notation isn't % supported in the main text, it doesn't seem desirable. Furthermore, % that is not enough: for node names that actually contain a ^ % character, we would end up writing a line like this: 'xrdef {'hat % b-title}{'hat b} and \xrdef does a \csname...\endcsname on the first % argument, and \hat is not an expandable control sequence. It could % all be worked out, but why? Either we support ^^ or we don't. % % The other change necessary for this was to define \auxhat: % \def\auxhat{\def^{'hat }}% extra space so ok if followed by letter % and then to call \auxhat in \setq. % \catcode`\^=\other % % Special characters. Should be turned off anyway, but... \catcode`\~=\other \catcode`\[=\other \catcode`\]=\other \catcode`\"=\other \catcode`\_=\other \catcode`\|=\other \catcode`\<=\other \catcode`\>=\other \catcode`\$=\other \catcode`\#=\other \catcode`\&=\other \catcode`\%=\other \catcode`+=\other % avoid \+ for paranoia even though we've turned it off % % This is to support \ in node names and titles, since the \ % characters end up in a \csname. It's easier than % leaving it active and making its active definition an actual \ % character. What I don't understand is why it works in the *value* % of the xrdef. Seems like it should be a catcode12 \, and that % should not typeset properly. But it works, so I'm moving on for % now. --karl, 15jan04. \catcode`\\=\other % % Make the characters 128-255 be printing characters. {% \count1=128 \def\loop{% \catcode\count1=\other \advance\count1 by 1 \ifnum \count1<256 \loop \fi }% }% % % @ is our escape character in .aux files, and we need braces. \catcode`\{=1 \catcode`\}=2 \catcode`\@=0 } \def\readdatafile#1{% \begingroup \setupdatafile \input\jobname.#1 \endgroup} \message{insertions,} % including footnotes. \newcount \footnoteno % The trailing space in the following definition for supereject is % vital for proper filling; pages come out unaligned when you do a % pagealignmacro call if that space before the closing brace is % removed. (Generally, numeric constants should always be followed by a % space to prevent strange expansion errors.) \def\supereject{\par\penalty -20000\footnoteno =0 } % @footnotestyle is meaningful for info output only. \let\footnotestyle=\comment {\catcode `\@=11 % % Auto-number footnotes. Otherwise like plain. \gdef\footnote{% \let\indent=\ptexindent \let\noindent=\ptexnoindent \global\advance\footnoteno by \@ne \edef\thisfootno{$^{\the\footnoteno}$}% % % In case the footnote comes at the end of a sentence, preserve the % extra spacing after we do the footnote number. \let\@sf\empty \ifhmode\edef\@sf{\spacefactor\the\spacefactor}\ptexslash\fi % % Remove inadvertent blank space before typesetting the footnote number. \unskip \thisfootno\@sf \dofootnote }% % Don't bother with the trickery in plain.tex to not require the % footnote text as a parameter. Our footnotes don't need to be so general. % % Oh yes, they do; otherwise, @ifset (and anything else that uses % \parseargline) fails inside footnotes because the tokens are fixed when % the footnote is read. --karl, 16nov96. % \gdef\dofootnote{% \insert\footins\bgroup % We want to typeset this text as a normal paragraph, even if the % footnote reference occurs in (for example) a display environment. % So reset some parameters. \hsize=\pagewidth \interlinepenalty\interfootnotelinepenalty \splittopskip\ht\strutbox % top baseline for broken footnotes \splitmaxdepth\dp\strutbox \floatingpenalty\@MM \leftskip\z@skip \rightskip\z@skip \spaceskip\z@skip \xspaceskip\z@skip \parindent\defaultparindent % \smallfonts \rm % % Because we use hanging indentation in footnotes, a @noindent appears % to exdent this text, so make it be a no-op. makeinfo does not use % hanging indentation so @noindent can still be needed within footnote % text after an @example or the like (not that this is good style). \let\noindent = \relax % % Hang the footnote text off the number. Use \everypar in case the % footnote extends for more than one paragraph. \everypar = {\hang}% \textindent{\thisfootno}% % % Don't crash into the line above the footnote text. Since this % expands into a box, it must come within the paragraph, lest it % provide a place where TeX can split the footnote. \footstrut \futurelet\next\fo@t } }%end \catcode `\@=11 % In case a @footnote appears in a vbox, save the footnote text and create % the real \insert just after the vbox finished. Otherwise, the insertion % would be lost. % Similarily, if a @footnote appears inside an alignment, save the footnote % text to a box and make the \insert when a row of the table is finished. % And the same can be done for other insert classes. --kasal, 16nov03. % Replace the \insert primitive by a cheating macro. % Deeper inside, just make sure that the saved insertions are not spilled % out prematurely. % \def\startsavinginserts{% \ifx \insert\ptexinsert \let\insert\saveinsert \else \let\checkinserts\relax \fi } % This \insert replacement works for both \insert\footins{foo} and % \insert\footins\bgroup foo\egroup, but it doesn't work for \insert27{foo}. % \def\saveinsert#1{% \edef\next{\noexpand\savetobox \makeSAVEname#1}% \afterassignment\next % swallow the left brace \let\temp = } \def\makeSAVEname#1{\makecsname{SAVE\expandafter\gobble\string#1}} \def\savetobox#1{\global\setbox#1 = \vbox\bgroup \unvbox#1} \def\checksaveins#1{\ifvoid#1\else \placesaveins#1\fi} \def\placesaveins#1{% \ptexinsert \csname\expandafter\gobblesave\string#1\endcsname {\box#1}% } % eat @SAVE -- beware, all of them have catcode \other: { \def\dospecials{\do S\do A\do V\do E} \uncatcodespecials % ;-) \gdef\gobblesave @SAVE{} } % initialization: \def\newsaveins #1{% \edef\next{\noexpand\newsaveinsX \makeSAVEname#1}% \next } \def\newsaveinsX #1{% \csname newbox\endcsname #1% \expandafter\def\expandafter\checkinserts\expandafter{\checkinserts \checksaveins #1}% } % initialize: \let\checkinserts\empty \newsaveins\footins \newsaveins\margin % @image. We use the macros from epsf.tex to support this. % If epsf.tex is not installed and @image is used, we complain. % % Check for and read epsf.tex up front. If we read it only at @image % time, we might be inside a group, and then its definitions would get % undone and the next image would fail. \openin 1 = epsf.tex \ifeof 1 \else % Do not bother showing banner with epsf.tex v2.7k (available in % doc/epsf.tex and on ctan). \def\epsfannounce{\toks0 = }% \input epsf.tex \fi \closein 1 % % We will only complain once about lack of epsf.tex. \newif\ifwarnednoepsf \newhelp\noepsfhelp{epsf.tex must be installed for images to work. It is also included in the Texinfo distribution, or you can get it from ftp://tug.org/tex/epsf.tex.} % \def\image#1{% \ifx\epsfbox\undefined \ifwarnednoepsf \else \errhelp = \noepsfhelp \errmessage{epsf.tex not found, images will be ignored}% \global\warnednoepsftrue \fi \else \imagexxx #1,,,,,\finish \fi } % % Arguments to @image: % #1 is (mandatory) image filename; we tack on .eps extension. % #2 is (optional) width, #3 is (optional) height. % #4 is (ignored optional) html alt text. % #5 is (ignored optional) extension. % #6 is just the usual extra ignored arg for parsing this stuff. \newif\ifimagevmode \def\imagexxx#1,#2,#3,#4,#5,#6\finish{\begingroup \catcode`\^^M = 5 % in case we're inside an example \normalturnoffactive % allow _ et al. in names % If the image is by itself, center it. \ifvmode \imagevmodetrue \nobreak\bigskip % Usually we'll have text after the image which will insert % \parskip glue, so insert it here too to equalize the space % above and below. \nobreak\vskip\parskip \nobreak \line\bgroup \fi % % Output the image. \ifpdf \dopdfimage{#1}{#2}{#3}% \else % \epsfbox itself resets \epsf?size at each figure. \setbox0 = \hbox{\ignorespaces #2}\ifdim\wd0 > 0pt \epsfxsize=#2\relax \fi \setbox0 = \hbox{\ignorespaces #3}\ifdim\wd0 > 0pt \epsfysize=#3\relax \fi \epsfbox{#1.eps}% \fi % \ifimagevmode \egroup \bigbreak \fi % space after the image \endgroup} % @float FLOATTYPE,LABEL,LOC ... @end float for displayed figures, tables, % etc. We don't actually implement floating yet, we always include the % float "here". But it seemed the best name for the future. % \envparseargdef\float{\eatcommaspace\eatcommaspace\dofloat#1, , ,\finish} % There may be a space before second and/or third parameter; delete it. \def\eatcommaspace#1, {#1,} % #1 is the optional FLOATTYPE, the text label for this float, typically % "Figure", "Table", "Example", etc. Can't contain commas. If omitted, % this float will not be numbered and cannot be referred to. % % #2 is the optional xref label. Also must be present for the float to % be referable. % % #3 is the optional positioning argument; for now, it is ignored. It % will somehow specify the positions allowed to float to (here, top, bottom). % % We keep a separate counter for each FLOATTYPE, which we reset at each % chapter-level command. \let\resetallfloatnos=\empty % \def\dofloat#1,#2,#3,#4\finish{% \let\thiscaption=\empty \let\thisshortcaption=\empty % % don't lose footnotes inside @float. % % BEWARE: when the floats start float, we have to issue warning whenever an % insert appears inside a float which could possibly float. --kasal, 26may04 % \startsavinginserts % % We can't be used inside a paragraph. \par % \vtop\bgroup \def\floattype{#1}% \def\floatlabel{#2}% \def\floatloc{#3}% we do nothing with this yet. % \ifx\floattype\empty \let\safefloattype=\empty \else {% % the floattype might have accents or other special characters, % but we need to use it in a control sequence name. \indexnofonts \turnoffactive \xdef\safefloattype{\floattype}% }% \fi % % If label is given but no type, we handle that as the empty type. \ifx\floatlabel\empty \else % We want each FLOATTYPE to be numbered separately (Figure 1, % Table 1, Figure 2, ...). (And if no label, no number.) % \expandafter\getfloatno\csname\safefloattype floatno\endcsname \global\advance\floatno by 1 % {% % This magic value for \lastsection is output by \setref as the % XREFLABEL-title value. \xrefX uses it to distinguish float % labels (which have a completely different output format) from % node and anchor labels. And \xrdef uses it to construct the % lists of floats. % \edef\lastsection{\floatmagic=\safefloattype}% \setref{\floatlabel}{Yfloat}% }% \fi % % start with \parskip glue, I guess. \vskip\parskip % % Don't suppress indentation if a float happens to start a section. \restorefirstparagraphindent } % we have these possibilities: % @float Foo,lbl & @caption{Cap}: Foo 1.1: Cap % @float Foo,lbl & no caption: Foo 1.1 % @float Foo & @caption{Cap}: Foo: Cap % @float Foo & no caption: Foo % @float ,lbl & Caption{Cap}: 1.1: Cap % @float ,lbl & no caption: 1.1 % @float & @caption{Cap}: Cap % @float & no caption: % \def\Efloat{% \let\floatident = \empty % % In all cases, if we have a float type, it comes first. \ifx\floattype\empty \else \def\floatident{\floattype}\fi % % If we have an xref label, the number comes next. \ifx\floatlabel\empty \else \ifx\floattype\empty \else % if also had float type, need tie first. \appendtomacro\floatident{\tie}% \fi % the number. \appendtomacro\floatident{\chaplevelprefix\the\floatno}% \fi % % Start the printed caption with what we've constructed in % \floatident, but keep it separate; we need \floatident again. \let\captionline = \floatident % \ifx\thiscaption\empty \else \ifx\floatident\empty \else \appendtomacro\captionline{: }% had ident, so need a colon between \fi % % caption text. \appendtomacro\captionline{\scanexp\thiscaption}% \fi % % If we have anything to print, print it, with space before. % Eventually this needs to become an \insert. \ifx\captionline\empty \else \vskip.5\parskip \captionline % % Space below caption. \vskip\parskip \fi % % If have an xref label, write the list of floats info. Do this % after the caption, to avoid chance of it being a breakpoint. \ifx\floatlabel\empty \else % Write the text that goes in the lof to the aux file as % \floatlabel-lof. Besides \floatident, we include the short % caption if specified, else the full caption if specified, else nothing. {% \atdummies % % since we read the caption text in the macro world, where ^^M % is turned into a normal character, we have to scan it back, so % we don't write the literal three characters "^^M" into the aux file. \scanexp{% \xdef\noexpand\gtemp{% \ifx\thisshortcaption\empty \thiscaption \else \thisshortcaption \fi }% }% \immediate\write\auxfile{@xrdef{\floatlabel-lof}{\floatident \ifx\gtemp\empty \else : \gtemp \fi}}% }% \fi \egroup % end of \vtop % % place the captured inserts % % BEWARE: when the floats start floating, we have to issue warning % whenever an insert appears inside a float which could possibly % float. --kasal, 26may04 % \checkinserts } % Append the tokens #2 to the definition of macro #1, not expanding either. % \def\appendtomacro#1#2{% \expandafter\def\expandafter#1\expandafter{#1#2}% } % @caption, @shortcaption % \def\caption{\docaption\thiscaption} \def\shortcaption{\docaption\thisshortcaption} \def\docaption{\checkenv\float \bgroup\scanargctxt\defcaption} \def\defcaption#1#2{\egroup \def#1{#2}} % The parameter is the control sequence identifying the counter we are % going to use. Create it if it doesn't exist and assign it to \floatno. \def\getfloatno#1{% \ifx#1\relax % Haven't seen this figure type before. \csname newcount\endcsname #1% % % Remember to reset this floatno at the next chap. \expandafter\gdef\expandafter\resetallfloatnos \expandafter{\resetallfloatnos #1=0 }% \fi \let\floatno#1% } % \setref calls this to get the XREFLABEL-snt value. We want an @xref % to the FLOATLABEL to expand to "Figure 3.1". We call \setref when we % first read the @float command. % \def\Yfloat{\floattype@tie \chaplevelprefix\the\floatno}% % Magic string used for the XREFLABEL-title value, so \xrefX can % distinguish floats from other xref types. \def\floatmagic{!!float!!} % #1 is the control sequence we are passed; we expand into a conditional % which is true if #1 represents a float ref. That is, the magic % \lastsection value which we \setref above. % \def\iffloat#1{\expandafter\doiffloat#1==\finish} % % #1 is (maybe) the \floatmagic string. If so, #2 will be the % (safe) float type for this float. We set \iffloattype to #2. % \def\doiffloat#1=#2=#3\finish{% \def\temp{#1}% \def\iffloattype{#2}% \ifx\temp\floatmagic } % @listoffloats FLOATTYPE - print a list of floats like a table of contents. % \parseargdef\listoffloats{% \def\floattype{#1}% floattype {% % the floattype might have accents or other special characters, % but we need to use it in a control sequence name. \indexnofonts \turnoffactive \xdef\safefloattype{\floattype}% }% % % \xrdef saves the floats as a \do-list in \floatlistSAFEFLOATTYPE. \expandafter\ifx\csname floatlist\safefloattype\endcsname \relax \ifhavexrefs % if the user said @listoffloats foo but never @float foo. \message{\linenumber No `\safefloattype' floats to list.}% \fi \else \begingroup \leftskip=\tocindent % indent these entries like a toc \let\do=\listoffloatsdo \csname floatlist\safefloattype\endcsname \endgroup \fi } % This is called on each entry in a list of floats. We're passed the % xref label, in the form LABEL-title, which is how we save it in the % aux file. We strip off the -title and look up \XRLABEL-lof, which % has the text we're supposed to typeset here. % % Figures without xref labels will not be included in the list (since % they won't appear in the aux file). % \def\listoffloatsdo#1{\listoffloatsdoentry#1\finish} \def\listoffloatsdoentry#1-title\finish{{% % Can't fully expand XR#1-lof because it can contain anything. Just % pass the control sequence. On the other hand, XR#1-pg is just the % page number, and we want to fully expand that so we can get a link % in pdf output. \toksA = \expandafter{\csname XR#1-lof\endcsname}% % % use the same \entry macro we use to generate the TOC and index. \edef\writeentry{\noexpand\entry{\the\toksA}{\csname XR#1-pg\endcsname}}% \writeentry }} \message{localization,} % @documentlanguage is usually given very early, just after % @setfilename. If done too late, it may not override everything % properly. Single argument is the language (de) or locale (de_DE) % abbreviation. It would be nice if we could set up a hyphenation file. % { \catcode`\_ = \active \globaldefs=1 \parseargdef\documentlanguage{\begingroup \let_=\normalunderscore % normal _ character for filenames \tex % read txi-??.tex file in plain TeX. % Read the file by the name they passed if it exists. \openin 1 txi-#1.tex \ifeof 1 \documentlanguagetrywithoutunderscore{#1_\finish}% \else \input txi-#1.tex \fi \closein 1 \endgroup \endgroup} } % % If they passed de_DE, and txi-de_DE.tex doesn't exist, % try txi-de.tex. % \def\documentlanguagetrywithoutunderscore#1_#2\finish{% \openin 1 txi-#1.tex \ifeof 1 \errhelp = \nolanghelp \errmessage{Cannot read language file txi-#1.tex}% \else \input txi-#1.tex \fi \closein 1 } % \newhelp\nolanghelp{The given language definition file cannot be found or is empty. Maybe you need to install it? In the current directory should work if nowhere else does.} % Set the catcode of characters 128 through 255 to the specified number. % \def\setnonasciicharscatcode#1{% \count255=128 \loop\ifnum\count255<256 \global\catcode\count255=#1\relax \advance\count255 by 1 \repeat } \def\setnonasciicharscatcodenonglobal#1{% \count255=128 \loop\ifnum\count255<256 \catcode\count255=#1\relax \advance\count255 by 1 \repeat } % @documentencoding sets the definition of non-ASCII characters % according to the specified encoding. % \parseargdef\documentencoding{% % Encoding being declared for the document. \def\declaredencoding{\csname #1.enc\endcsname}% % % Supported encodings: names converted to tokens in order to be able % to compare them with \ifx. \def\ascii{\csname US-ASCII.enc\endcsname}% \def\latnine{\csname ISO-8859-15.enc\endcsname}% \def\latone{\csname ISO-8859-1.enc\endcsname}% \def\lattwo{\csname ISO-8859-2.enc\endcsname}% \def\utfeight{\csname UTF-8.enc\endcsname}% % \ifx \declaredencoding \ascii \asciichardefs % \else \ifx \declaredencoding \lattwo \setnonasciicharscatcode\active \lattwochardefs % \else \ifx \declaredencoding \latone \setnonasciicharscatcode\active \latonechardefs % \else \ifx \declaredencoding \latnine \setnonasciicharscatcode\active \latninechardefs % \else \ifx \declaredencoding \utfeight \setnonasciicharscatcode\active \utfeightchardefs % \else \message{Unknown document encoding #1, ignoring.}% % \fi % utfeight \fi % latnine \fi % latone \fi % lattwo \fi % ascii } % A message to be logged when using a character that isn't available % the default font encoding (OT1). % \def\missingcharmsg#1{\message{Character missing in OT1 encoding: #1.}} % Take account of \c (plain) vs. \, (Texinfo) difference. \def\cedilla#1{\ifx\c\ptexc\c{#1}\else\,{#1}\fi} % First, make active non-ASCII characters in order for them to be % correctly categorized when TeX reads the replacement text of % macros containing the character definitions. \setnonasciicharscatcode\active % % Latin1 (ISO-8859-1) character definitions. \def\latonechardefs{% \gdef^^a0{~} \gdef^^a1{\exclamdown} \gdef^^a2{\missingcharmsg{CENT SIGN}} \gdef^^a3{{\pounds}} \gdef^^a4{\missingcharmsg{CURRENCY SIGN}} \gdef^^a5{\missingcharmsg{YEN SIGN}} \gdef^^a6{\missingcharmsg{BROKEN BAR}} \gdef^^a7{\S} \gdef^^a8{\"{}} \gdef^^a9{\copyright} \gdef^^aa{\ordf} \gdef^^ab{\missingcharmsg{LEFT-POINTING DOUBLE ANGLE QUOTATION MARK}} \gdef^^ac{$\lnot$} \gdef^^ad{\-} \gdef^^ae{\registeredsymbol} \gdef^^af{\={}} % \gdef^^b0{\textdegree} \gdef^^b1{$\pm$} \gdef^^b2{$^2$} \gdef^^b3{$^3$} \gdef^^b4{\'{}} \gdef^^b5{$\mu$} \gdef^^b6{\P} % \gdef^^b7{$^.$} \gdef^^b8{\cedilla\ } \gdef^^b9{$^1$} \gdef^^ba{\ordm} % \gdef^^bb{\missingcharmsg{RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK}} \gdef^^bc{$1\over4$} \gdef^^bd{$1\over2$} \gdef^^be{$3\over4$} \gdef^^bf{\questiondown} % \gdef^^c0{\`A} \gdef^^c1{\'A} \gdef^^c2{\^A} \gdef^^c3{\~A} \gdef^^c4{\"A} \gdef^^c5{\ringaccent A} \gdef^^c6{\AE} \gdef^^c7{\cedilla C} \gdef^^c8{\`E} \gdef^^c9{\'E} \gdef^^ca{\^E} \gdef^^cb{\"E} \gdef^^cc{\`I} \gdef^^cd{\'I} \gdef^^ce{\^I} \gdef^^cf{\"I} % \gdef^^d0{\missingcharmsg{LATIN CAPITAL LETTER ETH}} \gdef^^d1{\~N} \gdef^^d2{\`O} \gdef^^d3{\'O} \gdef^^d4{\^O} \gdef^^d5{\~O} \gdef^^d6{\"O} \gdef^^d7{$\times$} \gdef^^d8{\O} \gdef^^d9{\`U} \gdef^^da{\'U} \gdef^^db{\^U} \gdef^^dc{\"U} \gdef^^dd{\'Y} \gdef^^de{\missingcharmsg{LATIN CAPITAL LETTER THORN}} \gdef^^df{\ss} % \gdef^^e0{\`a} \gdef^^e1{\'a} \gdef^^e2{\^a} \gdef^^e3{\~a} \gdef^^e4{\"a} \gdef^^e5{\ringaccent a} \gdef^^e6{\ae} \gdef^^e7{\cedilla c} \gdef^^e8{\`e} \gdef^^e9{\'e} \gdef^^ea{\^e} \gdef^^eb{\"e} \gdef^^ec{\`{\dotless i}} \gdef^^ed{\'{\dotless i}} \gdef^^ee{\^{\dotless i}} \gdef^^ef{\"{\dotless i}} % \gdef^^f0{\missingcharmsg{LATIN SMALL LETTER ETH}} \gdef^^f1{\~n} \gdef^^f2{\`o} \gdef^^f3{\'o} \gdef^^f4{\^o} \gdef^^f5{\~o} \gdef^^f6{\"o} \gdef^^f7{$\div$} \gdef^^f8{\o} \gdef^^f9{\`u} \gdef^^fa{\'u} \gdef^^fb{\^u} \gdef^^fc{\"u} \gdef^^fd{\'y} \gdef^^fe{\missingcharmsg{LATIN SMALL LETTER THORN}} \gdef^^ff{\"y} } % Latin9 (ISO-8859-15) encoding character definitions. \def\latninechardefs{% % Encoding is almost identical to Latin1. \latonechardefs % \gdef^^a4{\euro} \gdef^^a6{\v S} \gdef^^a8{\v s} \gdef^^b4{\v Z} \gdef^^b8{\v z} \gdef^^bc{\OE} \gdef^^bd{\oe} \gdef^^be{\"Y} } % Latin2 (ISO-8859-2) character definitions. \def\lattwochardefs{% \gdef^^a0{~} \gdef^^a1{\missingcharmsg{LATIN CAPITAL LETTER A WITH OGONEK}} \gdef^^a2{\u{}} \gdef^^a3{\L} \gdef^^a4{\missingcharmsg{CURRENCY SIGN}} \gdef^^a5{\v L} \gdef^^a6{\'S} \gdef^^a7{\S} \gdef^^a8{\"{}} \gdef^^a9{\v S} \gdef^^aa{\cedilla S} \gdef^^ab{\v T} \gdef^^ac{\'Z} \gdef^^ad{\-} \gdef^^ae{\v Z} \gdef^^af{\dotaccent Z} % \gdef^^b0{\textdegree} \gdef^^b1{\missingcharmsg{LATIN SMALL LETTER A WITH OGONEK}} \gdef^^b2{\missingcharmsg{OGONEK}} \gdef^^b3{\l} \gdef^^b4{\'{}} \gdef^^b5{\v l} \gdef^^b6{\'s} \gdef^^b7{\v{}} \gdef^^b8{\cedilla\ } \gdef^^b9{\v s} \gdef^^ba{\cedilla s} \gdef^^bb{\v t} \gdef^^bc{\'z} \gdef^^bd{\H{}} \gdef^^be{\v z} \gdef^^bf{\dotaccent z} % \gdef^^c0{\'R} \gdef^^c1{\'A} \gdef^^c2{\^A} \gdef^^c3{\u A} \gdef^^c4{\"A} \gdef^^c5{\'L} \gdef^^c6{\'C} \gdef^^c7{\cedilla C} \gdef^^c8{\v C} \gdef^^c9{\'E} \gdef^^ca{\missingcharmsg{LATIN CAPITAL LETTER E WITH OGONEK}} \gdef^^cb{\"E} \gdef^^cc{\v E} \gdef^^cd{\'I} \gdef^^ce{\^I} \gdef^^cf{\v D} % \gdef^^d0{\missingcharmsg{LATIN CAPITAL LETTER D WITH STROKE}} \gdef^^d1{\'N} \gdef^^d2{\v N} \gdef^^d3{\'O} \gdef^^d4{\^O} \gdef^^d5{\H O} \gdef^^d6{\"O} \gdef^^d7{$\times$} \gdef^^d8{\v R} \gdef^^d9{\ringaccent U} \gdef^^da{\'U} \gdef^^db{\H U} \gdef^^dc{\"U} \gdef^^dd{\'Y} \gdef^^de{\cedilla T} \gdef^^df{\ss} % \gdef^^e0{\'r} \gdef^^e1{\'a} \gdef^^e2{\^a} \gdef^^e3{\u a} \gdef^^e4{\"a} \gdef^^e5{\'l} \gdef^^e6{\'c} \gdef^^e7{\cedilla c} \gdef^^e8{\v c} \gdef^^e9{\'e} \gdef^^ea{\missingcharmsg{LATIN SMALL LETTER E WITH OGONEK}} \gdef^^eb{\"e} \gdef^^ec{\v e} \gdef^^ed{\'\i} \gdef^^ee{\^\i} \gdef^^ef{\v d} % \gdef^^f0{\missingcharmsg{LATIN SMALL LETTER D WITH STROKE}} \gdef^^f1{\'n} \gdef^^f2{\v n} \gdef^^f3{\'o} \gdef^^f4{\^o} \gdef^^f5{\H o} \gdef^^f6{\"o} \gdef^^f7{$\div$} \gdef^^f8{\v r} \gdef^^f9{\ringaccent u} \gdef^^fa{\'u} \gdef^^fb{\H u} \gdef^^fc{\"u} \gdef^^fd{\'y} \gdef^^fe{\cedilla t} \gdef^^ff{\dotaccent{}} } % UTF-8 character definitions. % % This code to support UTF-8 is based on LaTeX's utf8.def, with some % changes for Texinfo conventions. It is included here under the GPL by % permission from Frank Mittelbach and the LaTeX team. % \newcount\countUTFx \newcount\countUTFy \newcount\countUTFz \gdef\UTFviiiTwoOctets#1#2{\expandafter \UTFviiiDefined\csname u8:#1\string #2\endcsname} % \gdef\UTFviiiThreeOctets#1#2#3{\expandafter \UTFviiiDefined\csname u8:#1\string #2\string #3\endcsname} % \gdef\UTFviiiFourOctets#1#2#3#4{\expandafter \UTFviiiDefined\csname u8:#1\string #2\string #3\string #4\endcsname} \gdef\UTFviiiDefined#1{% \ifx #1\relax \message{\linenumber Unicode char \string #1 not defined for Texinfo}% \else \expandafter #1% \fi } \begingroup \catcode`\~13 \catcode`\"12 \def\UTFviiiLoop{% \global\catcode\countUTFx\active \uccode`\~\countUTFx \uppercase\expandafter{\UTFviiiTmp}% \advance\countUTFx by 1 \ifnum\countUTFx < \countUTFy \expandafter\UTFviiiLoop \fi} \countUTFx = "C2 \countUTFy = "E0 \def\UTFviiiTmp{% \xdef~{\noexpand\UTFviiiTwoOctets\string~}} \UTFviiiLoop \countUTFx = "E0 \countUTFy = "F0 \def\UTFviiiTmp{% \xdef~{\noexpand\UTFviiiThreeOctets\string~}} \UTFviiiLoop \countUTFx = "F0 \countUTFy = "F4 \def\UTFviiiTmp{% \xdef~{\noexpand\UTFviiiFourOctets\string~}} \UTFviiiLoop \endgroup \begingroup \catcode`\"=12 \catcode`\<=12 \catcode`\.=12 \catcode`\,=12 \catcode`\;=12 \catcode`\!=12 \catcode`\~=13 \gdef\DeclareUnicodeCharacter#1#2{% \countUTFz = "#1\relax \wlog{\space\space defining Unicode char U+#1 (decimal \the\countUTFz)}% \begingroup \parseXMLCharref \def\UTFviiiTwoOctets##1##2{% \csname u8:##1\string ##2\endcsname}% \def\UTFviiiThreeOctets##1##2##3{% \csname u8:##1\string ##2\string ##3\endcsname}% \def\UTFviiiFourOctets##1##2##3##4{% \csname u8:##1\string ##2\string ##3\string ##4\endcsname}% \expandafter\expandafter\expandafter\expandafter \expandafter\expandafter\expandafter \gdef\UTFviiiTmp{#2}% \endgroup} \gdef\parseXMLCharref{% \ifnum\countUTFz < "A0\relax \errhelp = \EMsimple \errmessage{Cannot define Unicode char value < 00A0}% \else\ifnum\countUTFz < "800\relax \parseUTFviiiA,% \parseUTFviiiB C\UTFviiiTwoOctets.,% \else\ifnum\countUTFz < "10000\relax \parseUTFviiiA;% \parseUTFviiiA,% \parseUTFviiiB E\UTFviiiThreeOctets.{,;}% \else \parseUTFviiiA;% \parseUTFviiiA,% \parseUTFviiiA!% \parseUTFviiiB F\UTFviiiFourOctets.{!,;}% \fi\fi\fi } \gdef\parseUTFviiiA#1{% \countUTFx = \countUTFz \divide\countUTFz by 64 \countUTFy = \countUTFz \multiply\countUTFz by 64 \advance\countUTFx by -\countUTFz \advance\countUTFx by 128 \uccode `#1\countUTFx \countUTFz = \countUTFy} \gdef\parseUTFviiiB#1#2#3#4{% \advance\countUTFz by "#10\relax \uccode `#3\countUTFz \uppercase{\gdef\UTFviiiTmp{#2#3#4}}} \endgroup \def\utfeightchardefs{% \DeclareUnicodeCharacter{00A0}{\tie} \DeclareUnicodeCharacter{00A1}{\exclamdown} \DeclareUnicodeCharacter{00A3}{\pounds} \DeclareUnicodeCharacter{00A8}{\"{ }} \DeclareUnicodeCharacter{00A9}{\copyright} \DeclareUnicodeCharacter{00AA}{\ordf} \DeclareUnicodeCharacter{00AB}{\guillemetleft} \DeclareUnicodeCharacter{00AD}{\-} \DeclareUnicodeCharacter{00AE}{\registeredsymbol} \DeclareUnicodeCharacter{00AF}{\={ }} \DeclareUnicodeCharacter{00B0}{\ringaccent{ }} \DeclareUnicodeCharacter{00B4}{\'{ }} \DeclareUnicodeCharacter{00B8}{\cedilla{ }} \DeclareUnicodeCharacter{00BA}{\ordm} \DeclareUnicodeCharacter{00BB}{\guillemetright} \DeclareUnicodeCharacter{00BF}{\questiondown} \DeclareUnicodeCharacter{00C0}{\`A} \DeclareUnicodeCharacter{00C1}{\'A} \DeclareUnicodeCharacter{00C2}{\^A} \DeclareUnicodeCharacter{00C3}{\~A} \DeclareUnicodeCharacter{00C4}{\"A} \DeclareUnicodeCharacter{00C5}{\AA} \DeclareUnicodeCharacter{00C6}{\AE} \DeclareUnicodeCharacter{00C7}{\cedilla{C}} \DeclareUnicodeCharacter{00C8}{\`E} \DeclareUnicodeCharacter{00C9}{\'E} \DeclareUnicodeCharacter{00CA}{\^E} \DeclareUnicodeCharacter{00CB}{\"E} \DeclareUnicodeCharacter{00CC}{\`I} \DeclareUnicodeCharacter{00CD}{\'I} \DeclareUnicodeCharacter{00CE}{\^I} \DeclareUnicodeCharacter{00CF}{\"I} \DeclareUnicodeCharacter{00D1}{\~N} \DeclareUnicodeCharacter{00D2}{\`O} \DeclareUnicodeCharacter{00D3}{\'O} \DeclareUnicodeCharacter{00D4}{\^O} \DeclareUnicodeCharacter{00D5}{\~O} \DeclareUnicodeCharacter{00D6}{\"O} \DeclareUnicodeCharacter{00D8}{\O} \DeclareUnicodeCharacter{00D9}{\`U} \DeclareUnicodeCharacter{00DA}{\'U} \DeclareUnicodeCharacter{00DB}{\^U} \DeclareUnicodeCharacter{00DC}{\"U} \DeclareUnicodeCharacter{00DD}{\'Y} \DeclareUnicodeCharacter{00DF}{\ss} \DeclareUnicodeCharacter{00E0}{\`a} \DeclareUnicodeCharacter{00E1}{\'a} \DeclareUnicodeCharacter{00E2}{\^a} \DeclareUnicodeCharacter{00E3}{\~a} \DeclareUnicodeCharacter{00E4}{\"a} \DeclareUnicodeCharacter{00E5}{\aa} \DeclareUnicodeCharacter{00E6}{\ae} \DeclareUnicodeCharacter{00E7}{\cedilla{c}} \DeclareUnicodeCharacter{00E8}{\`e} \DeclareUnicodeCharacter{00E9}{\'e} \DeclareUnicodeCharacter{00EA}{\^e} \DeclareUnicodeCharacter{00EB}{\"e} \DeclareUnicodeCharacter{00EC}{\`{\dotless{i}}} \DeclareUnicodeCharacter{00ED}{\'{\dotless{i}}} \DeclareUnicodeCharacter{00EE}{\^{\dotless{i}}} \DeclareUnicodeCharacter{00EF}{\"{\dotless{i}}} \DeclareUnicodeCharacter{00F1}{\~n} \DeclareUnicodeCharacter{00F2}{\`o} \DeclareUnicodeCharacter{00F3}{\'o} \DeclareUnicodeCharacter{00F4}{\^o} \DeclareUnicodeCharacter{00F5}{\~o} \DeclareUnicodeCharacter{00F6}{\"o} \DeclareUnicodeCharacter{00F8}{\o} \DeclareUnicodeCharacter{00F9}{\`u} \DeclareUnicodeCharacter{00FA}{\'u} \DeclareUnicodeCharacter{00FB}{\^u} \DeclareUnicodeCharacter{00FC}{\"u} \DeclareUnicodeCharacter{00FD}{\'y} \DeclareUnicodeCharacter{00FF}{\"y} \DeclareUnicodeCharacter{0100}{\=A} \DeclareUnicodeCharacter{0101}{\=a} \DeclareUnicodeCharacter{0102}{\u{A}} \DeclareUnicodeCharacter{0103}{\u{a}} \DeclareUnicodeCharacter{0106}{\'C} \DeclareUnicodeCharacter{0107}{\'c} \DeclareUnicodeCharacter{0108}{\^C} \DeclareUnicodeCharacter{0109}{\^c} \DeclareUnicodeCharacter{010A}{\dotaccent{C}} \DeclareUnicodeCharacter{010B}{\dotaccent{c}} \DeclareUnicodeCharacter{010C}{\v{C}} \DeclareUnicodeCharacter{010D}{\v{c}} \DeclareUnicodeCharacter{010E}{\v{D}} \DeclareUnicodeCharacter{0112}{\=E} \DeclareUnicodeCharacter{0113}{\=e} \DeclareUnicodeCharacter{0114}{\u{E}} \DeclareUnicodeCharacter{0115}{\u{e}} \DeclareUnicodeCharacter{0116}{\dotaccent{E}} \DeclareUnicodeCharacter{0117}{\dotaccent{e}} \DeclareUnicodeCharacter{011A}{\v{E}} \DeclareUnicodeCharacter{011B}{\v{e}} \DeclareUnicodeCharacter{011C}{\^G} \DeclareUnicodeCharacter{011D}{\^g} \DeclareUnicodeCharacter{011E}{\u{G}} \DeclareUnicodeCharacter{011F}{\u{g}} \DeclareUnicodeCharacter{0120}{\dotaccent{G}} \DeclareUnicodeCharacter{0121}{\dotaccent{g}} \DeclareUnicodeCharacter{0124}{\^H} \DeclareUnicodeCharacter{0125}{\^h} \DeclareUnicodeCharacter{0128}{\~I} \DeclareUnicodeCharacter{0129}{\~{\dotless{i}}} \DeclareUnicodeCharacter{012A}{\=I} \DeclareUnicodeCharacter{012B}{\={\dotless{i}}} \DeclareUnicodeCharacter{012C}{\u{I}} \DeclareUnicodeCharacter{012D}{\u{\dotless{i}}} \DeclareUnicodeCharacter{0130}{\dotaccent{I}} \DeclareUnicodeCharacter{0131}{\dotless{i}} \DeclareUnicodeCharacter{0132}{IJ} \DeclareUnicodeCharacter{0133}{ij} \DeclareUnicodeCharacter{0134}{\^J} \DeclareUnicodeCharacter{0135}{\^{\dotless{j}}} \DeclareUnicodeCharacter{0139}{\'L} \DeclareUnicodeCharacter{013A}{\'l} \DeclareUnicodeCharacter{0141}{\L} \DeclareUnicodeCharacter{0142}{\l} \DeclareUnicodeCharacter{0143}{\'N} \DeclareUnicodeCharacter{0144}{\'n} \DeclareUnicodeCharacter{0147}{\v{N}} \DeclareUnicodeCharacter{0148}{\v{n}} \DeclareUnicodeCharacter{014C}{\=O} \DeclareUnicodeCharacter{014D}{\=o} \DeclareUnicodeCharacter{014E}{\u{O}} \DeclareUnicodeCharacter{014F}{\u{o}} \DeclareUnicodeCharacter{0150}{\H{O}} \DeclareUnicodeCharacter{0151}{\H{o}} \DeclareUnicodeCharacter{0152}{\OE} \DeclareUnicodeCharacter{0153}{\oe} \DeclareUnicodeCharacter{0154}{\'R} \DeclareUnicodeCharacter{0155}{\'r} \DeclareUnicodeCharacter{0158}{\v{R}} \DeclareUnicodeCharacter{0159}{\v{r}} \DeclareUnicodeCharacter{015A}{\'S} \DeclareUnicodeCharacter{015B}{\'s} \DeclareUnicodeCharacter{015C}{\^S} \DeclareUnicodeCharacter{015D}{\^s} \DeclareUnicodeCharacter{015E}{\cedilla{S}} \DeclareUnicodeCharacter{015F}{\cedilla{s}} \DeclareUnicodeCharacter{0160}{\v{S}} \DeclareUnicodeCharacter{0161}{\v{s}} \DeclareUnicodeCharacter{0162}{\cedilla{t}} \DeclareUnicodeCharacter{0163}{\cedilla{T}} \DeclareUnicodeCharacter{0164}{\v{T}} \DeclareUnicodeCharacter{0168}{\~U} \DeclareUnicodeCharacter{0169}{\~u} \DeclareUnicodeCharacter{016A}{\=U} \DeclareUnicodeCharacter{016B}{\=u} \DeclareUnicodeCharacter{016C}{\u{U}} \DeclareUnicodeCharacter{016D}{\u{u}} \DeclareUnicodeCharacter{016E}{\ringaccent{U}} \DeclareUnicodeCharacter{016F}{\ringaccent{u}} \DeclareUnicodeCharacter{0170}{\H{U}} \DeclareUnicodeCharacter{0171}{\H{u}} \DeclareUnicodeCharacter{0174}{\^W} \DeclareUnicodeCharacter{0175}{\^w} \DeclareUnicodeCharacter{0176}{\^Y} \DeclareUnicodeCharacter{0177}{\^y} \DeclareUnicodeCharacter{0178}{\"Y} \DeclareUnicodeCharacter{0179}{\'Z} \DeclareUnicodeCharacter{017A}{\'z} \DeclareUnicodeCharacter{017B}{\dotaccent{Z}} \DeclareUnicodeCharacter{017C}{\dotaccent{z}} \DeclareUnicodeCharacter{017D}{\v{Z}} \DeclareUnicodeCharacter{017E}{\v{z}} \DeclareUnicodeCharacter{01C4}{D\v{Z}} \DeclareUnicodeCharacter{01C5}{D\v{z}} \DeclareUnicodeCharacter{01C6}{d\v{z}} \DeclareUnicodeCharacter{01C7}{LJ} \DeclareUnicodeCharacter{01C8}{Lj} \DeclareUnicodeCharacter{01C9}{lj} \DeclareUnicodeCharacter{01CA}{NJ} \DeclareUnicodeCharacter{01CB}{Nj} \DeclareUnicodeCharacter{01CC}{nj} \DeclareUnicodeCharacter{01CD}{\v{A}} \DeclareUnicodeCharacter{01CE}{\v{a}} \DeclareUnicodeCharacter{01CF}{\v{I}} \DeclareUnicodeCharacter{01D0}{\v{\dotless{i}}} \DeclareUnicodeCharacter{01D1}{\v{O}} \DeclareUnicodeCharacter{01D2}{\v{o}} \DeclareUnicodeCharacter{01D3}{\v{U}} \DeclareUnicodeCharacter{01D4}{\v{u}} \DeclareUnicodeCharacter{01E2}{\={\AE}} \DeclareUnicodeCharacter{01E3}{\={\ae}} \DeclareUnicodeCharacter{01E6}{\v{G}} \DeclareUnicodeCharacter{01E7}{\v{g}} \DeclareUnicodeCharacter{01E8}{\v{K}} \DeclareUnicodeCharacter{01E9}{\v{k}} \DeclareUnicodeCharacter{01F0}{\v{\dotless{j}}} \DeclareUnicodeCharacter{01F1}{DZ} \DeclareUnicodeCharacter{01F2}{Dz} \DeclareUnicodeCharacter{01F3}{dz} \DeclareUnicodeCharacter{01F4}{\'G} \DeclareUnicodeCharacter{01F5}{\'g} \DeclareUnicodeCharacter{01F8}{\`N} \DeclareUnicodeCharacter{01F9}{\`n} \DeclareUnicodeCharacter{01FC}{\'{\AE}} \DeclareUnicodeCharacter{01FD}{\'{\ae}} \DeclareUnicodeCharacter{01FE}{\'{\O}} \DeclareUnicodeCharacter{01FF}{\'{\o}} \DeclareUnicodeCharacter{021E}{\v{H}} \DeclareUnicodeCharacter{021F}{\v{h}} \DeclareUnicodeCharacter{0226}{\dotaccent{A}} \DeclareUnicodeCharacter{0227}{\dotaccent{a}} \DeclareUnicodeCharacter{0228}{\cedilla{E}} \DeclareUnicodeCharacter{0229}{\cedilla{e}} \DeclareUnicodeCharacter{022E}{\dotaccent{O}} \DeclareUnicodeCharacter{022F}{\dotaccent{o}} \DeclareUnicodeCharacter{0232}{\=Y} \DeclareUnicodeCharacter{0233}{\=y} \DeclareUnicodeCharacter{0237}{\dotless{j}} \DeclareUnicodeCharacter{1E02}{\dotaccent{B}} \DeclareUnicodeCharacter{1E03}{\dotaccent{b}} \DeclareUnicodeCharacter{1E04}{\udotaccent{B}} \DeclareUnicodeCharacter{1E05}{\udotaccent{b}} \DeclareUnicodeCharacter{1E06}{\ubaraccent{B}} \DeclareUnicodeCharacter{1E07}{\ubaraccent{b}} \DeclareUnicodeCharacter{1E0A}{\dotaccent{D}} \DeclareUnicodeCharacter{1E0B}{\dotaccent{d}} \DeclareUnicodeCharacter{1E0C}{\udotaccent{D}} \DeclareUnicodeCharacter{1E0D}{\udotaccent{d}} \DeclareUnicodeCharacter{1E0E}{\ubaraccent{D}} \DeclareUnicodeCharacter{1E0F}{\ubaraccent{d}} \DeclareUnicodeCharacter{1E1E}{\dotaccent{F}} \DeclareUnicodeCharacter{1E1F}{\dotaccent{f}} \DeclareUnicodeCharacter{1E20}{\=G} \DeclareUnicodeCharacter{1E21}{\=g} \DeclareUnicodeCharacter{1E22}{\dotaccent{H}} \DeclareUnicodeCharacter{1E23}{\dotaccent{h}} \DeclareUnicodeCharacter{1E24}{\udotaccent{H}} \DeclareUnicodeCharacter{1E25}{\udotaccent{h}} \DeclareUnicodeCharacter{1E26}{\"H} \DeclareUnicodeCharacter{1E27}{\"h} \DeclareUnicodeCharacter{1E30}{\'K} \DeclareUnicodeCharacter{1E31}{\'k} \DeclareUnicodeCharacter{1E32}{\udotaccent{K}} \DeclareUnicodeCharacter{1E33}{\udotaccent{k}} \DeclareUnicodeCharacter{1E34}{\ubaraccent{K}} \DeclareUnicodeCharacter{1E35}{\ubaraccent{k}} \DeclareUnicodeCharacter{1E36}{\udotaccent{L}} \DeclareUnicodeCharacter{1E37}{\udotaccent{l}} \DeclareUnicodeCharacter{1E3A}{\ubaraccent{L}} \DeclareUnicodeCharacter{1E3B}{\ubaraccent{l}} \DeclareUnicodeCharacter{1E3E}{\'M} \DeclareUnicodeCharacter{1E3F}{\'m} \DeclareUnicodeCharacter{1E40}{\dotaccent{M}} \DeclareUnicodeCharacter{1E41}{\dotaccent{m}} \DeclareUnicodeCharacter{1E42}{\udotaccent{M}} \DeclareUnicodeCharacter{1E43}{\udotaccent{m}} \DeclareUnicodeCharacter{1E44}{\dotaccent{N}} \DeclareUnicodeCharacter{1E45}{\dotaccent{n}} \DeclareUnicodeCharacter{1E46}{\udotaccent{N}} \DeclareUnicodeCharacter{1E47}{\udotaccent{n}} \DeclareUnicodeCharacter{1E48}{\ubaraccent{N}} \DeclareUnicodeCharacter{1E49}{\ubaraccent{n}} \DeclareUnicodeCharacter{1E54}{\'P} \DeclareUnicodeCharacter{1E55}{\'p} \DeclareUnicodeCharacter{1E56}{\dotaccent{P}} \DeclareUnicodeCharacter{1E57}{\dotaccent{p}} \DeclareUnicodeCharacter{1E58}{\dotaccent{R}} \DeclareUnicodeCharacter{1E59}{\dotaccent{r}} \DeclareUnicodeCharacter{1E5A}{\udotaccent{R}} \DeclareUnicodeCharacter{1E5B}{\udotaccent{r}} \DeclareUnicodeCharacter{1E5E}{\ubaraccent{R}} \DeclareUnicodeCharacter{1E5F}{\ubaraccent{r}} \DeclareUnicodeCharacter{1E60}{\dotaccent{S}} \DeclareUnicodeCharacter{1E61}{\dotaccent{s}} \DeclareUnicodeCharacter{1E62}{\udotaccent{S}} \DeclareUnicodeCharacter{1E63}{\udotaccent{s}} \DeclareUnicodeCharacter{1E6A}{\dotaccent{T}} \DeclareUnicodeCharacter{1E6B}{\dotaccent{t}} \DeclareUnicodeCharacter{1E6C}{\udotaccent{T}} \DeclareUnicodeCharacter{1E6D}{\udotaccent{t}} \DeclareUnicodeCharacter{1E6E}{\ubaraccent{T}} \DeclareUnicodeCharacter{1E6F}{\ubaraccent{t}} \DeclareUnicodeCharacter{1E7C}{\~V} \DeclareUnicodeCharacter{1E7D}{\~v} \DeclareUnicodeCharacter{1E7E}{\udotaccent{V}} \DeclareUnicodeCharacter{1E7F}{\udotaccent{v}} \DeclareUnicodeCharacter{1E80}{\`W} \DeclareUnicodeCharacter{1E81}{\`w} \DeclareUnicodeCharacter{1E82}{\'W} \DeclareUnicodeCharacter{1E83}{\'w} \DeclareUnicodeCharacter{1E84}{\"W} \DeclareUnicodeCharacter{1E85}{\"w} \DeclareUnicodeCharacter{1E86}{\dotaccent{W}} \DeclareUnicodeCharacter{1E87}{\dotaccent{w}} \DeclareUnicodeCharacter{1E88}{\udotaccent{W}} \DeclareUnicodeCharacter{1E89}{\udotaccent{w}} \DeclareUnicodeCharacter{1E8A}{\dotaccent{X}} \DeclareUnicodeCharacter{1E8B}{\dotaccent{x}} \DeclareUnicodeCharacter{1E8C}{\"X} \DeclareUnicodeCharacter{1E8D}{\"x} \DeclareUnicodeCharacter{1E8E}{\dotaccent{Y}} \DeclareUnicodeCharacter{1E8F}{\dotaccent{y}} \DeclareUnicodeCharacter{1E90}{\^Z} \DeclareUnicodeCharacter{1E91}{\^z} \DeclareUnicodeCharacter{1E92}{\udotaccent{Z}} \DeclareUnicodeCharacter{1E93}{\udotaccent{z}} \DeclareUnicodeCharacter{1E94}{\ubaraccent{Z}} \DeclareUnicodeCharacter{1E95}{\ubaraccent{z}} \DeclareUnicodeCharacter{1E96}{\ubaraccent{h}} \DeclareUnicodeCharacter{1E97}{\"t} \DeclareUnicodeCharacter{1E98}{\ringaccent{w}} \DeclareUnicodeCharacter{1E99}{\ringaccent{y}} \DeclareUnicodeCharacter{1EA0}{\udotaccent{A}} \DeclareUnicodeCharacter{1EA1}{\udotaccent{a}} \DeclareUnicodeCharacter{1EB8}{\udotaccent{E}} \DeclareUnicodeCharacter{1EB9}{\udotaccent{e}} \DeclareUnicodeCharacter{1EBC}{\~E} \DeclareUnicodeCharacter{1EBD}{\~e} \DeclareUnicodeCharacter{1ECA}{\udotaccent{I}} \DeclareUnicodeCharacter{1ECB}{\udotaccent{i}} \DeclareUnicodeCharacter{1ECC}{\udotaccent{O}} \DeclareUnicodeCharacter{1ECD}{\udotaccent{o}} \DeclareUnicodeCharacter{1EE4}{\udotaccent{U}} \DeclareUnicodeCharacter{1EE5}{\udotaccent{u}} \DeclareUnicodeCharacter{1EF2}{\`Y} \DeclareUnicodeCharacter{1EF3}{\`y} \DeclareUnicodeCharacter{1EF4}{\udotaccent{Y}} \DeclareUnicodeCharacter{1EF8}{\~Y} \DeclareUnicodeCharacter{1EF9}{\~y} \DeclareUnicodeCharacter{2013}{--} \DeclareUnicodeCharacter{2014}{---} \DeclareUnicodeCharacter{2018}{\quoteleft} \DeclareUnicodeCharacter{2019}{\quoteright} \DeclareUnicodeCharacter{201A}{\quotesinglbase} \DeclareUnicodeCharacter{201C}{\quotedblleft} \DeclareUnicodeCharacter{201D}{\quotedblright} \DeclareUnicodeCharacter{201E}{\quotedblbase} \DeclareUnicodeCharacter{2022}{\bullet} \DeclareUnicodeCharacter{2026}{\dots} \DeclareUnicodeCharacter{2039}{\guilsinglleft} \DeclareUnicodeCharacter{203A}{\guilsinglright} \DeclareUnicodeCharacter{20AC}{\euro} \DeclareUnicodeCharacter{2192}{\expansion} \DeclareUnicodeCharacter{21D2}{\result} \DeclareUnicodeCharacter{2212}{\minus} \DeclareUnicodeCharacter{2217}{\point} \DeclareUnicodeCharacter{2261}{\equiv} }% end of \utfeightchardefs % US-ASCII character definitions. \def\asciichardefs{% nothing need be done \relax } % Make non-ASCII characters printable again for compatibility with % existing Texinfo documents that may use them, even without declaring a % document encoding. % \setnonasciicharscatcode \other \message{formatting,} \newdimen\defaultparindent \defaultparindent = 15pt \chapheadingskip = 15pt plus 4pt minus 2pt \secheadingskip = 12pt plus 3pt minus 2pt \subsecheadingskip = 9pt plus 2pt minus 2pt % Prevent underfull vbox error messages. \vbadness = 10000 % Don't be so finicky about underfull hboxes, either. \hbadness = 2000 % Following George Bush, get rid of widows and orphans. \widowpenalty=10000 \clubpenalty=10000 % Use TeX 3.0's \emergencystretch to help line breaking, but if we're % using an old version of TeX, don't do anything. We want the amount of % stretch added to depend on the line length, hence the dependence on % \hsize. We call this whenever the paper size is set. % \def\setemergencystretch{% \ifx\emergencystretch\thisisundefined % Allow us to assign to \emergencystretch anyway. \def\emergencystretch{\dimen0}% \else \emergencystretch = .15\hsize \fi } % Parameters in order: 1) textheight; 2) textwidth; % 3) voffset; 4) hoffset; 5) binding offset; 6) topskip; % 7) physical page height; 8) physical page width. % % We also call \setleading{\textleading}, so the caller should define % \textleading. The caller should also set \parskip. % \def\internalpagesizes#1#2#3#4#5#6#7#8{% \voffset = #3\relax \topskip = #6\relax \splittopskip = \topskip % \vsize = #1\relax \advance\vsize by \topskip \outervsize = \vsize \advance\outervsize by 2\topandbottommargin \pageheight = \vsize % \hsize = #2\relax \outerhsize = \hsize \advance\outerhsize by 0.5in \pagewidth = \hsize % \normaloffset = #4\relax \bindingoffset = #5\relax % \ifpdf \pdfpageheight #7\relax \pdfpagewidth #8\relax % if we don't reset these, they will remain at "1 true in" of % whatever layout pdftex was dumped with. \pdfhorigin = 1 true in \pdfvorigin = 1 true in \fi % \setleading{\textleading} % \parindent = \defaultparindent \setemergencystretch } % @letterpaper (the default). \def\letterpaper{{\globaldefs = 1 \parskip = 3pt plus 2pt minus 1pt \textleading = 13.2pt % % If page is nothing but text, make it come out even. \internalpagesizes{607.2pt}{6in}% that's 46 lines {\voffset}{.25in}% {\bindingoffset}{36pt}% {11in}{8.5in}% }} % Use @smallbook to reset parameters for 7x9.25 trim size. \def\smallbook{{\globaldefs = 1 \parskip = 2pt plus 1pt \textleading = 12pt % \internalpagesizes{7.5in}{5in}% {-.2in}{0in}% {\bindingoffset}{16pt}% {9.25in}{7in}% % \lispnarrowing = 0.3in \tolerance = 700 \hfuzz = 1pt \contentsrightmargin = 0pt \defbodyindent = .5cm }} % Use @smallerbook to reset parameters for 6x9 trim size. % (Just testing, parameters still in flux.) \def\smallerbook{{\globaldefs = 1 \parskip = 1.5pt plus 1pt \textleading = 12pt % \internalpagesizes{7.4in}{4.8in}% {-.2in}{-.4in}% {0pt}{14pt}% {9in}{6in}% % \lispnarrowing = 0.25in \tolerance = 700 \hfuzz = 1pt \contentsrightmargin = 0pt \defbodyindent = .4cm }} % Use @afourpaper to print on European A4 paper. \def\afourpaper{{\globaldefs = 1 \parskip = 3pt plus 2pt minus 1pt \textleading = 13.2pt % % Double-side printing via postscript on Laserjet 4050 % prints double-sided nicely when \bindingoffset=10mm and \hoffset=-6mm. % To change the settings for a different printer or situation, adjust % \normaloffset until the front-side and back-side texts align. Then % do the same for \bindingoffset. You can set these for testing in % your texinfo source file like this: % @tex % \global\normaloffset = -6mm % \global\bindingoffset = 10mm % @end tex \internalpagesizes{673.2pt}{160mm}% that's 51 lines {\voffset}{\hoffset}% {\bindingoffset}{44pt}% {297mm}{210mm}% % \tolerance = 700 \hfuzz = 1pt \contentsrightmargin = 0pt \defbodyindent = 5mm }} % Use @afivepaper to print on European A5 paper. % From romildo@urano.iceb.ufop.br, 2 July 2000. % He also recommends making @example and @lisp be small. \def\afivepaper{{\globaldefs = 1 \parskip = 2pt plus 1pt minus 0.1pt \textleading = 12.5pt % \internalpagesizes{160mm}{120mm}% {\voffset}{\hoffset}% {\bindingoffset}{8pt}% {210mm}{148mm}% % \lispnarrowing = 0.2in \tolerance = 800 \hfuzz = 1.2pt \contentsrightmargin = 0pt \defbodyindent = 2mm \tableindent = 12mm }} % A specific text layout, 24x15cm overall, intended for A4 paper. \def\afourlatex{{\globaldefs = 1 \afourpaper \internalpagesizes{237mm}{150mm}% {\voffset}{4.6mm}% {\bindingoffset}{7mm}% {297mm}{210mm}% % % Must explicitly reset to 0 because we call \afourpaper. \globaldefs = 0 }} % Use @afourwide to print on A4 paper in landscape format. \def\afourwide{{\globaldefs = 1 \afourpaper \internalpagesizes{241mm}{165mm}% {\voffset}{-2.95mm}% {\bindingoffset}{7mm}% {297mm}{210mm}% \globaldefs = 0 }} % @pagesizes TEXTHEIGHT[,TEXTWIDTH] % Perhaps we should allow setting the margins, \topskip, \parskip, % and/or leading, also. Or perhaps we should compute them somehow. % \parseargdef\pagesizes{\pagesizesyyy #1,,\finish} \def\pagesizesyyy#1,#2,#3\finish{{% \setbox0 = \hbox{\ignorespaces #2}\ifdim\wd0 > 0pt \hsize=#2\relax \fi \globaldefs = 1 % \parskip = 3pt plus 2pt minus 1pt \setleading{\textleading}% % \dimen0 = #1\relax \advance\dimen0 by \voffset % \dimen2 = \hsize \advance\dimen2 by \normaloffset % \internalpagesizes{#1}{\hsize}% {\voffset}{\normaloffset}% {\bindingoffset}{44pt}% {\dimen0}{\dimen2}% }} % Set default to letter. % \letterpaper \message{and turning on texinfo input format.} % Define macros to output various characters with catcode for normal text. \catcode`\"=\other \catcode`\~=\other \catcode`\^=\other \catcode`\_=\other \catcode`\|=\other \catcode`\<=\other \catcode`\>=\other \catcode`\+=\other \catcode`\$=\other \def\normaldoublequote{"} \def\normaltilde{~} \def\normalcaret{^} \def\normalunderscore{_} \def\normalverticalbar{|} \def\normalless{<} \def\normalgreater{>} \def\normalplus{+} \def\normaldollar{$}%$ font-lock fix % This macro is used to make a character print one way in \tt % (where it can probably be output as-is), and another way in other fonts, % where something hairier probably needs to be done. % % #1 is what to print if we are indeed using \tt; #2 is what to print % otherwise. Since all the Computer Modern typewriter fonts have zero % interword stretch (and shrink), and it is reasonable to expect all % typewriter fonts to have this, we can check that font parameter. % \def\ifusingtt#1#2{\ifdim \fontdimen3\font=0pt #1\else #2\fi} % Same as above, but check for italic font. Actually this also catches % non-italic slanted fonts since it is impossible to distinguish them from % italic fonts. But since this is only used by $ and it uses \sl anyway % this is not a problem. \def\ifusingit#1#2{\ifdim \fontdimen1\font>0pt #1\else #2\fi} % Turn off all special characters except @ % (and those which the user can use as if they were ordinary). % Most of these we simply print from the \tt font, but for some, we can % use math or other variants that look better in normal text. \catcode`\"=\active \def\activedoublequote{{\tt\char34}} \let"=\activedoublequote \catcode`\~=\active \def~{{\tt\char126}} \chardef\hat=`\^ \catcode`\^=\active \def^{{\tt \hat}} \catcode`\_=\active \def_{\ifusingtt\normalunderscore\_} \let\realunder=_ % Subroutine for the previous macro. \def\_{\leavevmode \kern.07em \vbox{\hrule width.3em height.1ex}\kern .07em } \catcode`\|=\active \def|{{\tt\char124}} \chardef \less=`\< \catcode`\<=\active \def<{{\tt \less}} \chardef \gtr=`\> \catcode`\>=\active \def>{{\tt \gtr}} \catcode`\+=\active \def+{{\tt \char 43}} \catcode`\$=\active \def${\ifusingit{{\sl\$}}\normaldollar}%$ font-lock fix % If a .fmt file is being used, characters that might appear in a file % name cannot be active until we have parsed the command line. % So turn them off again, and have \everyjob (or @setfilename) turn them on. % \otherifyactive is called near the end of this file. \def\otherifyactive{\catcode`+=\other \catcode`\_=\other} % Used sometimes to turn off (effectively) the active characters even after % parsing them. \def\turnoffactive{% \normalturnoffactive \otherbackslash } \catcode`\@=0 % \backslashcurfont outputs one backslash character in current font, % as in \char`\\. \global\chardef\backslashcurfont=`\\ \global\let\rawbackslashxx=\backslashcurfont % let existing .??s files work % \realbackslash is an actual character `\' with catcode other, and % \doublebackslash is two of them (for the pdf outlines). {\catcode`\\=\other @gdef@realbackslash{\} @gdef@doublebackslash{\\}} % In texinfo, backslash is an active character; it prints the backslash % in fixed width font. \catcode`\\=\active @def@normalbackslash{{@tt@backslashcurfont}} % On startup, @fixbackslash assigns: % @let \ = @normalbackslash % \rawbackslash defines an active \ to do \backslashcurfont. % \otherbackslash defines an active \ to be a literal `\' character with % catcode other. @gdef@rawbackslash{@let\=@backslashcurfont} @gdef@otherbackslash{@let\=@realbackslash} % Same as @turnoffactive except outputs \ as {\tt\char`\\} instead of % the literal character `\'. % @def@normalturnoffactive{% @let\=@normalbackslash @let"=@normaldoublequote @let~=@normaltilde @let^=@normalcaret @let_=@normalunderscore @let|=@normalverticalbar @let<=@normalless @let>=@normalgreater @let+=@normalplus @let$=@normaldollar %$ font-lock fix @unsepspaces } % Make _ and + \other characters, temporarily. % This is canceled by @fixbackslash. @otherifyactive % If a .fmt file is being used, we don't want the `\input texinfo' to show up. % That is what \eatinput is for; after that, the `\' should revert to printing % a backslash. % @gdef@eatinput input texinfo{@fixbackslash} @global@let\ = @eatinput % On the other hand, perhaps the file did not have a `\input texinfo'. Then % the first `\' in the file would cause an error. This macro tries to fix % that, assuming it is called before the first `\' could plausibly occur. % Also turn back on active characters that might appear in the input % file name, in case not using a pre-dumped format. % @gdef@fixbackslash{% @ifx\@eatinput @let\ = @normalbackslash @fi @catcode`+=@active @catcode`@_=@active } % Say @foo, not \foo, in error messages. @escapechar = `@@ % These look ok in all fonts, so just make them not special. @catcode`@& = @other @catcode`@# = @other @catcode`@% = @other @c Local variables: @c eval: (add-hook 'write-file-hooks 'time-stamp) @c page-delimiter: "^\\\\message" @c time-stamp-start: "def\\\\texinfoversion{" @c time-stamp-format: "%:y-%02m-%02d.%02H" @c time-stamp-end: "}" @c End: @c vim:sw=2: @ignore arch-tag: e1b36e32-c96e-4135-a41a-0b2efa2ea115 @end ignore getdp-2.4.2-source/doc/texinfo/Strip.pdf000644 001750 001750 00000004671 11266605602 021631 0ustar00geuzainegeuzaine000000 000000 %PDF-1.1 %쏢 4 0 obj << /Length 5 0 R >> stream q 1 i 0.472425 w 61.2255 23.0397 m 174.607 23.0397 l S 174.922 170.499 m 208.937 170.499 l S 61.5404 170.499 m 174.922 170.499 l S 208.685 22.9767 m 208.685 136.359 l S 208.685 136.359 m 208.685 170.373 l S 61.2255 23.0397 m 61.2255 136.422 l S 61.2255 136.422 m 61.2255 170.436 l S 27.2109 86.5336 m 58.9578 61.5896 l S 53.7927 67.5737 m 57.572 62.6604 l 51.903 65.18 l S Q q W 0 0 210 16.3 re 0 16.3 210 0.1 re 0 16.4 210 3.1 re 0 19.5 210 0.1 re 0 19.6 210 0.7 re 0 20.3 210 0.1 re 0 20.4 210 2.1 re 0 22.5 210 0.1 re 0 22.6 210 149.4 re n 1 i 0.472425 w 145.128 2.63096 m 126.987 20.7721 l S Q q 1 i 0.472425 w 131.396 14.2211 m 128.184 19.5753 l 133.538 16.3628 l S 208.559 39.921 m 95.1771 39.921 l S 174.607 23.0397 m 208.622 23.0397 l S 101.224 66.5658 m 87.6183 43.8894 l S 92.9094 49.7475 m 88.4371 45.4012 l 90.3269 51.3222 l S endstream endobj 5 0 obj 839 endobj 6 0 obj << /Type /Font /Name /R6 /Subtype /Type1 /BaseFont /Courier >> endobj 7 0 obj << /Length 8 0 R >> stream BT /R6 9.4485 Tf 1 0 0 1 128.184 103.793 Tm (Air) Tj ET 174.041 131.634 m 205.788 106.69 l S 200.622 112.675 m 204.402 107.761 l 198.733 110.281 l S Q q W 0 0 210 162.4 re 0 162.4 210 0.1 re 0 162.5 210 4.4 re 0 166.9 210 0.1 re 0 167 210 1.4 re 0 168.4 210 0.1 re 0 168.5 210 1.4 re 0 169.9 210 0.1 re 0 170 210 2 re n 1 i 0.472425 w 160.057 145.681 m 146.451 168.358 l S Q q 1 i 0.472425 w 149.159 160.925 m 147.27 166.909 l 151.742 162.5 l S 95.1141 39.921 m 61.3514 39.921 l S 95.0511 39.984 m 95.0511 42.6926 l S 95.0511 42.5666 m 61.2255 42.5666 l S BT /R6 9.4485 Tf 1 0 0 1 -0.000829688 91.0689 Tm (Surf_dn0) Tj 1 0 0 1 147.396 0.363345 Tm (Ground) Tj 1 0 0 1 144.624 28.5828 Tm (Diel1) Tj 1 0 0 1 103.807 69.7153 Tm (Line) Tj 1 0 0 1 125.475 134.595 Tm (Surf_Inf) Tj ET Q endstream endobj 8 0 obj 780 endobj 3 0 obj << /Type /Page /MediaBox [0 0 210 172] /Parent 2 0 R /Resources << /ProcSet [/PDF /Text] /Font << /R6 6 0 R >> >> /Contents [ 4 0 R 7 0 R ] >> endobj 2 0 obj << /Type /Pages /Kids [ 3 0 R ] /Count 1 >> endobj 1 0 obj << /Type /Catalog /Pages 2 0 R >> endobj 9 0 obj << /CreationDate (D:19990722085003) /Producer (Aladdin Ghostscript 5.03) >> endobj xref 0 10 0000000000 65535 f 0000002071 00000 n 0000002012 00000 n 0000001854 00000 n 0000000015 00000 n 0000000906 00000 n 0000000925 00000 n 0000001003 00000 n 0000001835 00000 n 0000002120 00000 n trailer << /Size 10 /Root 1 0 R /Info 9 0 R >> startxref 2211 %%EOF getdp-2.4.2-source/doc/texinfo/MagDyn_av_2D.pro000644 001750 001750 00000014152 11266605602 022744 0ustar00geuzainegeuzaine000000 000000 /* ------------------------------------------------------------------- File "MagDyn_av_2D.pro" Magnetodynamics - Magnetic vector potential and electric scalar potential a-v formulation (2D) ------------------------------------------------------------------- I N P U T --------- GlobalGroup : (Extension '_Mag' is for Magnetic problem) ----------- Domain_Mag Whole magnetic domain DomainCC_Mag Nonconducting regions (not used) DomainC_Mag Conducting regions DomainS_Mag Inductor regions (Source) DomainV_Mag All regions in movement (for speed term) Function : -------- nu[] Magnetic reluctivity sigma[] Electric conductivity Velocity[] Velocity of regions Constraint : ---------- MagneticVectorPotential_2D Fixed magnetic vector potential (2D) (classical boundary condition) SourceCurrentDensityZ Fixed source current density (in Z direction) Voltage_2D Fixed voltage Current_2D Fixed Current Parameters : ---------- Freq Frequency (Hz) Parameters for time loop with theta scheme : Mag_Time0, Mag_TimeMax, Mag_DTime Initial time, Maximum time, Time step (s) Mag_Theta Theta (e.g. 1. : Implicit Euler, 0.5 : Cranck Nicholson) */ Group { DefineGroup[ Domain_Mag, DomainCC_Mag, DomainC_Mag, DomainS_Mag, DomainV_Mag ]; } Function { DefineFunction[ nu, sigma ]; DefineFunction[ Velocity ]; DefineVariable[ Freq ]; DefineVariable[ Mag_Time0, Mag_TimeMax, Mag_DTime, Mag_Theta ]; } FunctionSpace { // Magnetic vector potential a (b = curl a) { Name Hcurl_a_Mag_2D; Type Form1P; BasisFunction { // a = a s // e e { Name se; NameOfCoef ae; Function BF_PerpendicularEdge; Support Domain_Mag; Entity NodesOf[ All ]; } } Constraint { { NameOfCoef ae; EntityType NodesOf; NameOfConstraint MagneticVectorPotential_2D; } } } // Gradient of Electric scalar potential (2D) { Name Hregion_u_Mag_2D; Type Form1P; BasisFunction { { Name sr; NameOfCoef ur; Function BF_RegionZ; Support DomainC_Mag; Entity DomainC_Mag; } } GlobalQuantity { { Name U; Type AliasOf ; NameOfCoef ur; } { Name I; Type AssociatedWith; NameOfCoef ur; } } Constraint { { NameOfCoef U; EntityType Region; NameOfConstraint Voltage_2D; } { NameOfCoef I; EntityType Region; NameOfConstraint Current_2D; } } } // Source current density js (fully fixed space) { Name Hregion_j_Mag_2D; Type Vector; BasisFunction { { Name sr; NameOfCoef jsr; Function BF_RegionZ; Support DomainS_Mag; Entity DomainS_Mag; } } Constraint { { NameOfCoef jsr; EntityType Region; NameOfConstraint SourceCurrentDensityZ; } } } } Formulation { { Name Magnetodynamics_av_2D; Type FemEquation; Quantity { { Name a ; Type Local ; NameOfSpace Hcurl_a_Mag_2D; } { Name ur; Type Local ; NameOfSpace Hregion_u_Mag_2D; } { Name I ; Type Global; NameOfSpace Hregion_u_Mag_2D [I]; } { Name U ; Type Global; NameOfSpace Hregion_u_Mag_2D [U]; } { Name js; Type Local ; NameOfSpace Hregion_j_Mag_2D; } } Equation { Galerkin { [ nu[] * Dof{d a} , {d a} ]; In Domain_Mag; Jacobian Vol; Integration CurlCurl; } Galerkin { DtDof [ sigma[] * Dof{a} , {a} ]; In DomainC_Mag; Jacobian Vol; Integration CurlCurl; } Galerkin { [ sigma[] * Dof{ur} , {a} ]; In DomainC_Mag; Jacobian Vol; Integration CurlCurl; } Galerkin { [ - sigma[] * (Velocity[] *^ Dof{d a}) , {a} ]; In DomainV_Mag; Jacobian Vol; Integration CurlCurl; } Galerkin { [ - Dof{js} , {a} ]; In DomainS_Mag; Jacobian Vol; Integration CurlCurl; } Galerkin { DtDof [ sigma[] * Dof{a} , {ur} ]; In DomainC_Mag; Jacobian Vol; Integration CurlCurl; } Galerkin { [ sigma[] * Dof{ur} , {ur} ]; In DomainC_Mag; Jacobian Vol; Integration CurlCurl; } GlobalTerm { [ Dof{I} , {U} ]; In DomainC_Mag; } } } } Resolution { { Name MagDyn_av_2D; System { { Name Sys_Mag; NameOfFormulation Magnetodynamics_av_2D; Type ComplexValue; Frequency Freq; } } Operation { Generate[Sys_Mag]; Solve[Sys_Mag]; SaveSolution[Sys_Mag]; } } { Name MagDyn_t_av_2D; System { { Name Sys_Mag; NameOfFormulation Magnetodynamics_av_2D; } } Operation { InitSolution[Sys_Mag]; SaveSolution[Sys_Mag]; TimeLoopTheta[Mag_Time0, Mag_TimeMax, Mag_DTime, Mag_Theta] { Generate[Sys_Mag]; Solve[Sys_Mag]; SaveSolution[Sys_Mag]; } } } } PostProcessing { { Name MagDyn_av_2D; NameOfFormulation Magnetodynamics_av_2D; Quantity { { Name a; Value { Local { [ {a} ]; In Domain_Mag; Jacobian Vol; } } } { Name az; Value { Local { [ CompZ[{a}] ]; In Domain_Mag; Jacobian Vol; } } } { Name b; Value { Local { [ {d a} ]; In Domain_Mag; Jacobian Vol; } } } { Name h; Value { Local { [ nu[] * {d a} ]; In Domain_Mag; Jacobian Vol; } } } { Name j; Value { Local { [ - sigma[]*(Dt[{a}]+{ur}) ]; In DomainC_Mag; Jacobian Vol; } } } { Name jz; Value { Local { [ - sigma[]*CompZ[Dt[{a}]+{ur}] ]; In DomainC_Mag; Jacobian Vol; } } } { Name roj2; Value { Local { [ sigma[]*SquNorm[Dt[{a}]+{ur}] ]; In DomainC_Mag; Jacobian Vol; } } } { Name U; Value { Local { [ {U} ]; In DomainC_Mag; } } } { Name I; Value { Local { [ {I} ]; In DomainC_Mag; } } } } } } getdp-2.4.2-source/doc/texinfo/Core.pdf000644 001750 001750 00000004030 11266605602 021405 0ustar00geuzainegeuzaine000000 000000 %PDF-1.1 %쏢 4 0 obj << /Length 5 0 R >> stream q 1 i 0.472425 w 175.285 23.4382 m 175.285 86.033 124.542 136.776 61.9468 136.776 c S 175.285 23.3941 m 209.299 23.3941 l S 61.9027 23.3941 m 61.9027 136.776 l S 61.9027 136.776 m 61.9027 170.791 l S 61.9027 23.3941 m 175.285 23.3941 l S 61.9027 68.7469 m 84.5791 68.7469 l 84.5791 23.3941 l S 95.9173 23.3941 11.3382 22.6764 re S 179.82 152.65 m 166.214 129.973 l S 171.505 135.831 m 167.033 131.485 l 168.923 137.406 l S 209.299 23.5127 m 209.157 104.793 143.302 170.649 62.0219 170.791 c S 27.8881 86.8881 m 59.635 61.944 l S 54.4698 67.9281 m 58.2492 63.0149 l 52.5802 65.5344 l S endstream endobj 5 0 obj 585 endobj 6 0 obj << /Type /Font /Name /R6 /Subtype /Type1 /BaseFont /Courier >> endobj 7 0 obj << /Length 8 0 R >> stream BT /R6 9.4485 Tf 1 0 0 1 86.8467 143.579 Tm (AirInf) Tj ET Q q W 0 0 217 16.7 re 0 16.7 217 0.1 re 0 16.8 217 3.1 re 0 19.9 217 0.1 re 0 20 217 0.7 re 0 20.7 217 0.1 re 0 20.8 217 2 re 0 22.8 217 0.1 re 0 22.9 217 149.1 re n 1 i 0.472425 w 145.805 2.98538 m 127.664 21.1265 l S Q q 1 i 0.472425 w 132.074 14.5755 m 128.861 19.9297 l 134.215 16.7172 l S BT /R6 9.4485 Tf 1 0 0 1 157.144 154.917 Tm (SurfaceGInf) Tj 0 1 -1 0 75.5085 34.7324 Tm (Core) Tj 0 1 -1 0 104.988 25.6618 Tm (Ind) Tj 1 0 0 1 0.676392 91.4233 Tm (SurfaceGe0) Tj 1 0 0 1 148.073 0.717734 Tm (SurfaceGh0) Tj 1 0 0 1 102.72 80.0852 Tm (Air) Tj ET Q endstream endobj 8 0 obj 617 endobj 3 0 obj << /Type /Page /MediaBox [0 0 217 172] /Parent 2 0 R /Resources << /ProcSet [/PDF /Text] /Font << /R6 6 0 R >> >> /Contents [ 4 0 R 7 0 R ] >> endobj 2 0 obj << /Type /Pages /Kids [ 3 0 R ] /Count 1 >> endobj 1 0 obj << /Type /Catalog /Pages 2 0 R >> endobj 9 0 obj << /CreationDate (D:19990720175515) /Producer (Aladdin Ghostscript 5.03) >> endobj xref 0 10 0000000000 65535 f 0000001654 00000 n 0000001595 00000 n 0000001437 00000 n 0000000015 00000 n 0000000652 00000 n 0000000671 00000 n 0000000749 00000 n 0000001418 00000 n 0000001703 00000 n trailer << /Size 10 /Root 1 0 R /Info 9 0 R >> startxref 1794 %%EOF getdp-2.4.2-source/doc/texinfo/Strip.fig000644 001750 001750 00000003176 11266605602 021624 0ustar00geuzainegeuzaine000000 000000 #FIG 3.2 Landscape Center Metric Letter 100.00 Single -2 1200 2 6 1353 3873 3693 3873 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 2 3153 3873 3693 3873 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 2 1353 3873 3153 3873 -6 6 1358 1532 3698 1532 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 2 3158 1532 3698 1532 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 2 1358 1532 3158 1532 -6 6 3694 1534 3694 3874 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 2 3694 3874 3694 2074 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 2 3694 2074 3694 1534 -6 6 1353 1533 1353 3873 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 2 1353 3873 1353 2073 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 2 1353 2073 1353 1533 -6 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2 0 0 1.00 48.00 96.00 813 2865 1317 3261 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2 0 0 1.00 48.00 96.00 2685 4197 2397 3909 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 2 3692 3605 1892 3605 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2 0 0 1.00 48.00 96.00 1988 3182 1772 3542 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2 0 0 1.00 48.00 96.00 3144 2149 3648 2545 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2 0 0 1.00 48.00 96.00 2922 1926 2706 1566 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 2 1891 3605 1355 3605 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 2 1890 3604 1890 3561 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 2 1890 3563 1353 3563 4 0 0 100 0 12 10 0.0000 4 135 720 381 2793 Surf_dn0\001 4 0 0 100 0 12 10 0.0000 4 105 540 2721 4233 Ground\001 4 0 0 100 0 12 10 0.0000 4 105 450 2677 3785 Diel1\001 4 0 0 100 0 12 10 0.0000 4 105 360 2029 3132 Line\001 4 0 0 100 0 12 10 0.0000 4 135 720 2373 2102 Surf_Inf\001 4 0 0 100 0 12 10 0.0000 4 105 270 2416 2591 Air\001 getdp-2.4.2-source/doc/texinfo/Strip.txt000644 001750 001750 00000001364 11266605602 021673 0ustar00geuzainegeuzaine000000 000000 SurfInf / / +------------------------------------+ / | | / | Air |/ | | | Line | | / / / | 2D elements in: +-------/---+ / | Air, Diel1 / |- | +-----------+------------------------+ 1D elements in: | Diel1 | Line, Ground, SurfInf | | +------------------------------------+ \ Ground getdp-2.4.2-source/doc/texinfo/Core.txt000644 001750 001750 00000001541 11266605602 021457 0ustar00geuzainegeuzaine000000 000000 SurfaceGInf ______ / | -----____/ | \___ |____ AirInf \__ S | ------_ \ u | \ \ r | Air \ \ f | \ \ a | \ | c | | | e +------+ | | G | | | | e | Core | +---+ | | 0 | | |Ind| | | | | | | | | +------+---+---+---------+------+ \ SurfaceGh0 2D elements in: Air, AirInf, Core, Ind 1D elements in: SurfaceGh0, SurfaceGe0, SurfaceGInf (AirInf is a spherical shell corresponding to an infinite region) getdp-2.4.2-source/doc/texinfo/Jacobian_Lib.pro000644 001750 001750 00000001344 11266605602 023045 0ustar00geuzainegeuzaine000000 000000 /* ------------------------------------------------------------------- File "Jacobian_Lib.pro" Definition of a jacobian method ------------------------------------------------------------------- I N P U T --------- GlobalGroup : ----------- DomainInf Regions with Spherical Shell Transformation Parameters : ---------- Val_Rint, Val_Rext Inner and outer radius of the Spherical Shell of DomainInf */ Group { DefineGroup[ DomainInf ] ; DefineVariable[ Val_Rint, Val_Rext ] ; } Jacobian { { Name Vol ; Case { { Region DomainInf ; Jacobian VolSphShell {Val_Rint, Val_Rext} ; } { Region All ; Jacobian Vol ; } } } } getdp-2.4.2-source/doc/texinfo/objects-wrap.tex000644 001750 001750 00000000501 11266605602 023143 0ustar00geuzainegeuzaine000000 000000 % dvips -E objects-wrap -o objects-wrap.eps \documentclass[12pt]{article} \RequirePackage[latin1]{inputenc} \usepackage{graphicx, color} \newcommand{\code}[1]{\upshape\texttt{#1}} \newcommand{\var}[1]{{\normalfont\itshape#1}} \pagestyle{empty} \thispagestyle{empty} \begin{document} \input{getdp.tex} \end{document} getdp-2.4.2-source/doc/texinfo/cmake_options.texi000644 001750 001750 00000002607 12205340471 023552 0ustar00geuzainegeuzaine000000 000000 @item ENABLE_ARPACK Enable Arpack eigensolver (requires Fortran) (default: ON) @item ENABLE_BLAS_LAPACK Enable BLAS/Lapack for linear algebra (e.g. for Arpack) (default: ON) @item ENABLE_BUILD_LIB Enable 'lib' target for building static GetDP library (default: OFF) @item ENABLE_BUILD_SHARED Enable 'shared' target for building shared GetDP library (default: OFF) @item ENABLE_BUILD_ANDROID Enable Android NDK library target (experimental) (default: OFF) @item ENABLE_FORTRAN Enable Fortran (needed for Arpack/Sparskit/Zitsol & Bessel) (default: ON) @item ENABLE_GMSH Enable Gmsh functions (for field interpolation) (default: ON) @item ENABLE_GSL Enable GSL functions (for some built-in functions) (default: ON) @item ENABLE_LEGACY Use legacy assembler (required for actual computations) (default: ON) @item ENABLE_MPI Enable MPI parallelization (with PETSc/SLEPc) (default: OFF) @item ENABLE_NR Enable NR functions (if GSL is unavailable) (default: ON) @item ENABLE_NX Enable proprietary NX extension (default: OFF) @item ENABLE_OPENMP Enable OpenMP parallelization of some functions (experimental) (default: OFF) @item ENABLE_PETSC Enable PETSc linear solver (default: ON) @item ENABLE_SLEPC Enable SLEPc eigensolver (default: ON) @item ENABLE_SPARSKIT Enable Sparskit solver instead of PETSc (requires Fortran) (default: ON) @item ENABLE_ZITSOL Enable Zitsol solvers (requires PETSc and Fortran) (default: OFF) getdp-2.4.2-source/doc/texinfo/objects.fig000644 001750 001750 00000010004 11266605602 022140 0ustar00geuzainegeuzaine000000 000000 #FIG 3.2 Landscape Center Inches Letter 100.00 Single -2 1200 2 0 32 #ffffae 2 2 0 1 0 7 52 0 20 0.000 0 0 -1 0 0 5 450 3975 1800 3975 1800 4350 450 4350 450 3975 2 2 0 1 0 7 52 0 20 0.000 0 0 -1 0 0 5 2175 3300 3525 3300 3525 3675 2175 3675 2175 3300 2 2 0 1 0 7 52 0 20 0.000 0 0 -1 0 0 5 2175 3975 3525 3975 3525 4350 2175 4350 2175 3975 2 2 0 1 0 7 52 0 20 0.000 0 0 -1 0 0 5 2175 4650 3525 4650 3525 5025 2175 5025 2175 4650 2 2 0 1 0 7 52 0 20 0.000 0 0 -1 0 0 5 2175 6000 3525 6000 3525 6375 2175 6375 2175 6000 2 2 0 1 0 7 52 0 20 0.000 0 0 -1 0 0 5 3900 4650 5250 4650 5250 5025 3900 5025 3900 4650 2 2 0 1 0 7 52 0 20 0.000 0 0 -1 0 0 5 3900 5325 5250 5325 5250 5700 3900 5700 3900 5325 2 2 0 1 0 7 52 0 20 0.000 0 0 -1 0 0 5 5625 4650 6975 4650 6975 5025 5625 5025 5625 4650 2 2 0 1 0 7 52 0 20 0.000 0 0 -1 0 0 5 7350 3975 8700 3975 8700 4350 7350 4350 7350 3975 2 2 0 1 0 7 52 0 20 0.000 0 0 -1 0 0 5 7350 4650 8700 4650 8700 5025 7350 5025 7350 4650 2 2 0 0 0 7 54 0 45 0.000 0 0 -1 0 0 5 300 7350 8850 7350 8850 4500 300 4500 300 7350 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 4 0 0 1.00 75.00 105.00 1200 4350 1725 5175 3000 5400 3900 4950 0.000 -1.000 -1.000 0.000 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 3 0 0 1.00 75.00 105.00 3450 6000 3750 5400 3975 5025 0.000 -1.000 0.000 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 2 0 0 1.00 75.00 105.00 4575 5325 4575 5025 0.000 0.000 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 3 0 0 1.00 75.00 105.00 1200 3975 1500 3675 2175 3525 0.000 -1.000 0.000 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 3 0 0 1.00 75.00 105.00 3527 3582 4200 3900 4650 4650 0.000 -1.000 0.000 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 3 0 0 1.00 75.00 105.00 3527 3469 5325 3900 6300 4650 0.000 -1.000 0.000 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 3 0 0 1.00 75.00 105.00 3521 3366 6136 3830 7350 4650 0.000 -1.000 0.000 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 4 0 0 1.00 75.00 105.00 1050 3975 2700 2700 6300 2700 8025 3975 0.000 -1.000 -1.000 0.000 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 2 0 0 1.00 75.00 105.00 2850 3675 2850 3975 0.000 0.000 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 2 0 0 1.00 75.00 105.00 2850 4350 2850 4650 0.000 0.000 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 3 0 0 1.00 75.00 105.00 5252 5509 7081 5488 7950 5025 0.000 -1.000 0.000 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 2 0 0 1.00 75.00 105.00 1800 4159 2175 4159 0.000 0.000 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 4 0 0 1.00 75.00 105.00 900 4350 2250 6825 6450 6900 8250 5025 0.000 -1.000 -1.000 0.000 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 3 0 0 1.00 75.00 105.00 1050 4350 1383 5544 2174 6195 0.000 -1.000 0.000 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 3 0 0 1.00 75.00 105.00 3530 6195 6723 5964 8100 5025 0.000 -1.000 0.000 3 2 0 1 0 6 50 0 -1 0.000 0 1 0 4 0 0 1.00 75.00 105.00 5250 4950 6015 5311 7094 5318 7800 5025 0.000 -1.000 -1.000 0.000 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 3 0 0 1.00 75.00 105.00 3524 4155 4125 4275 4500 4650 0.000 -1.000 0.000 3 2 0 5 0 7 50 0 -1 0.000 0 1 0 3 0 0 3.00 180.00 180.00 1350 4350 1672 4732 2183 4849 0.000 -1.000 0.000 3 2 0 5 0 7 50 0 -1 0.000 0 1 0 2 0 0 3.00 180.00 180.00 3530 4840 3905 4840 0.000 0.000 3 2 0 5 0 7 50 0 -1 0.000 0 1 0 2 0 0 3.00 180.00 180.00 5260 4840 5635 4840 0.000 0.000 3 2 0 5 0 7 50 0 -1 0.000 0 1 0 2 0 0 3.00 180.00 180.00 6979 4840 7354 4840 0.000 0.000 3 2 0 5 0 7 50 0 -1 0.000 0 1 0 2 0 0 3.00 180.00 180.00 8025 4650 8025 4350 0.000 0.000 4 1 0 50 0 0 10 0.0000 6 135 825 1125 4200 \\code{Group}\001 4 1 0 50 0 0 10 0.0000 6 135 990 2850 3525 \\code{Function}\001 4 1 0 50 0 0 10 0.0000 6 135 1110 2850 4200 \\code{Constraint}\001 4 1 0 50 0 0 10 0.0000 6 135 1320 2850 4875 \\code{FunctionSpace}\001 4 1 0 50 0 0 10 0.0000 6 135 945 2850 6225 \\code{Jacobian}\001 4 1 0 50 0 0 10 0.0000 6 135 1140 4575 5550 \\code{Integration}\001 4 1 0 50 0 0 10 0.0000 6 135 1230 4575 4875 \\code{Formulation}\001 4 1 0 50 0 0 10 0.0000 6 135 1125 6300 4875 \\code{Resolution}\001 4 1 0 50 0 0 10 0.0000 6 135 1335 8025 4200 \\code{PostOperation}\001 4 1 0 50 0 0 10 0.0000 6 135 1380 8025 4875 \\code{PostProcessing}\001 getdp-2.4.2-source/doc/texinfo/mStrip.pro000644 001750 001750 00000004035 11266605602 022027 0ustar00geuzainegeuzaine000000 000000 /* ------------------------------------------------------------------- File "mStrip.pro" This file defines the problem dependent data structures for the microstrip problem. To compute the solution: getdp mStrip -solve EleSta_v To compute post-results: getdp mStrip -pos Map or getdp mStrip -pos Cut ------------------------------------------------------------------- */ Group { /* Let's start by defining the interface (i.e. elementary groups) between the mesh file and GetDP (no mesh object is defined, so the default mesh will be assumed to be in GMSH format and located in "mStrip.msh") */ Air = Region[101]; Diel1 = Region[111]; Ground = Region[120]; Line = Region[121]; SurfInf = Region[130]; /* We can then define a global group (used in "EleSta_v.pro", the file containing the function spaces and formulations) */ DomainCC_Ele = Region[{Air, Diel1}]; } Function { /* The relative permittivity (needed in the formulation) is piecewise defined in elementary groups */ epsr[Air] = 1.; epsr[Diel1] = 9.8; } Constraint { /* Now, some Dirichlet conditions are defined. The name 'ElectricScalarPotential' refers to the constraint name given in the function space */ { Name ElectricScalarPotential; Type Assign; Case { { Region Region[{Ground, SurfInf}]; Value 0.; } { Region Line; Value 1.e-3; } } } } /* The formulation used and its tools, considered as being in a black box, can now be included */ Include "Jacobian_Lib.pro" Include "Integration_Lib.pro" Include "EleSta_v.pro" /* Finally, we can define some operations to output results */ e = 1.e-7; PostOperation { { Name Map; NameOfPostProcessing EleSta_v; Operation { Print [ v, OnElementsOf DomainCC_Ele, File "mStrip_v.pos" ]; Print [ e, OnElementsOf DomainCC_Ele, File "mStrip_e.pos" ]; } } { Name Cut; NameOfPostProcessing EleSta_v; Operation { Print [ e, OnLine {{e,e,0}{10.e-3,e,0}} {500}, File "Cut_e" ]; } } } getdp-2.4.2-source/doc/texinfo/Core.fig000644 001750 001750 00000002430 11266605602 021403 0ustar00geuzainegeuzaine000000 000000 #FIG 3.2 Landscape Center Metric Letter 100.00 Single -3 1200 2 6 360 1575 3870 4275 5 1 0 1 0 7 100 0 -1 0.000 0 1 0 0 1329.847 3917.153 3672 3915 2986 2261 1332 1575 5 1 0 1 0 7 100 0 -1 0.000 0 1 0 0 1332.709 3914.291 3132 3915 2605 2642 1332 2115 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 2 3132 3915 3672 3915 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 2 1332 3915 1332 2115 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 2 1332 2115 1332 1575 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 2 1332 3915 3132 3915 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 3 1332 3195 1692 3195 1692 3915 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 0 0 4 1872 3915 1872 3555 2052 3555 2052 3915 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2 0 0 1.00 48.00 96.00 3204 1863 2988 2223 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2 0 0 1.00 48.00 96.00 792 2907 1296 3303 2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2 0 0 1.00 48.00 96.00 2664 4239 2376 3951 4 0 0 100 0 12 10 0.0000 4 105 990 2844 1827 SurfaceGInf\001 4 0 0 100 0 12 10 1.5708 4 90 360 1548 3735 Core\001 4 0 0 100 0 12 10 1.5708 4 105 270 2016 3879 Ind\001 4 0 0 100 0 12 10 0.0000 4 105 900 360 2835 SurfaceGe0\001 4 0 0 100 0 12 10 0.0000 4 105 900 2700 4275 SurfaceGh0\001 4 0 0 100 0 12 10 0.0000 4 105 270 1980 3015 Air\001 4 0 0 100 0 12 10 0.0000 4 105 540 1728 2007 AirInf\001 -6 getdp-2.4.2-source/doc/texinfo/objects-wrap.jpg000644 001750 001750 00000611405 11266605602 023136 0ustar00geuzainegeuzaine000000 000000 JFIFHHExifMM*JR(iZHHc^CC^c }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( ( ( ( ( ( ( ({Yd~ο˷?>k߄N?(6>/eK, g~xotxGZ߇=?R?ỼG| ?oQw*oww߇?]E8~uiF  5-|9TU1?hxA>$hأ;hm/4{ 4|Jׇ+{?cS`Y_Ҟ6J*"b O?\S?`Va7#j~_6?\S?`Va7#j~_6?\S?`Va6x¿-%m ſ?cS`Y_ҞH|#uhm~٦[&)[,ӿ?~-<;g.G~~,8_x'G%[,CY|E >ԼMh5 J xk41fxs¾4c>&7u='Bjγ^Z^ks}}sʠa=gI??jc/O;A_ኾ|{O ? /ONw!ۿ |?Koثc,I ~ؾM5ޡkƿ ö^> "d ߋ?mKO-R׋&RK֟Y_,Gm;K. OPԮ@> ( ( ( (g+ :ׇixY|N|Y_:?|5okךN{ITӵM:{i剀> R2|;Ao ǿ gφ)'Xg|[[|M]w߈Y'vZo#-f[χ^7I@?j#jgmo]mKD3iSF he¿>l?ڏQ'N;N|4~wke gx?1𕆽߇`W?h+oPWK- iLxwo)~˟gON >%|,1R_x+_-=g:g|k?|v?b#'_'~=fwY l_xz|:мYWi|Oi _-㏁4/_>%?|E[/@'5Cú'j|A Bƙi^UzP@P@P@P@P@P@P@P@P@P@P,~_MᏊARd5x~*3Q,>|w/[McOxTƅ~?|=]Gþ7|mxomw`-O('OO/k|@~4\jz|D/?Idw]|߆G{j uG0į3Z칥x;.xso?Pe|Uo(V mC_>ڀtkW#K*> ѼY~4@*ƣmCڧCo|Ai4ψ~%j[<7_iZXP@P@P@P@P@P@P@/6w?gOǯfh~ l~6:>_/ڻ7oto#_ W|=z^;٫Yşhx>%>0~W _ ~ןty|;W ?|Wژ  ;!o˟5O?}͇ ߲/e"ڞgx_)۞~'snϨgK 58mo Ym]^?k?Z1K<.ƚWïğxviwEoZ@> ( ( ( ( ( ( ( ( (>5?/X|<׌|AVԼ?k;_>|[>>Qt8~*j?gO|Tɥ|Ohמxᝏ&Ҽ}x&_Qߌ7~zXv)of٣_Ÿ^^(W_#G|'[^6ù> @H|M %{m ֲEo.oo- kå|z}GEx Wz'? ¾/|5'~Ѽ'xOFӼ9_ WÚu xk=xBl4F-t/NP ( ( ( ( ( ( ( ( (?ӿeVdW-~,.еkĞcW/ƏO;eW"%|?H>_~$xB;K7ǯi?i_1º>I_]/ڷ-{u+ƿ  ( ( ( ( ( ( ( (O~w`~;kf7tVu[/|B|<>^?G|hA|c~CO[|1yP_?Xj)oc?_]۳/5#Z<9?>?wߌ5  |7:xWPw_x~1a_~!jvſk>76/~/|N>&xQX]( ( ( ( ( ( ( ( ( ( ()|'Yߍ >`eI|Ro~ x_ؚƟ-w>,u> twL>i~k^[OɿgᎾ>Wyck_o]3E߇gwOm9:u=|c0A?{º75??cό*ZQtSƿk=~&"SS?#Ƿ?mx/Oȟ|7$N>ߠ ( ( ( ( ( ( ()|R'k~$Kِ\k 5]cƟ G>֟x4?;Ś6? ¾#Ӯtk-4{yy:6iuju͕|A Oi1ϵxJ?~(±C L3?x;Y]7᷋~$x?kU|&|/xƽ_᝟Z|TѾDBm~/| _zw/5_~%^x<( ( ( ( ( ( _A_*!Xx_?ky=|3~Ꚏ{oy_BcƉ? |B>!xc~.yF~S৅~xWPд-C*'Au㟊suj>3|L4+I־$Iִ+Bo4{ A>|?p` (?k-K/ 3? kTGE##?e}9>M7?eWJzXT3WEM7?eWJzXT3WEM7?eWJzXT3WEM7?eWJzXT3WEM7?eWJzXT3WEM7?eWJz<ट_/?gb؃VO/5K/ +^xjXYZM/4 F5NdUӭ[@?W ( ( ( ( ( ( ( (Ş|+o^|ig~1w4m;~g|G\!׉=[^i:&KtmRN4뫛+i&LXXL( ( ( ( ( ⯇O, j%ǶŧkY??|))_4- PI]x?iڧό5M;Ju?u'Jд^i:CށᏇ >c?>x'χ\( (+ Yfd:F⯊5EZ_|3ۼiskZAa[Q.--4G;/~ ]YgC7ĿͪI76?:f!iW Z(9)n.% ybRK,U#4Vww`4ºg/~ ^HHGw _~ ?ah~;|QW,t3_Ŀ&pZBu˩XxG\i,@W?T<Eh ģX??WN )wǯT_?yh L~~ W/& ~ӟy{P@P@P@P@P@P@P@AxGöBoO;/O'Go'׃th/|GO ? ( ( ( ( ()|R'k~$Kِ\k 5]cƟ G>֟x| (?O_oC~T'>)::_@7ÿ/emW.=?O kS<]7WYx>5"~ohC3Q+Zsux; -{ pޯ ᯀ>:5?NΗ|'c ??_Q_گ|;?aoj??j?P_|/?g xWY2kh<9x'|hZ~N>- Ľp>/; n|GG'/<η/ OE.xGzVkxXAdMq i]|cC\3mçX?h/2|u/#Z>-_/V Oŋooz_I񽕷nO~ >~Q '_mK0<ŸxBjGU| Zŏ>N惮DyA>|we>?w7Eoګó~6Nٓ |_x  _r+W_ ׼OW>&G/CR$ Ɵ/h>[;_Zw|cII{Ig/Oboh]JH6Bx~So5}V/3x|yߍ~~>4' x]^#k/?>!x4/Z_i__'J?>&Af^/hZ- Sr|9-?/S4)"ij5C?L>Hx4FnGm7>Ll@X_R0#Y5vúм ;?:<_<#/ڛ |?ݒx7ï _ 햛wD1Wƍ;%~#JWö<9 %_oĶ?5KW?}wc_Z7_P?h?W oпn/W?iMs% 7,O ࠞ /'}~ھNX&S5bw|2 kƿxw>~OW%?dOfMӼ# yO쟸,_'EKEfox▃ONK~=o /o>6N o>k {ŞwmOGO4}rOm?ׇEþ?X}@N?jEfG 7!dI'#?mdWH?l$g2? 17 ߓ Z?_~cԿ _ /LW x¿/{|%7n[? ?k/~6l-3 |R~iۺ't"P c ;_ X'ğ|I6]KZ&qyaBfOL|[ax@-)_~ğ3& ?}'S>xkw/|@{__~5&9t|RCŚH ?  zwS|,|G'<9 ۢL?M|SAYdak~?[?xw@=S ǧ#Ű[WG/N_3(2K?g_?x;X|9/:֢P@P@P@P@P@~|M_xk4Ofx¾,>7k'^^iz΍Z]iڦuse}m= |%gePox߉?Ə:ΣS_oW:o|G7?:Ώ]sRմ?dP@P@P@P@Pvߵ? _o8ݚO_IiU/Od H,,Mwƿ2g$~)xÿ cOjZGjVhjo5=?LoommO]W.|@?ÿwĿh'm][{7Wѿk =~˟!8Ywl3|>|_[~$~@$ZÏثo[g /ͩ>)\~׃ x+kB~)|>kxVVou%?_O_'~ǿljnzNo8M u gJuxO&=~&<;ixR>>,य़`Gj?_K/Ig:Ǡ~r"w_ 3?g >i!О) xw_~M/>St?߇ 5 ࠟ?l)X?Sqhu |?ݒ1Ҵ-w ~$+R|? joV_@~?dF4G{?gF 37xأ/Muok/ ' ¾ׁ|Mx'ƞѼYOYӼG_xWzuxk:=擯x^o-5MY.SNx`<| -^(/wƙvU해|4o ~̞x*i_f7<]%1e/Q6]_ú|5ƛk Q.?_y~߳e/MƧxk:Gmom4]+]~5][x$QuXKAeϋ>o~ x[mOQ%?|E[/@'5Cú'j|A Bƙi^UzP/'ޑ^2xqyت=_Go\xG_k&z~:|YW_j~|1i 1w?0_3>[kɴω~=>xĞ(kGZ߶wm_R?_|?x?_TģOL``_;Sgo_/? lC*} L2^`F 3D>X%?#OMF|duoIH?׿?ٷH@P@P@P@P@?৅h?z/ -$hkW|-xox36 [h?OZpO⯋umՇ/[?4<kCgĭgPWjα/~&xK]/<7sJ?Ɲ ?ß}?@P@P@P@Pƿ|7{u!'B)1;xĹxtk?&~ڇ<0|)?Iү5@S¿|x]|tN>!|IUǎ-Thv1{~'|^U,_5Wׯ>)~ƣwqNh{?xޫ86Ə~"^ x/uZ?Z7M_Q/7="OQ?G/W5?K"Ox>; I ( (>,य़`Gj ( (> gC]^&)xOxYniv _5FĞ!ioXhG>0|wk Ɵߵ *oE\xBL5G7;8[Z|  <%㏈xKD_1;DYowǟ}@P@ |Rco;~/x{zg7wco _?|/7L5?Im.Yu}Wנ d3xjxJo;oݏc úG<υ~Y6_d..4xXSv_a/5a/&ſثW_G h-дzß߷? _1j؇<-¾8)Zx~┟ @>U~?%64|?ؐ|ROαxtK߁#tm_ſ 3~SxwL7O(<,~K??hA oſC&O9G A'&f ?%$ g?#?-'% ^`Y+ 3?DHি _|:?l/E?'şGOO/>|EgOx~'|>xº>E@~ڞ#Q~6g<9 >%>,?1m3Yk_j񏊼?;m[' ¾ׁ|Mx'ƞѼYOYӼG_xWzuxk:=擯x^o-5MY.SNx` ( ( ( (ڇ1⟅?n} W_>~kOŇ'¯oBS{>|:mo^-mP@P@P@P@|ɟ'ƿ'/ػ?_xwƿ?l5h%?Qÿ+=k u>|EѮ4F FkW5_~XxZhoxG-uw + Ws¾tk?'(lt-Cw>X?g:X|]p৅gO~ ;P 鷞1֝|B5|[/Jc/Nt=G)Dž)_ h [j~#/_5x;v?Ş4RG o /|@٢xx5It_ >l/O=#F~_ '?_}Oú>$xv^)|]{P@P@y/ >8][ Q 7ï^ xXEnGŚn_'N}53O|+i/b_2A싦xw|E!E[|M|7|M,KP@P|tg_{H[-bgXD|[߁##/Ox3~/oL-KO7+| c+*]S? >6sL{|;?|#EtOV?o}W7oGem7K| oZ4jzoKĚ߇?Ɓ|'nO >;}k n~&> ( şOكTW%|1?e.|_)G6?noڳl5{|[|@eCh&3Z?/#Ob~?7!]~~ wL,>\}X=֯Y\(ћ+=@,o*o+Sћ+=@,o*o+Sћ+=@.xK 8| 7{كtIa[_0xগo*🊼95~?x_g~\տk]GKu*+U< ,~ߴ";F0I~?_?? #?:WycXT3WEM7?eWJzXT3WEM7?eWJzXT3WE)$~Ŀ?b]'W?mi F<:O]u=bj g?cS`Y_Ҟ77ŕ_)?cS`Y_Ҟ77ŕ_)~8ў:?b [?K/R7*Լ+z׎Ca-c gi7 t+}T4m:QWNyo!_ (>?3c#N%J=;: ς?N7_ $g@۟!6/+J/,m*Ᏺ|mѦh.S|Ig?V6o(W|[6~,|+x|iŞ;~g|G[k7Ci:&Tѵ.N4k+V( (?~]دطg<;ᦹx6[Xk?5/S7񝶝ϋ:ً}2!"Ā/ڟwF~ 1/>~.'o?5oß o|b /Moş| |R)/^(k/xwiu^\GTğ > xw/S'o\3I"욷Wz4Q֠4;Qu,@>35'USK4JmQmY]'VKK;85,/ZErw&! .4x #xJ&/|O[7v~Ѫc$h cIeM;RE[GbIՒN;yd{ E,u ֲ\ɈCs |bYK??lg_P@~|M_xk4Ofx¾,>7k'^^iz΍Z]iڦuse}m= ~,WC,ox+f_z注Q0xCgkYomIOWS/]SOVP@P@P,|+xe/x<k>7;N>|kƹ:!- Ÿ ☼;'9mx~[{%@xO| |0>Ih Y1xW'@B&mo+VҾVχ`COA&<)??4p (>@|,ώߍ?u_Ih٫Ux ᩾|k+^~·շl<O;~?u?n{qd?yGMxַχ i 7W1|d_m}?xWǾ׎ o>4xzΝ? ¾#ӭx^!o4{yihΗyujuյ+tP@K?~'鿱}]go>_hំ }{Ğ,c|IR WKYt{\j:սrnÏŸxou SOu[]_LmGDntkL{Yڞ麮r!ӯtp%Uc^=7E/t_cCX?/ut4:-\ƺd}T"pio燵| |C<+&~ 4& _{FuZRmXm=s0@ھejvi^jZ{m}#tWkioOq,q w/F?2.M<_Ÿڷ+m?znU>u;aKI_@|d'#묿॔PGWw7 Y@@|gn7Ϗ|\5/?/z¯i~ÿ еOڛ;i?߳u6Nů ~3SOæ"xƺς~7b~}rX/luo0PZsZ'/]š=K?y񭖵</\xSֲҤ`G 5}D|>x#S>67ic/o ?i|Gu o>┟&v>,{x'm-j/?ON / h/ K>)>%:k.⮑{㵭ǂs[Oh.iu>5}C c Pkᧇ~0|O]|:fIohj ~,S&Ws]S_&_ͽ-v˨xwY}WLvEűS2(gs|My_#񽯇x{şX*+ :_h&NxWM]m,~񦣡i^ͬZ=u{@>"ӿ?i/+/ 4~YvgĿiռs^ s?~0$n?5GkH<'3&U|-5*? 8wL|_πP/ۣ_ZmskG>"[xiK|DI_^}ߎu^ ,>2 Qo?U W/_O"~]|7>>#Uj>4o %j~:9l'Z~ςI xgIGS)Po~+zkω69e :@czLV 4xW,tSz^i^:Ɓ[f?kYh |=Eg^+Z׭da_x Vm#Qᯆ_}xpcCϟUmI&}bL>~?e?wW_Q{GNH5➝xKqk Q.?_y~߳e/MƧxk:Gmom4]+]~5][x$9Kb`x~%b?OĚơk}O_l_ePv_P;'+3nH8 o_;ߎ/7oA>6N~Ͽ'$w4}G5Gi$㏇i'_KMڟ);#>W5?[|AuMC]?eώ| bQmU ?w(L*OX>ӓ?W/]j>4]J ( (Ş|+o^|ig~1w4m;~g|G\!׉=[^i:&KtmRN4뫛+i&O;DI&?kۇe˯>5ϖ_OZ~&Aoi_?ii~;폍%Us߆c[R'Əh_~kxKp[\Ϧk4cơxG6< \O_^6?㿇^; žtk@ ( ş?xk_|_ g8K^6>2z?|~%Oׂ|ŷ7'/2.?nj>1|*AAsOxW^ QҼ1⯋į _O7k  >NG­>@>>ɺ9Ncz Q٣HGO x^:_ړƭsG<'7 Ǿ7Ч /5 x'ᖿ}x[_[H ~ПGǟƟa?ڻwKm7E+Ğ~~ j>xW:F4jzOڿմ =}k_P|D῎> kxHߋo/#Ioiw&3e]!0~-]cGO D_ ֚_0~~?PoG/  Ѿ"hߴWߎw>xswCH_zn5/E5ž:<8.<% !<)SW*?j S|!S <59|gL/ګRj> x.C~'[qxo3S)fZE|}7M4ؿ/?k3][7Z <[zᏍ~x?./|<:X~=S↗jڷ~ãVkn4  ho?+_?e_>"'x:@|g)"ϣ|GҼSKFczE~N_~ ~Ǘ ?bڻ0+W[gxž+~'~}7=+xp&־>7CyFxwŚOV_^Z-7jFgUmZmsexTOV-Í<`ߵ_g~O,*^^| 5l|Qu\i~*6/ّ>*xw?dtxPWU^+wNFYK(((ş'.)|k/ 3//xw<;xwFw5-#O5}+B?5 ZJ/%$bYK?`L=/%$bYK?`L=/%$bYK?`L=r5~$_WG_ xS}n /`W5Z0]ռXu/Z$//6j^# 5״i%.'| I᤽g + ^> S~ 0ؿ_#u@= eI,?2?g_xؿ_#u@0|^bSVt?f7ҿm>,<SŸ*|+c&<=_kڽ}{CH}GYҬKF)?g?_/)g{Yd~ο,%&G{Yd~ο,%&G{Yd~ο,%&G{Yd~ο,%&G{Yd~ο,%&G{Yd~ο) &4?bڿ~wj#W= x{G毯x^-4F.SQx`(<| -^(/wƙvU해| K8|WC|ѿa,|S{音K:G'{xh_ߎixz ]C>K, N}[_ ,:~~0o~ G>1xD׼A$z>|iu/?l|`%mG>|p~Xլl?{J?~#SW__&/F4}@P@P@PfcN޻G~ =e<#Jik]G;sᏎi |L+V־|ItW^lAgt=szK{_Ao>!?` ( ~ ~wƯx~ԡ_ !izv{_h7C//|1&xQX_-]b@ [/Ï_|@ _O?O# k7/ٓOKa'5 x^|}(~̠_cŞx_|o-YYӼ9_ WßSXMbIм?i6wꗖvZ_\mAbYK?`L=/%$bYK?`L=/%$(gxax_o'k0?eOj$sY\Z׍o|-%ƛ\&c~XYJKX;{Yd~ο,%&G{Yd~ο,%&G{Yd~ο,%&G>`ni/^~o~|Yx;߅?3~o@~ |(z+_|+y'o'&xhLOGo]X:?x;J ( (>,य़`Gj ( ( (3"5WV~ ? |e?"w?o^M_ÿ|SwÖÿ; ?h~7|,>|t OkUKoH]<% _H-?%ߌV~$>?g? 7?|o_ д~m6> Ӵ_ Ug<ǁ~-+kw'|!ZU4xWЬ@/`A75O~ߴ?|'kWkj:55 +Z6a"Ӽ9mxc4ޥxW~ ( ( (>5V5W|14^'t7=/Qu4=+^?g# |g<9_//h |k/ a ¾ 7?9Ӵ&izvk_ $Ni6~ uĺ~%=?~/ ?A@P@P@s,|{_x^<O>񏃼Yi#<+=:GMbI׼?i7^jZv]\_[Om<0|YQ{||7komgƾ?.?E?g߀u{M/|AKm7MĞun_ <;|q:eW૧|_4W;8i׷Efɠ^|u>"ڸ~忲I_$~>lgĉ}~(ѭow^{\g[}.mO&~+~_隦᷄nA%|Mhu>{hSj6:vwkxEC~Eo}wsGӺPX|agcj SEjzӾ x.xJP|?ß SѴH|-cjzf^xzgX_m#İEufjo; l|+3? xY|{Y?ړg^*+ọ^߈O]FWoywyF?Եbc~"<wNtnom6-GOɨRM|Qga/G w?cٻ$(|:kߴg]"3Ǜ=j/߃Mj|;|.Ӿ ~.t'k oK.,|qCxOXÛI }{ ^֒xS~џ_٣RŞӛğ<[6J.d?> @|sY;x ^3׼Jx ZxbA]W_џgtx@4;K[Ɩot =xx/]Z?7mz#/?<+_#F#^Exψ|#_o[ φ0x g/)L߶'_/ʼw}{~##<3@֮>Z/4_}/Hx+9#=w4 h?Cjͬ~խ4v/? h Ư$Ϋc;j6  <FC'l~:g1xW[>%Au_ڷ^~7x{P#)9^dj>*ڶyn]Hm'Nj>/-:z/|/ڿ[RKe ?d/IswcT'u]>sk.0@y tڏ+=:}{_Ox͎[KXue}^E5fƚ͖Vi ii^oPE7O-$z?|qm^h_'졦5şY@[4OxE𦭪I٨7^6Va[i^/^>&uyj{ S~#SE'|BYi'|WFޡ{sm]?Ě:e|ZKjk[ M6iO7/?}}ݮ{Ma!N1Ac|Q񅝎x'?MHfN _>;o

+=CM|+NF!k퍩^y /a~j;S׭K]ק@?+W~jiߴp|&S4:t?c?~0ko<6Y-_B7:?[mxA4 >k|3W֑[@ּ-km+wSú>}79:X-^Mfڸ=+>\Iּgm_?.;8z7Vw?~.uj]#Jfzv@i1G+X7'l~:g1xW[>%Au_ڷ^~7x{P#)9^dj>*ڶyn]Hm'Nj>/-:z/|/ڿ[RKe ?d/IswcT'u]>sk.0@y tڏ+=:}{_Ox͎[KXue}^E5fƚ͖Vi ii^oPE7O-$z?|qm^h_'졦5şY@[4OxE𦭪I٨7^6Va[i^/^>&uyj{ S~#SE'|B_:GO_g_G7%K߳O;~Kox_wWŸQ|/~://➣j|k ?g)_ĿڗN w"-7ٟ_|>~"?Ɵ|c|ڍ>too'o x쬖'~7i~᫋g՗+o漒+[_\GoywyF?Եbc~"<wNtnom6-GOɨRM|Qga/.]L9] ?O?[jgqw7Cԡ#_kvRV5ӴRH/?m]byX k_ m f4i,?bKK4F'Ϋgwm3NǍa\@!O#^>{W✺O/>4\YxK>g>lt+5^xj7mxA|4>'M韲! |(Ѯ-`|g>1EM=;Ex :|=wkX^?hPx#'Ė9[ ߇%j:~.-!Uxct>3kAKxG|P_9Yux?PӼ!xcD>e|BVmcm|?yx\o @<>}T׎5 u_`յ+ xvQoIϊ7A +tu֍$%UKOq_ |/x"W~?c<ºޑ* 7?M7վ&xڕݗ]{-oNa!|7ZK׉2Zîާ+-7/4n.l? 객sHǞ&LOJxǞ )'|To#ECmRB?e 7Tѭ,P6٥|@/5mRO~@~П~:^/|#h~"KKo|?S량_ ]kT3cYOG MҬ[i ZlZ :55?¿I۟O`u2x¿t+I<:׀l9m՟gRÿT|GγKiZl2N|_HM# ub|55 |TѦ$e-/_G:_:ٴ;5Msm><|kt/x_r0oĿ'io-Bտ~7 _g_~#_=r3^~xCIƉJ}N36YZ~Absx:}R MN˫j@,~8jV>֣oo4?xzW0)jzIKNN|_^fRӯ7xB@^}5+/`~.^_-^.d{ǻ/c|Q*~>0w^Bm#Ÿ c<[qO5|[ͮjo<9Q3t_ f_I?~׿L 4X|~⟆jO.|?;o

+=CM|+NF!k퍩^y /a~j;S׭K]ק@!mF 77f<_VK o? Cc?{ͳjZX^Iޯx#7~<^ |K|Zo~ZKm1|1?~?MYFFg_7W 6s #|)u(MRߌ?OW.s'Z -ڳ8ԻPXxwwj/5Yut+MQO~6w-?i w~)wxVw:eݿ.V:Gjwnw-͍ҽ`Ҷd[rhx{¯|Iqo񞩩>%)~_/ŏ,t.ֺ3k ͨk>sln|?e8}M/^˧YkO| /ƦC{OJ/5Pf)<[a}G2kZ_ke{v IxW|R]٧ڋjꟵ퍩)4o%׉_:\kvy__Үa5/M]]7_|ĖV.ot7P/TO=;FԚxSBI4 ~? |=7 6Ǿ$}o|B5oڏźBjڦXW'Ӽ=g5]x_Ot)u@>+ߊ?/~ ?~Vw^4FKk|Q؟j~,:/¿?KWx a 9վ%hߵH76Pm#]W<[⟇ZOauH_~ uX>06^ [Tu(e|M iWW|0>/*_Ge7iO|)|w~6k:s~1?],?<)}k|ڿ~1| ~//ǚf[$uE=/2̚glη㏍|7~5{zI?|,Ŀ SA7|wg//^<ӵ]++:/k5ix{iué^)q:Njv(a+J4i6 ~0xo[?_y-coe|) H$.+>*ߎ%0oB&ZBӧ?t~ _}߆ޥ .mg|?}ɭ+qgeFarLN]kY3ܒj>~CwCr}7]zDu]ׄ>:I;seys;e?XiާLϋn}¸n~~? aoa68x3(u;ukÞ2 F|rl,Eσ WZ/džlͧjzx_ 3UoB<zw#ִW|IxOBL,|է_)Βt ~M j/?v~vW߃z]o2tW-^z1 O {X31`Т0?go??V A3_#u&U'ߴ7-E']I+uV>5SOR.bߎ> ^%?j?h#^xw }C mm{+{ZOB~?g?'~n/|InS_ gV|!F4ȵ_At|G3."<^?ymG?kuW3 ~7Z(}Gk^3%kP#j\5/ĐK [e/d?&ցmZ^j?C+߉|O>&|T<:a-|{ֱ㋋/1Ծnu |9~M,|.{Y#?`? OdMV~ia6zh/Ӵ/zfּ_|[~0xK>*Nu%m(xg௃gqསew}3GGo40oA_;/7{:g4?kv_Ş?U*Ó~+&h!O۟M+˟i-12M=g|[u? ~uC K{uWTŏMNǖ&񟍿i@> C['Z{㫟۷W{ݿ`w/.Gqi񯎼Cj_j$|q{mxlُ/)KcC*94nH[j^ ?hElX__,4&?bmQtIos(=:$~t_w@ V:In5'6<)xEi_~ s=w ?u˽|;_~H}{Ep3x-<4bEB?/c+Dlbh[C5ω~K4{K_ M[?~8/xa_ִy?-&嶣kH񮵫xvï֐{mHOٷ 5h~ɿ?j__fOj ~7Ϭx{7O(߄ ~5M4Ҵ%υ5/|?ϋ=gj gX.Û}F~@)~?I_o3|^gӾ'?i :Ea-If>~7|hs}oR{]ORz=jm/i HiڷǝWC+;Z ¶ZV.5.|O sBM#7ύe'~Gm5V?ߴuOѕ?M{?ziF-SŖƹIO:,!q-9oVћᧈ5_|?<شh=2xv8:'.ExmN4{Oh 3GEOO|:[HhK/WF[|@<kLMWGԾ<Ė|Si@sDԾ"@8Eğh!YOF#>ZUmg_Ǐ_3~Oknj?h<sྣG]mOE&{TZ=΍>xí o/ᰞKk5)u;g6qj5]'MԵj_ .-_h_ ͭxB`5|UNpKfP_>{M*+_fi>7`5i~~˿2xMQs+RO6_ɥ|6?j)uٳw__bxGw9=SᾳpH> M|TeO'.(X_P_E~0!L {'ÿPE.|]i"ì_O?T-Viu?~˿NA5/|3S.|I~%׼Eo&33.@-_SPUrh:ݦqNԼ|~ر6Xi_L#ڢ^׼Q)4{tH4> NtxkNlxSTׁ~O۳Ҿzx~ {w⿈0hƋ'.fZxh7#o#~A6k]?s\5x#LcHցo6K@ִ\}i6|Y.jG~*|1COZ~Ͽ h/7H~-xEgO9Ig+RҼE._'ğ}'?)DVwZ]5Z6(+HWKymͧ'@ӨwQ|-yqxAX[O2^x[nH51_<[&(G#_bͦ8O~200lliÖa[~~y?eh>'o)niMv6I4[Ϋ|j[{r+OZtvqi'񆹡x&S~MNƿ\~#6iPo{:hʟ&=M=B_4wuzY}n\wmPo~hׂoOwlZi4 t;z~_xk*( ߄i|?Mx?qwK­ož??⽟?g_şW߆_o2L%֋x/K^Xᖰo } >r GK6ҵ ~Xⵇ ".@~7ZxEzNm|y'eRN6>#uf^S:S~7Z[sU~-~[~_֕z+iwizo?.$Wciw;hwo3~9Ꮗ^Z7m?DIctCUA_(/#_~?JZ]| kV*?~.~ ㅶ5:<oY?K_ZG-"H2ZcjfO{`jা*}^_?ŗ_t,hF/(O/t e_Ƚqx_z>. 5ψ5|a~/C'*4?e']׈aO#𮩪"ςm˩>$tK"QEah/)KcC*94nH[j^ ?hElX__,4&?bmQtIos(=:$~t_w@O+ LfK'f ~|+QѾ7-}?ÏF4-çB~"d2jGlI~3F`ko?S /ȿM }m#;>%='Xe]}CxZR|lޠt|B_js[X4,-|7!6-l ]ྕ_Z57|P?ڏߌ"׵#ƺ֭ۿZC?E R|Egu~N+Zi/~Ҿ$ז>?2t ߍ:u7מ\E%煾 OSޝȿNsź"i)~:/c.Ɵ|9of ||7G'Z |V?d'o~(i{H4P_CNվ<Q[G֮L-N_~>"AwiAwk2i@<j//Adٿ5ٯf+~?_?g__ğ/~يH> xž7ݵ~.VF|Vw D.nnOnOsoڋǑͬ <kWrtOOIeCi^&|`?0kkk:T@uK_OM&FWYr/x9-t~ӿ@*j=2?oO |E%OڗŞ{ejہv^Gk}Ε{x{zFh:~(D |AO M߇:$j[٪|3saۓdO?woxM'-&şkk 6z5' ~><+{z_ÛKKO?O ew[?h_ڿ-~ii\j |KƟ|5 : Fug+ׅ/<@߲>$ ?M "x+߃O6~-xvV~|m֏_#[>x+RJf|>}b;IOZO~ o/Sgi> Z/[嗋<׾ ^}SC &|x:'yuxo-FkOZiV?/< 6|o ׾"xþռUi 𭌺ش VtkkgTVmv@/گŏPi>wk>6>o^iZ4l(ȷS[X&I=¡>&}jGSkJNQ-D]Mu8{Cӯ-GYҬ/-o-,ouK[˻M:/?Pd{{}{x x^w_K%^"{ oxcfhMo X&q .[ңԦլ"Sm6M9/m5yd7 {֭7[u'CmC[4$om4U&VIt.Y]c@ .C_ Z[)u(udӠi[$> ,य़`GjX֓+ocUok>,~5f|d&SR>_ kt_xC? ?nU?>" 1 d~ַo!2wд _N ᯎ6bxc~|D?> KėO?|l_'>j(%|Ե;/Ĩ|^<+"~ %^i7g[ mgŝ_zΫwMѿbt xCwZW6n| /<ˋ)sk7<w!"m#W1s@Ik;)WDҕm{_ٷ-|V[HgleռMŠhvך[^k:[m.cz>ǫB4|QJ/?-k Wf|]ainltb ٥xV7^&.u~jpwWះ>-xVJ.7OvW jԴ]KI{_ږ[c Q.7H3DS_o_k6!Լ;ch~ԭl uzuyy>D񇌾"x#E\Scw7ZiừijwsºO{_[W7x{QhU-XM'7R/t8W_4E$+K#\Wi%]I" wսWssiyismuks <7K;,NF̬ @W왧?|{ =׵] {Aᘵ  -t(AoQݟkd+;|Y|(APt~__l ?i0>?ּ OoWmo!|1Em/^ ǺU |WO)o[k3mε":/~$K??5:/ _x?|Ҿ ZZ>< w{hZijkd<3q P/tH{ThVSo(P e {MN~M5 2;ҡ ӠŜ6@:J(⭜p]:xvI>u}@? ~&q_G✗\7]Lw>' >$?|/?ٿOqqx|5NMPc|O{/ 7{aG6V]e/"~2gߎiߎ^G/~/|2~N|;όog~z4 k`_?>,|#?|'8o?~%m# U2?UOxzt\kԾ 9A4 i|>=߄|7{y;Ŀ֧׮4> `Դ>P>cimghi> zG o@My?|x| {3[.&ZrxQ; }K{mo<[/⏈u_|&G]6=+7.?hպi^ 57m/#$ E4#Y3iz\5ޛi)oG>!#D2Σ+Ժtr,>DR:tڮzYVqw6^[%VhqkwjMͼ9 TP 74?W>iZ:v}yrl,Ըkkۻm-iA$iAJQ^izvifM%cVVWMksK}Bntx> \x\Bԡn'Nvo vUޭ]񕗈5E҇>et 7^(:oygcDjFѴ3$2|@~.x;5B+Z-Au_o_Kio|>Yk'm|=}gfczw;:?V=ys_|9/n-O>ZUxsΠ > 4o?,w5ׇ<]yA-U7?mONivqQ/~!xy{k_h>2ĶoLڧ>,E#kI/<7z5<_h6w d\^[At? k}SXk'ğ>$3 7aƿĭF "о&GE񭇂-~ƗN d xOE?Oׯkxo?OᏉ|U;KßnM=2CIu-gck+wt3}jG:E>m֟cM{x0b;š4#е_xS:/uU߃O1]1x<)Noe esJ)xcෆ4 |JUυ4?যYex//^ּE\Ӵ|6&񿄼o_'|;OWf oٗ}ǯ? ?vޕ⿊Oo& ZW< o{q>?x[-׆<|Xyi _ }#ǡV~&_WO5mNÞ$(\?` xsT/~0^j ?fMĺ񞍩xS|E L|gH|XqSeiG^xZ8~)B/?/4>_S[~1xgi|C^5;,\Jַu_?i_LJExsxsK~ h(^/؋U%͟?> xo QECm2_x@?_;gwً޴jOo%>>5+ _?hֱ-xFV#?5g!?;|<jC[^,˺?^1~ў>i~/GSk< G^&Q?&gom~!~3| {[σ4S!<9/Xhmit wa}N㟉OXGa/|33#_ßڇ/¾+d?mN|qw}O W۫_]4[@>>%~}gMU?/~"7>>8QץҾ‘tx']H׾oxؗ]⏍gV;>?>(o>8~:(kJ6㏆xLqq7Ml5|E4|H޵Gnto i>x |x'kh6=A4\h~ʿ/|7~-Aφ~$*W> |!ǧ˟W4~4|] |Y<+/Z4]?HS>[ mvY`W_OC[`|cw#~,d~ ~&ky >Oj?u˿o sF4ִ mͷ>*Wz^@!㧇niG_C~7{?xS_cB!|.g h ~Bχ-l𧍵i|I:6JS (ـ~ο8ћ`}nA:_ٟj麏sv|Eu+ڙo+/>*uXޛn?'?nO%W|n챠~ߟ?j/ګO|13=x\VZ'+VB;1ᛍz7uߊ^|E}{m;P%Dž>ga#Uo5_A5^º?M<%GV xưk:o5φ-#A~ᬟ_~Km9~~POYz?,|YҬm>-7x·~!5ƺdW_?|(8]g-> e߆οtO\ _? ?X|\Wg:Ĩ/ TҀ8?[2`x->>7)4>.~߁KkO\vmY4^*sͯ_xnOQ_(c}_מ.zG %|>1u_?a-#㗆#ex'Nό:N-ƙ]׾ =/I1|'㿇'_+o7/3f_ !K]?&]y>,Ѕ?hpk}{\ڳg?¿ګ4| V^9x^ ]Ǐw-;:"τ4_M;_O ?m |jB_ ~KF<}.WM/~ԧok7gQO\>=M\>ڧbZuT5Yx+|iᏃ~f ztGwUk?fxF¿Q5KC㆛x~?W/|1 :k? 5xHA/ 7:~;@|JG?fOjTt S럴O /kɦ:>;]koڴ_xW~~~ݟk= w?5LL#kfgf_%?O!<־2|F<975x7GK>>Do_xW1x?a[vO~ǞS_hh?jߏ^7C|QԴK%ФOƿj:+O}47ZVyS>~~/Lگ OSx> OM+_'ݢxFO{߃'|E=ᮯ/ EVگ"Zj׀Yx_+(-uᯁ|[kxG>V݇O [v'Ε|aG< [cOpp_a?+N?~?f=3h~οZj4IӵGXRƛPWroφ_{ /a7Z,u=Ŀf&π4 ?ho|3ğu>|ԵM[)d>ׇ?h_u~Ϳh7s|c%? >$xUG>{M>_j0M!Bml@>"ֿ}΅DF>)pxZ/מ:egş׵Oޓ_]7DŽuxw%o |F4-i? < o  "ioxg[~ڿj gkľ o|5⟌>i:7,"Zx{@',>G/o}m;Wf_?bo7uُ!9i~/ڕ~k~-OĿ<+~ZDžsCv^3J|-l/f5~Ȟ?"?o9<WgO;7O/]x}nKftpgg ~ u;o߳OsQ_Zğu^F /+hto3C[B(~4_37SIs i|/hwO|qG%=6>0_Gው+ƚ?g߄^(Э|2>!j~4;߇&C2߱ΏGzFl.j<_xcM[ cJaH׈73vUWk|ko~< ~,>վaSaᯇ5ؾO x'/|'yZx;QɖOixLo7gڛWN?8|uxW'<+| "oړľ;q_ KῇcM;Fw^=nz&X^<|O‹iIo~^EVxKVv"9?-/l5 焥gMRq [_ -ltor`NZZ6;}yV;x^}wWV.>U'-2NXд{Ҿ|75ojڃqAa:މeo6:έga KðK>S,?i m4 S x3K7;y]sl%+MOHhL>=߇1i_jxOſ ]%['>zkk Ԯ%>>t/6?nύ:g8k)4b/j,&+OxJ¯źmk}"^U?d>%>9^&$ԴP&{ \е3zGOXL \ :7taVH]޷o5uEou_>#J7k\+^k5/n~iFŒx?KZW>/j5ջjs7͍~ \xSN>OᏇum>W?֛=gM3(?> 1xľ}-}OeNO}_i ]3gUď4 o_υs7#kOmh~~>Σ4xE|S5mx_⦏x<'ìxk6:z4Q5Ūj/a|)~v|A^&mB +9QMԼ-4[ux▙xwǾ:J"⮱k-dt_>kO$6zG6^.u766G/6xN#:瀵o i^@#cҼ=X»?Zԋ+(,`G[}D2V :u_>!xo:?@M=a|FѼ)q~|MV|MHτxoX_/f[x%x{4 ំ?l_mSSፏ|Xo'Ԣu?nS k:NJ5;> %ݖ@Q7C,.4of '0xU w9LmԺ6--BY3s6ErSKj1ver#-?֍eg~7w#/ squxN4~O.s}n'a:$_ZiVZ>]MfΑ}3 5>0tӤ _S #NXR~eh/ ?m o:/&L:Ϋnh?dI#u2D֧,H%4h୿ztX~ExQ&,_L/)8W][s}1?.c.d&.l:mIm"ЎN]5 ?_SD펛gDZQ4 oNɫ^66Yv ym4?m +hDL/)~G_h:""ּ!Fo}6':G  մKKOZ9}G 5_i^,k! k[`Z[q R:?PTZjW1jK)l^-C ʺ&ڈҝtLf [_QHM}Zoť vڌDvC@7/s,V[XΚ'"7>c g>֤Z>jAO?SkgX ~6^'l I~5t?f[ZG"+/{N_?h$OOտf~!G+ƫrI۫ o_Pj/~?~1|z-۟ScTWg |G'Ɵ[־s֬SS,%Xm]&_h6)Z ma'<1vZxĩu!t.-tIw ,.@Ma قI5l]Nb<u. u gk? ͤjA\zT隌qݳ\ o+{uYY߶;?=im]k:hF_˪xv:8[IN.W־hg;֏Fm-Ys_x#L`Moό4-45=sCHӣ4ԴZ&5c(l୿ƥBzx> 4zs~HGL5 --l5Inb,. G%탭|KN?RJPWz~Y\Cu n_ @kkwjp_ Eo{y-ojR0উoa6"]ޣiWlmby@ i_~1xWZѼ9o?_SKh7uDEyC.TmsG0Nu;/<ڏ;ŏi|r kd /'ԼX?Cö67u~g5M/ec"?Sk9<7WSh[htMe׵o:[,.@ $>/K_%|&'Kcn_âXζ4O"Dn|U G_K_?wx~~ ~>>xO%,c m'> UzΝ |Ҿ=/_ f:U_7?<?j"o|[c.|%'{mwF&[5x[6|+i%}J=Q_Zb&/Ÿ m'u"m]-a_-!u?tKEZ~)i|{㯄E_o]įMCcSx ொ*xWOnN^)>(1Mdx?<]lt_e|#b8Xе"Ҽ!sAu#m|=7숋Zx@]K ,`v^x+Ww/Vm--<ak&|_Ocxd8l/,momo5goqio=2<1Hw ?ůGt_ ߱?h|2ÿQx;k<3#©@o;{Ok{ - FO<[oW1К| 3şmt/vO߳xw+@Ui`; :M#Ꮍ'|fּU>hϊmAe+KG^='þo+o/|F_xS֚2<9|h/os>3?gG'ϊ|)?yƿ7 xq]_^\?[:?<Ko+oqy5u|EC@ 4=sźjx_GxdF]OZ3x_]WD3Z{h鷾HV᠊l?m>_SC=n4E( rxVұbmn,[e@ +oqg5݇kExC_ 4=źi x_XydE]3ZxA]+D0Zk@V^x./ߍ/ 4zs~HGL5 --l5Inb,. /+oqq4k+|  i$z4Vn"2xLo˨z˫68y[co%#ӼWmMBO&-[[gZ,3:/NOo?2?$xLA &̶wiˤmom66㖕6i{gYηug/OE> t_.~Ŷ6v3_NҬ%|@<;xY-mt#S<_7|q'_ >zUkx߰|Mio<#c,5@1vp] m|C~\'zMi5kixo/h^~Ooi[]gQ_?Ak:|!/xZ>֓ay.\7+M9YHWz~yY}3Q~ .Ổl5W0|]-ޥ?6>}{?'8VokW^_k^,֑xk|G;;?it/|ZwS_xb-^ +i_ ?6^ nMi,7ÉiW`ݟ![_?|ys~0gÝ<ߤ#|߱_tMV}j?ZGO-|]_LOi.BV5}{։#zg8Zvo3YkΟ[Ѯ5 [XO kHi?7//_R^ \{Ef~8ZjMiVy&j[[gZ,3:/NOo?2?$xLA &̶wiˤmom66㖕6i{gYηug/OE> t_.~Ŷ6v3_NҬ%|@<;xY-mt#S<_7|q'_ >zUkx߰|Mio<#c,5@1vp] m|C~\R-cM5lY)]Ni_|te7o.gC.K _jzV__᛭&z]o |9վ+WscNۿ.6fA]_w)j=xeSHA" }6L>)jx?nb_+÷>+ܥ):wt{еoG_@ ~"兿&d⧌G]#F +~~-Ro.U?Oυ?m,to xKoG i|AV_6,|EƦn/h~!]᷷|;~?> ·3x_|?xZgx_pz=k_ď_GKq)/د$]CO |cױ|qzS$:WO|Ou-;4[Z>$NIּ)g"{o $ZG Юu0h4Vm?VX|?ռ'xc]_#mSޕG¶AόFk/¾04^;?+weş~#x~+/k?¯_ gE/xW?oڇ>[k_ 7~9q/ez_O4x m{Q/DV?W?~Ş|m_?|%i{MxOC|th'NwҮn~i^{gWğߍp]AJWqꟷ xjFӣO/y<)jpi&-o¿؟?u VJc_ğ|-O?YRNoEtַ>O~xi/t=D_oM6-uC}K}GG3T5|C5rZj>$&?io㟊1ŧ|-?x'> {jp/<-?_٧G;ǟ~*Gǿ~ 'c;H x>NcxeB|Y' ~1U|A.axoN! x w|q'_ >zUkx߰|Mio<#c,5@1vp] m|C~\R-cM5lY)]Ni_|te7o.gC.K _jzV__᛭&z]o |9վ+WscNۿ.6fA]_w)j=xeSHA" }6L>)jx?nb_+÷>+ܥ):wt{еoG_@ ~"兿&d⧌G]#F +~~-Ro.U?Oυ?m,to xKoG i|AV_6,|EƦn/h~!]᷷|;~?> ·3x_|?xZgx_pǞ3*a>'> ?z'(ƽCZӵ]_X;w#5?n: NZJ]ҚG))t<%}? 5k?fύ&_6>Wun.^%_J/]o߂5Ʊ>>h ZwZ$d iYiտwzek:~-oF|-mcCi?ÿ@'׵#º༿ ~[BJx'Gr'i6Z'j-[ ğ_ W_xs[_Y2x@T#~# V?IsEW@-WzD7? /\+OoƸ.եkk+O r<5wiϧڼ584B_O:+g%|AO,|I^݋ڷ[k[^ ݧ 4UIS 6c>"|\6h_?>1]˯V-ON{݂ emmOh>0o&u;믉?$XC '~BW} uu: >u%HΙXŇ>!9-5_|Lk47čST{y}3|cL;_G2i߰[.5LW/ZTNjOOg:޷ Gi֒|i⇈?S|&_Q~躒Zge ;O7JDk]g>4OD~hOĞ;~\|(Wm~¾ 5VPxOow/o<;t5kpH7@&fw8|Y~??xG)wk^o⽼ĺlj.t(m|JIZύ|_|φn vt95V_ ri͏:FnWo4階ou ܦa>|Y_ٔM"x$,7Ÿۭ3\iQm|;஛r>\ӭ/kCBռ; | <+w?'3t0MmGeI0|PoT?>x_Hm5-k OY|CMOEԼ9awUg›8ag' ~=+kŞ:<]O~E~+*m|bӣiZ_Zb-Vt;E~(^J׾Oþ&|: <$xO^L?gN֭&~ۿ4-cYkz5ƳkkI>%,Sw?{ᮻ ǿ >O}|rc_ƞUOV׿hφ^.-Za|`{?ߴtm+"|o?/ xH>+~߷o/|f{hf_c7O>~\vGۛ&_oGD/BQ|C']|t[ Mjj:kg}촉h<[;f>.U~|Vf>!4.[jo'Vχu^5i/ #ĺg5)$cPs8O? l|=x4?2|SJH|Y?'|tCQ?^-'| _,XxCZ߇4>.A~Ͽg=֛Ὲ^>~|~%x~0m|d㞡pto~k&#T>$xLA &̶wiˤmom66㖕6i{gYηug/OE> t_.~Ŷ6v3_NҬ%|@<;xY-mt#S<_7|q'_ >zUkx߰|Mio<#c,5@1vp] m|C~\R-cM5lY)]Ni_|te7o.gC.K _jzV__᛭&z]o |9վ+WscNۿ.6fA]_w)j=xe/[;kx%~Ҟ"ޠt){lx'S5cJjKKSWC|iT&Ro:m?/ř|Ov/kn?g~)ˈ~ o,Y1T׼5X>#k|A@ !ojmF|U_3?-Am:sjvhV64DV׎ x[+2Y.gt ,SEԴ_.voeDINUfږkkS< ./ūZw‰~i5gLݧ vQω-3B>3x+gc#:~`sW0aTWZ4_x/(缽Dj7&g|Q_ķ6WIihڷc%o|M~i*|1}ρ+~|;O'{ ]xUψ*_#!oI\xw:|4Ѯ<_ZQ}|>Ѵoxxů;ƈ>!a7lI __~i<:5߄|;zo/bc,ski֟췤x׿{3T|9|F|S>7>q [x>*|Q-0x?s^aϩxk > OlƳ/TK[MkqixXgA)aR52>,>xğ 7|qV<LbYAOO̧x7߄`Fӭcw|gJIW"-n{K#aDVzfU宩oA mcv<__<;'B i?|M -[aIsZ=k/_)|pzx>|W<`񧈿k*[~#>|0|D?υiؚ^0uI_~7ig}~2|Wt/_i@`ySWo3modk\ݯ_7S{P?{oHoGm>Ţ/tkqKᵟ/ev^ (0Jb|P?5l ]7Mޡ/''GtmẲ {:4&*xQu->[i<~Ӿ.;|@gxY6cDxKKj֝_wgY<7i~]zosKoP$+ie7ߵX7,~%X|)>5u.Ş <#{y/~4牯,+l7W-: Zk6`OaXio&.<3~/>-<>A,۟n\kKR9P<umx/ mT_jm^ 4#vk=~(yqMp~A'|7GG߇qOaei:7? xOP>&_}o|f&~#"=@_|eydp0~|2UofC6*>i:2x=~[/ٮ~0k>/@ִy/ x~"*'韱Wk7! #i[~arWå4=fi_ Z/ b-]3|G]w/i<~O\E@kyeƺƩK]KğX xT~3j7~ylU&mӛSFҴٴ|{&7Vuu/[:_!Ns?ƟCg/0gŸ .uc-2'OwtO6&Դ[_ ho|8 7>~_P]5i,;ODkkCΛi}?۝}/rɼ94Ok0GN>{ ;_V uO l]eKgb{ߍ?Fyk/w)AxMKouy4ƍx?,ijVfɴ υ<1O|#|;s[w×RDԾ|%5O[_'r{:@+UڇF׈#56o[/_τ?oet[wχ-Yo Oy<3KxUwyx&᷂|mGþ.x Tj{+⾎|A%7+P?Ğ&4?'l¯_ >1xO᷎>|~߇~ s|\Wy-s@񾁫[+׆Ci ?T_IB_5]/X|/:zxQ> 5Ğ=x<+ 4~&Z)jڂ1O+4>Y{Wmu-M+Ҁ4-|_1x]mޞ0ޫs"r|T}GL/>-׼cxBoSĚo5I4ewjn~-i %QxoLu3v+7?o]Gzlw>$mKx~ƞ?Z|UCϡ^US_[/Yi<|Yأ>'OxFojuà^M%j/ mm?O |r2\oV]ƻ?T/u/ u SV.ܾ񿎿f EFѼuM?k? #߷$xn{4y~ |wZx~eQFh+g?hk1#_זKw'(u[Vl43a S'#?`%,~  kGRׇ?/ۓ~k|uf_U::Q!xDv<S^k׼d|Y|6w>n \"xvx>EiO<13Vo Oǿ8|w"v SΕc?^?mdaOZm46^b kN}ē>_|;+|;⟌<;GX~^_u|2ſ,~~^y?fo>_m4k__ a@ |U7}+@<4|FOխlGX~x:o@&<7P;@kk'WįxĿP^x_GXx>&ҴA~  F־|)g? ;[oiڪ{ICW{AmWz-tF+/BOG ‹ xEx! xg{+ _gA@>!|:oυ|G-s$Ҽw3 g ^j~"e]?Ğ!|O'xZ]G-|)+dxkkz׿>/M퍞dž$|b &쥥NKWo?S^n>8|+R|;O4j|i׾#i~,x>|G]w/i<~O\E@kyeƺƩK]Kğ|^>$~۟|wVk~ DŽc iO؛šZ.?'ğw'2h$$(𮛧K@>dӾ(\- 79iτzgu~wr]\hτ{kqxn_x_hP}h:^wō|CFˊoۃؒ <7sῃ=< f;xtk -I'.-,|+ghà |w%Ǐ(?鶺敡x_mV>EPk+Ew clmCC_pu V~0kTSaOu#/Ŗ&h7eGey]_M }Iftmc>.}kiE~"fsx2?ŗEgM7o5?jwԾ|$n-Xݟ\s7@>&Et?)?]i^?j'^Tiڇ[|xeyG4{=#Úυ<[mށ}>h~|-t]+׈5xk&@o|S!繼дl 4fwmckUe{- glڅLJR>.o&GOxW5/3@g6GwzX4V:6xL|ukq xQPHyq EWz}? ڝܾ3O i-FWaXWZOj` zK|9`񥏂|MD'&|῁?<a ޓ| Boo-.~,|PH#C𮉤x_OWoxR3LOoYҿk:6Kg?|S-[V5ڏuo(/V,xBID<+ |.55S}Jk gĭ ?iߴ.tυocY~?xOǟxSu߂7#|gjsmxW&\sM{d:aj Do4} l5E?`;Mcc=jFu6گ E̓WҴfg|/Aƾ,[tڣxNM?c"EI<_Ǜ/|Fc_k6>'.-,|+ghà |w%Ǐ(?鶺敡x_mV>EPk+Ew clmCC_pu V~0kTSaOu#/Ŗ&h7eGey]_M }Iftmc>.}kiE~"fsx2?ŗEgM7o5?jwԾ|$n-Xݟ\s7@*X&i6xͧx7ޝ.|b4k ?joh>{+"-\<5῁@6<+hW(-/na-Y] Ö:FxItm3Cſ|? >%~п~7hoڃuߋ7 6/gJ~"ix ~1 a?[0OP|AK'tozVO@/~'<[/[>h>g?>1<Ԯu/g.|`}ws}Ko j?y<+W~$ˢFj|~ώ"#J㟆|/Nx;fO~*CgfE?>%աo>>↣u_\f/|3%ć~t_\Ewρ9xvh'xxJ< { Oٷ>!|1:Z#'? #6[/:%iҭER_ KyZΥtۣ^UoާS?~xbW+iIh_'|ExX^dL^Ēx^“_nƑ=| |7} _xVn>-U ;;u?WOG;UIpi/»z1)WSd<)iO ?iN]Xj6wkޑ="(m|ox+Az+=KB_0}bL׬~h:P'&`x/OOwPE^u_~ߴN h'?xYѵ'>{Gڧí⟊Ci}huψzw=OVGբ?g'LV/~_Ot_93|=wzu cPwxJ].{ף?U.!{zF|R,GRomíuO Ii)z78G|mm /S>9ǫo#0Hn!jv_Ke'K[bE:,\f[Ö!|V/_V_MG۫}H?vW_X6.y?tkUӭ|]Zm[ Wf|Kw cj¿>\2; %UŅό|q+{ Rĺt0;v⿊ eY<%'Ğ ><~"Ss|.7j>x¿|MoilֺƑ"ѵe+[_!;ZC㏇eH/."|_g6񟈧?(WOj7o oh¾:|GS['OX⿇ b CƳ/ًJͼsDx s[yMk:Ci:[H 74zޝkG~ߍmmywǨ~߷ZT_SvxzKkk~?d>#ƟO x_~C;(qn] Q#c~:ŧ/꿴ڟhf|+|?}ZZşáeuj Ath??Yr_ +ΉW'<;NP~xY4?_4[:/nwz&! mLj?}ރM?+hx?/ 7Ӿ6_5xRM7/Oٛ^oƺoAƾ=?jco~|q/=gz("xU͜ގ?`[e1v 6?Ĺ~%~|c4{ŏ-nxnM>*K>#h~S˭SWbٓ5?~!iB|MCŸ3B~ 'Y'ZVhZ7E{O߲4 x_>xc^/G/ Bgč7zOi//zV*Cc? xzW3PcX-oH7O~ MpּeK?퍯xGy|_JC>h?Oeaj} Kd-[ž!a>;ΥLM/ox~-A~̿jOOA𾫫U5 MJ7? W?rx"_Qo'߈oœ񇀿g +8_Y^ )3eާq/Yڮſֿe@HK+~{Ꮓfo/? 4OC [>,{Ut|u&/Ǻ_:T<FxQPHyq EWz}? ڝܾ3O i-FWaXWZOj`!^~sG?M~%>+~/>!|Ik_h/l\5K\⦂ߊ4~[=;^ ~13%g|mSO fϋVW࿄֧M> oO|)/`i?]#.G<+>+U7?GS{m'٣-.P[hvd P|fL)o?hߵ|_KF?jW~'|cw=T¿KN6/)ŏ_IO_?@,_ |/Ooxs-|Li:]ߎ>)|S??[]M|)f~)|@O:ä.|D7M@|k?xwOታWoߋ};O ?QkDм/ſ x3/m|=:*s?'»{eiwWiM6'OZQ>4O5;⽕u}7.mo%Uѵi%Ήk]ដ5yzyxvRIQcwv|9sec<⯇6ߋztnTѮ<3 =\clt?SVtMs@׆;S'[62Ӿ4d𮧬hZN[o_W8Ծ-WM#ft/X']Ѵ!h0ZƳwxUG5+>K?xAŞ[,vhGFuUT_3iqG~xWItk:׏m.UcoQ~+&ſ&I6C﬚??g_W 1%W~kJCث1=f1CoV:F_ t>zEo_H|K7ɦ<^)g)á??mm;{/XKu- ]+v"_jMe|)?b=_WhsZo_e%<3VW>%F&j~/ 7Rǚna7/ SR`"vU~՞q|On<9 ~jWׁ⻸?ߎo6G=Ihz6Swſƍ|b״t{ym_ۂx|3c{/Ѭ;G+e5^7amBjO[}Z?m-'_|]!|Q?x~M~~:[[?>"|.־x{[ljoox{)~ UđOƏK{xAN _]׾SD:_~8Ho\~ݭY|<}T}z/xYֵ ?|{:T~7ভy W?K/~*x];5-CBPe㏌(xY/݄ZKu S< :'s6i6+׿4MŞ%48ot[%y_jU> =Yk[Zxse$귭c??|S5&(ژ=rVǎ_G/~~$Bׇe _?5=sV 1ƒZkھ&i-s}iڤ'3ᆞ^94O}wϣwz4u߆_ȼ1m'ԼxORҿe wn{/N~M/_?M[xAo yO~շZAh^FwBm5[+JҴ"0+w^ݦ|t`\_B*Qam^;o+Ya{[l4WTյ aԼ}`;WtD??j_ 5믂 eoCYӬa_'|q;t 3o?&Zx\ eWе?^?g[׊cڷ>)Ɵu?g ~>1kZd x{/C߷ eLJ~|woᇊ| ߄]|HO+]s>@!h hW5~<_q[xĞ>95S˫O'Ͷ?e?KMtK]|O}HOA- i?R~4_~*|=r?φ$3jwj?O-*V^wKXIZM#ڇmn~)xy<;+xs +Gj?F״? aOιc?k^/9쓭>:xrį؃.#i?_xwQ焵COA>fjukm I^ρ/5k‹k/ >xW0Owբ|=9|cؾ~SOW?7gxg__<EƯ~ğ<3w}߂~$7|1׼QjM?>v3jMLJO(%x֏pmmtMB|H %j"𷂵 Z_H+o&s?OxSxuO14?ٓlm4@~9kaKMQ0z垭[Ŀ_3HjzUZc$u=յ}.M7PZ{ό;xoU|0<7B@wuSRm~> _}w0~4^+>O ~[i/;Ms6⏂sJG7m7=Viß٣x}{] Ql4m+J?{ us؟xAu gҼ1_RÚ]Y|"Z-B SP4z^9kW@ѵMn]+ÚU޽N-*{4CIoj`6^ezZ[#2)Oߴ/mgo /|Rvmc_9;mpKGk}yBTYۺ[ώ <P[t#xbyD2nW!ԼsL:NI./Cc&y-ǖڄoe;%ʴ`IY[xe7ෂyt衆UU#Ԭ-.-݄זVۤO!jK|M> <%T7yͥu/Z5+[9C"kĺoo^^OE;y'x._oa/c$~zօxnZlڤ6~+*(^ĖUZ=?UKk2Io 8 M&`C #ibtazH!,妡ikauo}c}o\^Z\ij[]Z Ž. };}K}UZۏ喱ŭ1 ;6RHz: 3\=o|7 X"h"[#,mx%'xN'D-x_S?n/گZ`;i%ri78- 杪A}/N>i-7?_-#M}>wM]m>x*+{KZ-+Pq^'7> υ#*Mߵ4[{fk? t-FUѴ+O+`n-=.f㾶o|>_mvMuM[PK9T..-<1xOŗ`kW<7u>o2|: |U_:$ƅ6sR}/*t{?Y~8t;UWmk#[~._kŲiz| x?bÛ[}Kmgr<1>J]ڤ=b-c@|Yec7? ux<,&W+ֳ[W&jljtO z:ωdIZk|FMԬ'曦X|Ɓ6>?ݻ>ug\jۏj_mux*UƿwV?؃<94xzvi!!~<6{K]k1YgΧGTt߉?njT?^ O'od$w4q"|Sk0zCjwxGWu~+*;&_>#6wkto@.>*f^u~§O`9x~H?j¿\ xC'_6>`O~եƏxwG^ ƚlt?A񅷇-:yE??|_ ]kid<8}7([s?>)?½źDž/odӵ KA;'Az躯m!}#~kx/P^%LJuxѾ"?SXgtƕ?m b_;~+CE\ LW k?[γR~_߇doWx߈~*C+}.]?g~_|wxWÿ|߇m'gMoi핦𽟂4o>rmc %n|6E44K^9cGV^9~%YIfoa>gὮjW6iE~=.c𕖍Ci O+o x _ ZI<{+Oa=0>xX'dէ|Wh> Ҿ'x¿ ` _|uNj-_*x{JE_ X5 ~kŹu$V/ƺ|w>%wkQYCV,'-1n_(Ϯ]YvÚ{_]x+z_ hsꚔi|U??|[o>/Z\hڧ-{MG'67{ዝ~|ðx[I]\<5េ@+KH?^uGϊnxe|;ou]տu F52xr 3v0^hG| wZV3{Q4]5<7Oۻ%ׁ' 5[.I4h䷷ 5Hx=m|x+©U_I.`|bQUhBL<G/i5_x . Xx_|ou/hZmFOh/Mt_ Czx3OЀ>sҴ '|)6pt[xg`GO^XjJE4xOM@(EjZemiO_ n~xRaYw|K:ǟjn> w-׋/4 Xi:冗࿇>C|r𿅾+&y߫iF!76ny5]5gj/mG?A|Xw~-k?` ?mۂh |7—3. <,4oO7$i4-OZC¿-46ZƧۯ^moQYo#"ÚOtBB4o^Zόt_{'D;]?lkSdž_Mki_c?63Ե>4ϊ|U>Xx:h ٟ"ŏͯoR ~Z]c~ ,ڍ~|Oo"?/#od,u *|;??/)?{%< k_ǧ߰xv}kq ?O j\|=l<'xNfh_mnc zX)]VU?z%|d/3W~, K? zݿ_@s["x+~3vkWj$#Rğ|{sG >_u/xNW^!~-|?nڴѓ@ӓqxCGncChަ5sGWQk%kBOզkKPͤE -;/m'㗄|9S{Y⸱ w=~Nү<3?5 }TѦwٛk>?ek~4[x;Ƕ.[ugK ӟ]w ?c[zÈtMF +Lд# yXִ9<]?JxgtύEƣo~^%t&M q G$z'3_A}MX^jz(|Q WCx55ݗ0K/q˯9cjZ^C7_~"ׇu}Fn<+ >im=4KҴK~9A7+B ~ ~ ]n4Yj_ 2TPHԴ*Ÿ ,m6^ 'b%uϏ?/~*?l|Axvt|=q[^iW~7 w^u /|56 |W՚M;eQoۿWY}y%CoUl5݌j kٔ'/%ܗ?ƚ(|E0~yEkQx+(Uxi~"--)mbئ]JqcIsք+jxb_ |Ad=2Pү3~x^.#]S MNO^5◈#4o٣zouK]GiH|M;𖭭 ?V/C6'+? h>ßVkCu[=@-^-í95Wᶗ <|%u~%~%x~7UOknߴ?|v:|>?=kƟ?gVxu}7 ~[xǟ>@vRS>|mJ.5 /7,m^Ok?#>&0~8oj@E^j?ơ>eN/oK˯)u=ֹhS֚jYn,w@?G|C>mtkiC^gAյGuin"Q[{]K\𯉯t)g< \~3IhߌO?e߉?d/xßߎM_O|0׾'jSA GӦ QҮ/ھdӮ%x$ C|oO|:W-O>$(=oڏ? {q?N ^ –^Ѿ|#}6i[?U]O|Q%zz~;¿guߋ,污OcX~_ i?O|?fxHƿK_7-|)> _o1'&w5 Izφ|(<> О/i_hϏS>>>.E~k:}Y Wa#|oxwk\~Z.h_ǍKo3׎W_wN &xV^2ҼSh_Ž.-.|f7l~~?5υ?o_cOƭk |s6K|:ׯ>3f_ !K]?&]y>,Ѕ?hpk}{\ڳg?¿ګ4| V^9x^ ]Ǐw-;:"τ4_M; xƫ}cGGgm c]/1?qW|iA> | iǞo)jZ թ^0Ц7O|w |Yo*x¿sÿm/s[Y~=Ku??i?4K)v+1O?oڛF}S&DB_' ~u{omg o 6C_^]scN6|I/ox?Ǐٛχ xK+u/|v,vg8+ G~17 itt>i?> Y;/ pWSI(i?`v]&O~ß4|..!Ig'¸2߄^ uٴf Exgß+7MƱh=xxuo(?ⲏH?? `!kOۧ[=[*Ěmƞz+ŤX4]c? S A׈+xU_?+KjOxźׅ<s sZ-Wk^> }65}xR *Wÿo7|kQmZЗk <9-/эTI_| iQzO"Y~,|S[\״O]irѿ?ox[t-ğGMZO|<|Cysodv + ; u\|Q]7_??-gƣcoͯ[# vQ|Ey௎`k?+C\~ޟa :t/٣YߵmJѾ<|'6>x_T6?ψ~,xֻ2м-xƖ_3㏏ߵEKjA'|}şoϫW?aM<7I:e3o |w&/M_ۇOS^ 9k|Oռ!= Lw<GMf|<>i<3/{QW~ hZUؿßaogt3c/xN?|KxSk+þ&Ğ/İ -PbE|%'oԵ?>3~x^.#]S MNO^5◈#4o٣zouK]GiH|M;𖭭 ?V/C6''&|<gċ+߆7G>3 'Z?_i<[?}]Zg~?jo7^ ~ XE.W2x!<)_㿉> koI ~~^o7E-c\ߋ 2<i_Ïx3RxG_u_QEۏ #if~o8mm5ÿO~!iZw xeMqL4]_?1♿fxF$jז?|}D^-v.?>(i-3?_ŤjZemiO_ n~xRaYw|K:ǟjn> w-׋/4 Xi:冗࿇>C|r𿅾+&y߫iF!76ny5]5gj/mG?A|Xw~-k?` ?mۂh |7—3. <,4oO7$i4-OZC¿-46ZƧۯ^moQYo#"ÚOtBB4o^#_\kWzG~3Yb躦N^'Iᴴ 9u]U>~ KsGƟMRoh>"m?Oo"ֵ⋏x*eᴿ|mڔOSk.cq~֤r]kB[е]w]<1/> A2{H + . K}]i DŽzt_ nX_Gn4;9N &~m_x Qodɪ|k}̒x^CXKG"|A1) #ط4/>bӴ  |!_>/max6#u_ _-b/7/W=B_ǟ#^gi ͡|@վ7vi].ݟy7u[#\'ڎOiO-<_~`۽#ZFrx_ž 12/7> :úud/-CG_um^cPF׏7}wEg[~[+ϊo >k]Rz~H}ig|C,>2xwIЯ|5o ״(PE|>' nk3CN񶟮xRZ'|C~5뺿mO? S*m#|KaKhG_7[SvUk¾>:Tnό|;14ω-_1~#| о~K Ik/#! =?W?¿xOQo(ߦ_oۡir>&EφOE\\imƼދ^j>x3-MGZV[>6KoH51ZhYxEMƣM|;š?EtZ}Ko (]|xxL̞ݴztRZ|m𯅾6XV7?[|!$> YNJ?o"þ:𿇾%x4~(A _5Xh9Fn'B>ڛ|<>"o\gƯ[,u \Dε v7}cJk׳xS:ڤir⍗^<3Zc}p-eQ!|=^~1?g5sUc|DvJ[_SL- xƿJ9[1OK&)wK&|SR GG| 7!үtC~< +~xKB3J?bM]Λi?(-GZfä_ S':IJ4,C_Kqe_j࡟ZFiZߌn~7PGh (>C̿ |_Jm|G¾&_QZ_no^!֯/o5ߋLJjz׍>-GcY"Nh>B|o<-{.$]SU?ob>o(귺FO? oCWLҞ[xƾ* SWzG'G 7⿅<gcO>)ke^osj)s|uχt럃>ɨ^[k#$ơ51g(oh=#?9lW2 CU7z|ֺ6_ǞǰXϊ y/rX|d_kͯhP|Os/:׮gֆm?\>=OZ%m"kO_u;>x|TG8K)uk~>&=?o<;Z,|}:e敨XWo~ ?; Z|=i|fga-C0.xOKӿf ~}~5MS!߲/QMпfٷB^|M& h1᫉tۍyux @ǁP|6g[:|mؗ9C+,k^%~4B>7+yc2$2⛍G3q( ?o|H~.hz7ůIxn֪j:f~+MO]so ow~mGR/ xpĞݴztRZ|m𯅾6XV7?[|!$> YӼkd/ ~2D?jŚph/5 ]OmxxLs/|go ~oG_|;%>/~>5g-x@gۮxj 7uVN3WĽ^ž9<~ xK78<l&xJQ"m/-O wzK?&뚭>  e'#Z~P~ߟ~_j)?jOg]/7WxGRtZ^h֙}g;/+_MN>C|d= k~w@>nVÞ"6W|],wNqyRKX^ { K{Umwi uOa,W'qhuY|_|ox_nw?ixqڏuoo4#]7PMKIi mM> h .]3Wr٭~ݺ熮"spZa_Oo>|K5<)MR4|SySFgt~m-1i8~˖(w?Ŀj޹k>"q\-/)^ W_^%}zŭao'k~އr|g֓|>K))q֣@WF닿WĿ B%_~ƟG&|CHM4tWɣYZg_x-óxV/|)}Kxx!𯌥 x/{Pόzt#]ִ-xx~7WG]KK#Ӵ  |!_>/max6#u_ _-b/7/W=B_ǟ#^gi ͡|@վ7vi].ݟy7u[#\'ڎOiO-<_~`۽#ZFrx_ž 12/7> :úud/-CG_um^cPF׏7}wEg[~[+ϊo >k]Rz~H}ig|C,>2xwIЯ|5o ״(PE|>' nk3CN񶟮xRZ'|C~5뺿mO? S*m#|KaKhG_7[SvUk¾>k2J,u+xw7O⟂"h|Z~_6n-||>3|hyqk`@<'߳pw?>?W?¿xOQo(ߦ_oۡir>&EφOE\\imƼދ^j>x3-MGZV[>6KoH51ZhYxEMƣMgi~C?~$k?4=$6W|],wNqyRKX^ { K{Umwi uOa,|'| ?5~џ&x_~:><[D~ؚOÿa#UNM~/xy43W<>~ߵsGǏx ~>hw:f߅.|p)4>4h?xe!aG8}RFOۃ?^z>>O )n> kzgûA|eog?;֟]/L|$a]n-W%>\ˬYuuURšeo[~5%WηZ!zY6K z]߇/i7䲟—]j:>o {j?||Mo_|K"_ ?ٚWix~m.?tIGN<5ql=Ŭ~>F5 i?i>)L Uk*_^n}מ$??Z᷄~5h>g ]GW?wҞu+xo_~ _i~Ÿ n4&/5_ڶm_xUqҮ|c㏋>K,?6ٴ/|n׺"K5_۳/CwxgkXxO٣iy?{5,w%O:_m |/0">í z}hi6SDou V&wW_ý7|]wMx㏉tV1ism|skfqxʳbW>Mc^iZ{~࿉SSM2 OKů֚gov."<-c ;n6I2 SC{~Xj tg%%`ifC2 O //֡x:g쿢\[E~;%ğ~%Ҟ _7^!'ZJci MƏG.sjv~ΫG[|AEj-X$xkV{{hg#E47L,?ş7➽ujA]hi?mAn|57>)&kH[O:>=V#~"Ooa 6G|F?mxyt;&ESSHm/^ޑ?^> x'%ӣ- -{ԧϊnOx~XKo ?|-YMS_:7V.Oo.">_CN~!t7N]SP<9?~hYρ-DK?[ӭmt/M[>x猾7)i6?7k_Omд s@xx#@ѿ /: JDŽ3V~3.|,~|X_&u ~ѿG č;NyR>0ߍ/i xjK >?w/ˮj:d뺎(7/x#YsS#h-xNo\_<-⍟ĹEsG#߇Y>O}?į],z-OS_tO4~. NOԭn/gOhu惨}h E+? ƙu_<-SO|"_O;/Gkve/~:O4|TѼ?aii>t~Ixz_ x1ᮡ]xk{ž+фZ| ^#Esh/]|wo|]h1$s9ᆝiz?N|E>'o_k]VW?~>2޷jW!k-S>h>}*᎙3״)4O<;+Z]Ωj:{kww:nICco[5٠otH>x2x|#ߊz֍|^u}~"o>_}[þ@±C=T'|Ci%h-Ml(|`OOt#ɴxjzF{L~@xNĶ_.fokRG֛>+=hXi:uMC$Qg>޴>k,aoNn$&{Aing=SL [Ūxc\Vk4Gxz}Gd ZW~Dzf~߳^ea{mk 4okSZ\1E>#7@n<5{'u_ |Zuυb_Zx^yOߍP:o|F9V2k)|c~`xkRXI8|?6W}^]sQl']uGi |G#ψOÚMOS&&' #w^1s^G<5\/,?ni77Eu/Η{~$xH@9?+=KƛGlt?P_fQ]?HA4m;V_íRCxGznúZ#|c=/|}n3ÿ EsG#߇Y>O}?į],z-OS_tO4~. NOԭn/gOhu惨}h E+? ƙu_<-SO|"_O;/Gkve/~:O4|TѼ?aii>t~Ixz_ x1ᮡ]xk{ž+фZ| ^#Esh/]|wo|]h1$s9ᆝiz?N|E>'o_k]VW?~>2޷jW!k-S>h>}*᎙3״)4O<;+Z]Ωj:{kww:nICco[5٠otH>x2x|#ߊz֍|^u}~"o>_}[þ@±C=T'|Ci%h-Ml(|`OOt#ɴxjzF{L~@xNĶ_.fokRG֛>+=hXi:uMC$Qg>޴>k,aoNn$&{Aing=SL [Ūxc\Vk4Gxz}Gd ZW~Dzf~߳^ea{mk 4okSZ\1E>#7@n<5{'u_ |Zuυb_Zx^yOߍP:o|F9V2k)|c~`xkRXI8|?6W}^]sQl']uGi |G#ψOÚMOS&&' #w^1s^G<5\/,?ni77Eu/Η{~$xH@+i=!]Ŀg<6=ESI,3LVx K ߈K|cL;asU|A+,7Fڼ ? 좍Ŀngm50i˟ڧ"|Q'~𷌿koiZ͗ȷzu!.5煵v |I⏄Wkie3HaNӬ_]i&O75 :M'š]Ν6 4K;<7Y~54|xSz0Oo!v?47^.mE\[O=mOTдK?6u20ӼY/GψxGc^|g~/xWuGW^_mJ-ex X|14z&cG|#{wqx K5 GT?omnPU> |"յԬ|Ym<5|=f4WGO|bτ|O^ѵO Ү۟7>o\5_-Kxw]V?h~'y?|dtm#ľ#mſ߉ìܦVC曫|B h4fG]􇽸kI7|(okWW4xHK?c؇NP'7 ~_R/!M^xGǿ :k'T.x{Ğÿ 4^,gևq%-ֶ Ğ$ot(->2|m,'ikxO k mfO =¿ TU(LӴk,/m-~>#]fjkK֓f5Ap-dž~./<_B9KXBOk)^ M/;j^2Mc:/ul xjK >?w/ˮj:d뺎(7/x#YsSlZk|GJ~ oG ^4S7NJO` ??lo_s~5|f/w!M xO3C 3#<kuuomK8g F7׌!F=bUo,u#)/wxŇ/W;#Ğ6W|I=W!uoڰ|e7.~/jF\oS_2M]j6_i6f>ȟ֣mo_,xZ'>W.M=K~/'xyjVpA3X'4m:Am>m"~\Lүמ )'>_Os٧#5t ;N?|]uw>*h44 iv:twχ?$Ӽ=/D e?PҮ~5O=O-? /|n\GZYx]mqos>;>왦|k OOs3º7~ɺd@']x➃⯆&Ꮞݧ[2ՠuMX|14z&cG|#{wqx K5 GT?omnPU> |"յԬ|Ym<5|=f4WGO|bτ|O^ѵO Ү۟7>o\5_-Kxw]V?h~'y?|dtm#ľ#mſ߉ìܦVC曫|B h4fG]􇽸kI7|(okWW4xHK?c؇NP'7 ~_R/!M^xGǿ :k'T.x{Ğÿ 4^,gևq%-ֶ Ğ$ot(->2|m,'ikxO k mfO =¿ TU(LӴk,/m-~>#]fjkK֓f5Apτ1i >i76\_QZxwM? ĉx+o_ntmk]_~^ot[ؼ.\xwҾ麗@[/x},o6>/j>'toN|=o_#w2Ⱥ4IWJi~ i 4 xO{+o/EmWO?4jWz+?]oCtv |۬? ὾a5΁zŚ_x^$.of׭Qjaῄ$wa>⯎:&c=0o> V -3'oj4%#W+3T< Y\7K?B.5OV~;5i6~`յFK™|OS4>|;w𽦓6~̚rwCKD{DuǠK]CO8D͢> k<E|5<~e=>!zBqM7s<1>3xkŸ.4ˋ[߷zcsuOO<=&e #HQx6~!G Oxw%ĞM/ I,7M*)>a_Gg>j#Qy@ Z>x?ǟ yͶi0hwƓa{_Z]iw_ ? lCw~-v{◇>(B8_~)_w/8_ωm?.~+^4'>.|b_K۷߅<'TπhtmP\K|XK-o7=ޝkWv_Ck& +.iz|):?f5tKSO[Wo'"<4|EagXFjwxOKsi MzT_>5Kqk) |7V~y k:}:}Ļ :O;J7Me? K&hh~1jsmX.{wݺZK|YE힯?NcMhԤoxkV{~`z6& Ku΍|^42kc_K N|{KWÝ7R߂(e/f'GnχWmrYF> ? Q/þC|um;ZFO|࿏`xmEMjiJEgߋmnO[u7Z&2׼7Ğ.l'&jV<?# ;˗}apX~ÿZeƩ6}Fu:x/ٜ8ڶ~>S?~}~xχ|NfٓC<;Chz_|Y:oa^h.x}|+x_ǍOvAos ?_n>"xsÿ.$LjjoxbMejiW@O[ ._/g;? 5Qχ|F"O? |d?W~2rv7wO^?Z {CBFo Ծ-s F}zό|sR@>qxW:l?c~"׼"dkZ/g|Ki>>_.z~:ĭq'@.HԾ,j|^ԥM7NԵ}RX/ Xaiz5qcӿH4VK>~j:n)~' CY݌g Wz?hvy>"},~#|T5; PҼ'wṴx{*/%5~EtE~¾?tk?K>]džvħtowO@`2M|o)Կ.OumO-zwMuY~?<_::mti4H~4x{?9ue{xTnz-%>,W_Z֧jR7<5|=o?g0Gݏ=NGoUV⿆%:F־/kUޙ5qj/? }'Oվ %LJ|+Λxo^JE |fk}7FT+9gw{,DaF Ma:#Mt>_ǰ t,?a A-2Tmemw㾋X^:Ɲcn?@dKjҋ_X~_k nXi."ե}sHƧ'8.=>8<+֍\[Uq + 7x\ |h./ooCw~YEΒo~ׇ=>Lx#@3"/Eq/7<9߈xc_71&ߵ4XK`S-?/S~@mG ?Śf"x{]?'m0]s|7ng\Gc ;͜t|SS m508tuM;~%xExD!ю,_or|)|.58#|]}O7K/uZO 6<\K|XK-o7=ޝkWv_Ck& +.iz|):?f5tKSO[Wo'"<4|EagXFjwxOKsi MzT_>5Kqk) |7V~y k:}:}Ļ :O;J7Me? K&hh~1jsmX.{wݺZK|YE힯?NcMhԤoxkV{~`z6& Ku΍|^42kc_K N|{KWÝ7R߂(e/f'GnχWmrYF> ? Q/þC|um;ZFO|࿏`xmEMjiJEgߋmnO[u7Z&2׼7Ğ.l'&jV<?# ;˗}apX~ÿZeƩ6}Fu:x/ٜ>?:_%Cum|Dei `߆rh~K.hiivy[m?xJ=?F]M#1SfW:w>))ↁ6qxW:l?c~"׼"dkZ/g|Ki>>_.z~:ĭq'@.HԾ,j|^ԥM7NԵ}RX/ Xaiz5qcӿH4VK>~j:n)~' CY݌g Wz?hvy>"},~#|T5; PҼ'wṴx{*/%5~EtE~¾?tk?K>]džvħtowO@>@ |u|#ANyO~=k<:׵-׌h}ZC=Komρ-ϊ|ax υ^#7|3æ|!7F@G#S{oVWljuKۿׯR]Cϊ/l%jpoF#xsZs4}<]3Ѵ|f7%_o>+o_ntmk]_~^ot[ؼ.\xwҾ麗@[/x},o6>/j>'toN|=o_#w2Ⱥ4IWJi~ i 4 xO{+o/EmWO?4jWz+?]oCtv |۬? ὾a5΁zŚ_x^$.of׭Qjaῄ$wa>⯎:&c=0o> V -3'oj4%#W+3T< Y\7K?B.5OV~;5i6~`յFK™|OS4>|;w𽦓6~̚rwCKD{DuǠK]COԾ|imfO}?sĞӤ0G ƝxcNӴe<+F&Kgմx~koO]wJEw˯s(>$xv;#^⏋2(?~im5;AlbOخɧ?> YOO+*m+uOiږ㿈@,x[ӛ>wi3iRxs෈_WAy.#`$;,m,w}e[|jդOXm_hMBdčN_xs|._:=ooƾhzo7fZ_>'._tw߀}2{[!:+ j z{[x+/x;nj,ZUI>|"w^4A>8~hծ4OѬniI54%pt ?^_ڜ2_ f;Y)sN7@ژ;[P7 &:s4w5~K~%|J:iv{^5?|Jgڌ[>/^~+y=ߊ4)/6M3S-./_+!t۝=ߎߴ nIJLu_Z[ߌ^:A}O-m<}~ɚ7][aMgZo㯁5?jW#R7/@᫽]B]kEeIk=k$:3+Ne_؋o"kz_{[o_+4Y> i^Cw@'shPivϣx' ?i,O5o2Q78ev:l[i?|O4 \g|;zUxZqI'S )Ah{ +_| e{ h𽴚{Ñ]O#w5K|o߂_V=n]Ʒ/⏈t/( F_H=V))ڞ&Wf{LG-_?m ~,x7vlџsK|vKᏁ߰5##(84mE|"G .SX|Ku^‘c]@x UkǾW?7C/|O"/m/KmJ??G Oף`Ok6(g ??TH_ax,>xKR= /HG>.ofWmo{s{kxZ,ԼC{ma'~Z}_Z6(8<{H w24%>+>kC6^Լ%v0Z*=>@|go]cJPp ~%m'~У|)nB 7x;hW}3S. o4?d:ߍ?(vo |5OZWW|&u7➪> }QgO'FS>%9ɦjzp~_k{.s: ޟ'.5χ?-!q/Y.b&|m'HD,ks¾2R~ -|Maa5OGGt[?Xwyi~$U/w/4Am&-Ϋr?3K]t}S]mj~.ԮFko_2IsL9xw# lI' \R?oMjJ>#k7z0/jNa4+7Amcrm-zjMO$׈~/xoFZ̷_ѩ ]#B}?G>|IauiIVx+^#6^|Uinm>|^O]i\`RaC#N<1qi?|2xH|%w#|d2`-7zjr'O fcC:/j`S]oCPGqK&6\]4C=ߛ-m/(z^K׵z~$I(j1l{5~(> xĿ44O_ tnt~;~6GA$E/&`ź6.%g';ᯄNj~ xao<7?xwTc/{Av#B~$D4 KSu|#agk<9p :^9~5[Y 𽦩HwHgK@./4 6ğ OnF-[؛þ$ҥ~8кޣ[|g>&ikZ.k-MOڕԭ|M P 4xѮ~i>o7?$ᵜ_g_\WmfQmWIl /x ߳zv+ϊm>/MMxO1wZռ'],ڶpxx<[ F|Ka_ L|7|IauiIVx+^#6^|Uinm>|^O]i\`RaC#N<1qi?|2xH|%w3OjWΏV1&n~(x~(}xsI1qq{~[QY=>%mKFOO~">!xſGKέ|b?7?= |=6|qi¶+jZoƟzSx[◉u/xwR.3G<)m=ե,΅h~1hZm-K=[4tƹUɨ]|Ys~|#<&xs\tnlY zM;IE{v M M㉟B$>+h6'3ؑ?g-ާ+OPz|U6aⵆ]#zOj`>F៌zsxk_jWp뚟-$?g|Nɥc !Fe9FÞaqowA/n3yi>w6h6H 2Y>i^:Xo^𿎼:G= 9/-&j9ž~ YG=NBoÿ|G]Gĝ?|c_cQx Ӽ%Y~=|ZWo?-e!M~о<񟌾h^ u8x?j>#~~?}tZvs?G^ÿ cxKY]fx 1S%~#EZo|J|Ct>!AGxT⋹>#iA|~(}x`iŶoW > o}kZ/߷_+?j~ z>hZƩ[  jO x6n'[zu?g߁>Tk|6%8[Z|Xߊ-ojik?e_>"ľ&\ď?#|qkpghsJu9>;ix.J? 48C/?m)_F76">|?^aY0x#ik/;B 9ſcۗڏßYM&|q׼'?xDXγaLUáCĽ'ǿ~-mk|axd?( _ ~6%?$GR~K/ˠh>'Mx 9u[۴6QgϑP4.K=SNӥoctm$Ե+ 6Q;[q$PHo?ߍ5=G_^ Ծ!|Q>u/ Ѵuc^ 5,4:j{Zi?<1O~𶙭jzƊ73`2O3Mm"FYu kf ~F񿇵m?^/7Cs͠e{[-4h.XdUֵ}\i6Zy5]閺ơl`rYE;__HiXy>ok@X_R0#Y5|iŶoW > o}kZ/߷_+?j~ z>hZƩ[  jO x61KVKůx_5 8xPQxǞ;%5ׅto_ 'O>iIukCkc@~#j>uxJ-F9-ts"6 -;/֦o>Ž U4_O߂VicƟ{X>yx0? k"~YŚNCþ4mC''z|*||[/Ɵ-jh/ \\^VmV;i꺏uRѼgS=GS񟈴ψ^3o"R:&j_M1O_ŸMk|AZ~ǿj? $hZ-T]K^Դx(!񥾝|I/-kZTw:狾 QO [Ouiek>'⮱siZ7ƟZ5֭KsOV+]xt92j_dz>_ɞ kp[4`s|H:ޓi}kN|Q:]' j>*Sxg %;O- $O/w+}AMxaHw;=pho?g?<U: I!A|ig$gx#:<xLg>4j,WA'ux4U/îxᯉ4K٨|[3m8[ s(*ž 𥖡fH2K) oxW>O_躵#<1 O u(nF gM'twVLoχ G=>'~4i?'~ Լsٟῆ?g- 7?:/clmHk\~>gOύ@.Ǐz\ -ÿQoڲOYwZţ|./ 'Z|@}Y ZY6>$xk?o>mO_~|uuoxs@ltIkO+Zx|3|YoMS-CৃX~ykhɯ ߋNŞ 𮓬xx $iiB?k?5-ӟ@xX-|ASM7';x77;?^^1Ҿ$]ad++g??0RG}>!пdVØE[s_Oɢ^ߏ|3[|A€w-#N}kZҤӼW|<]g*xR{K+_' Y<77u JѾ4bѭm?[z i_sīP'?=5F?x'LXݢ٦oۛAOZv.ž< 9QT>?ąI/߇}W mmOg/"x[OV_go}mk GkGՖ+_|9'č'?iuگ5?ZIObWվ_tCMKF@ ?Co:ž&skOO<#I)]_\fJӬ/_~мEƿcLv[GǠt  ? /VW^jm4ߵ0hgӵK^1ߎ':c?|/"][ϟr7_™-7-ORGx{V,>.O+z]yL9_.-/5OLlw}ƚElhkGizGsw7߳o H>-|ZQU~ ZB _/!t6 <_Vx CCMcB5O XxWRxkx'?2Ce¯01xQ77#6Xv8Öt_iZW$_ œ|P#oWtO=<'U}k?G=[W⵽=Fe^zoڏt~}!^x!|Mþ>⟊Ɨbr]kW#Jҭ> |kݗ}3Go<obZO[6_IuxwƟ^M|dO_O׾i/|?ՋEO<񍇉4sCE{SÞMዋ<*'=WQ.jZ7*|G~3 ~-@">*]GDumSa )/S鴍{㏈4KOM]g_ R~4e_ʛKxú%>4Ӵ:ŭkJN^G\w ?' 4/ͯ5?>-&{ wۻ }sw+N+}SA6zGuiMb)eUz+o xOzm^5՞vI:i3_eVk?Hyứ;m'd6{8 g5 Ui_ uv!/g6ߋ$TU?5+ kTO>0|eGRӴ-[Y.v}j|Sw+e~Zpq3&d]9ikMt[VD9~&ռh xSறy}guZ@o=6φm_jj-Ų|Tw1[_ ^j7x>߱aa ~8|_#OZN.z|9'>|:ng(<%O~]|,o@дS?~}x;Q77#6Xʹv+񆋮ZW$7ֵ ; ?Ǧ֚>Q߱LOo]>2rû/_ossWsLqxHeouo쏌QBvw I~ 2|Od[y|G)z'o~ǟ6-uOԓxQ>'Y^}S NWAe;0k/|&dY>>h? 4O g?_ Y>&Yl_E x]ռc|gU*mO/YCi&gؿ?Nzׁ+G<#oѵOC𿏼E(x{vV(PV/Eu@ڇ{-kLjZ+P~_fˡx#¾ 'i|cSW|%xG^|9J7T@5 Xj/?+ƒEya]Mv81?N~ xSui~U4[GT-.u_ Zgĕv|}SGΥ<~=Mg f-m_ eJIdjUc4!qf[T/tkּ-7g^1@H~?>?x~>o~~~/% Gi}|fƥO?-4v9:Júo<[߁^8G߅VyF/}1*j^u-#RZ[55}O P)?UZ޽jGm `lY[述v|bO7æm_ևX <+ejZԿIiz~Zǃ #7K٣v67񮟮w jU|9m{j/3(>?|E= xU|M ~˿ uio+YIOIkYӮ<@u|k7 |kѿhhm _U t/'ޡ~_i5~ö3Ix $Z]s|{ :/M67ğ ÿc~2~–^&mk_+Du?:O!" xwf_Zm ߂b&Mo#%ַ/ %!j=WAдkNKoZ?τcxGދ?ɫiYɫ/7 O?gh_;υ|{,W =cl4Yjz?E ?»?\>>6]Of4ӼEceNRa_$ n/ZGok5 ־+: ^'(ؒQ /x]Y2|d>$xg~ |Kִo_G7 ˩i?m⟎%> [=*qi~Ɵ=.0ǚR?h/B)l u)l\C6lZqsR;UԼ- x@4/k?6~ дOn\k~2x,u-3 7EnB M -%ci}3F+Cw<=Gs>Y}_va-2o xvK%kgwO7:?4xǮ'DtMk&[߉bW5;Rռ?2a[AᅡS]+cI照Pr_U w ;ҴԴaxY7>+]fWEj^ Vz-XHS'5Mv>4mO |VQ-d^ZghxUՠ㖳O޹_Y_$#|m;\T4/tڞ$w<~hz$W7ƣwo5i:OZ爮cE|Mos]oſ/, گNoZDëOiU4B[(]zg_Kt ko4 }hÈ~9ê{ohc–@ƓTExōmR(D)|?֑o^Uxlu[~ȟ E7?Z4Z? Ā)bP,[.z/7G7Tֵ-:+[ˤX]B|M_ AUwRW+j-Ų|Tw1[_ ^j7x>߱aa ~8|_#OZN.z|9'>|:ng(<%O~]|,o@дS?~}x;Q77#6Xʹv+񆋮ZW$nos/b#ON|uxAIJjωh#αsacasZAzt#{}}}}KO|E!:mrY5= Z{[-[CGԭt)?Onġh76eּ xW+~о'~ дOn\k~2x,u-3 7EnB M -%ci}3F+Cw<=Gs>Y}_va-2o xvK%kgwO7:?4xǮ'DtMk&[߉bW5;Rռ?2a[AᅡS]+cI照Pr_U w ;ҴԴaxY7>+]fWEj^ Vz-XHS'5Mv>4mO |VQ-d^ZghxUՠ㖳O޹_Y_$#|m;\T4/tڞ$w<~hz$W7ƣwo5i:OZ爮cE|Mos]oſ/, گNoZDëOiU4B[(n#c/_J}{֟7,Ӽ'Q%:֯mz.Kt߈ =O?ީGyķ^)״ه^S-wɡx"VW:D^Pе-[ t)_[ _~iRX7QӴҠӴռs^iZ_>6o94Gß]WV{y_ .>׀8E_>('>i _Yt+?kp_u{ ǀ{Ps'|%ԭ.G'C=׍繵ԭ>8~߿^jZVA<'?]'%@]jk[}GdooYχ~#yf jxR?l7o~ў?:׃Z݌yVp7!hZRmwFӮܺxVw|.ȯ-o_PMUw/k.cym/5hh 6iw c7͗į_6Mx6'ai<6IZ7wg\YjiZ:/SO O6<7^)ݼӵ>>Ad\ַ3zG/ "~+yxKſcx/O~3_~Px{Z~|?<'*<+x 9W> |/m~x'7>}Q[R-l .:FO?Y}~5mKKj燼/k7N#Q. ֵO/};g1uG~ZtkJǾ"!k&~,'qo$E z&<3}m6`,?>ֶW?zZU]&Q/tWI}oi?yEVߥ+i:K6^Pav5[#L-lGRV17äM4YYG>jlf= ןWo<_4o&gToONK*ލ=淡 6-_K{MBѥG!Wo*]u>jpڝl-:xöz.wM6ms oo,'E{sg/woO?<;=C Wqó떾 ,_K= >$|/bd"M*m?->![$*m+]Zi %I+JO\$=5.a>BLeߋ߰4XٛhN?(யo |MY|9x]{-:IԭnjڗkeMut>22xAȵcj__?mVמ <=}sY:u֡ơE/wh2ᇄg x7I|/Ro/gU 7&9xjhLjgﯵ KPD'n'/|X6'؛jl^g:Ew^%qE猼fSngLWH~? !5]o07}[xM'\Ե ?αxOOx^&|i?c "ÿqj4 F;|-~Qu_x0MYXZ㿆/ſ ˩,~˨i? PiS9կ4/~7[hz͜ K|#`z+Xw/_ nu}kz~"gEk l4|\,k:tyN :ڽ~} zֽxWH >^RjVx#OV?oߌ5-+MԎǂg.~ Ԯ]52|7,gÿS5hOkmi7?hkku-n}&#Oh~7j /)<2x>(tOx1c_1u&B/!Ьn<:E6FkokNN_ !:ZZ?_iw+|OG|^mVO7ÔttIt[ig:#Kx3;: ~-ΙCፌ%~Cuj߈a-n5=VĶ<i@ Njc,152½&M7X=W3C~ELJ~ Dl>'|hwm3ZޣV2` 1Pе-[ t)_[ _~iRX7QӴҠӴռs^iZ_>6o94Gß]WV{y_ .>׀8E_>('>i _Yt+?kp_u{ ǀ{Ps'|%ԭ.G'C=׍繵ԭ>8~߿^jZVA<'?]'%@]jk[}GdooYχ~#yf jxR?l7o~ў?:׃Z݌yVp7!hZRmwFӮܺxVw|.ȯ-o_PMUw/k.cym/5hh 6iw c7͗į_6Mx6'ai<6IZ7wg\YjiZ:/SO O6<7^)ݼӵ>>AdY<'!_oS״M#Iax oEl>5~Ox1c_1u&B/!Ьn<:E6FkokNN_ !:ZZ?_iw+|OG|^mVO7ÔttIt[ig:#Kx3;: ~-ΙCፌ%~Cuj߈a-n5=VĶ<i@ Njc,152½&M7X=W3C~ELJ~ Dl>'|hwm3ZޣV2` 1Pе-[ t)_[ _~iRX7QӴҠӴռs^iZ_>6o94Gß]WV{y_ .>׀8E_>('>i _Yt+?kp_u{ ǀ{Ps'|%ԭ.G'C=׍繵ԭ>8~߿^jZVA<'?]'%@]jk[}GdooYχ~#yf jxR?l7o~ў?:׃Z݌yVp7!hZRmwFӮܺxVw|.ȯ-o_PMUw/k.cym/5hh 6iw c7͗į_6Mx6'ai<6IZ7wg\YjiZ:/SO O6<7^)ݼӵ>>Ad#~?,Wzƍ-쩡i@7>>]~M8_Ix?$_9[ÿ߇/u}[5kG/YWIy∦WhP?47 Aύ W+ K(x. 5t!]| <'5^m>otkx⎝H}_|A:FzI!jteh{%mܮav!gހ&/n.}4ύ/ D+iAkM%'|IR4~(6>4 ?jQO6vZf \ϧi;g|u^Ѿ*xN44BK6z5qƣæ]þ'+E6vN|U?h+2Yỏ{ 4k;ÿ KᏀ"x_ &|#}]rZŸ>.|'xI|G|{4Ao^sskQjVj_yiIot)K'zVh;=Ƶeko|f GDo]4 o[>bo 6z..[Ol4]\u?knO 巂6CKakV >-AE՟ß6w#\橪^_x vRԮSa-|;kSurִ|A?|W?ϊWzΝo? w[ > 4 )xƟ akU{hO_#LN.u n O]<u>d gm+ /5^D.~߳մg¾+4m!mtMG_eMLo!֑wŷiM ^hl./A[_\jVQHu?N{i> %z |9"W!ϧj9}߶a^NJ?i|Gx HX/'KE4#tGPqj |ng1\XZYEuu(_Ek] ߄o]'P}]>CH E45;`xS>|x 2߶/4humfic_}9_u~TS5顼@iWKqKP_^5_h-ulkme)˽3C߅&O'Oڍ4wq]xZaoWE|)?4j};N?aHE-߅<'52趾?a_x-?u3AXOOt |Kl|y^@#7vno< I#W<;x'ŶڎC|qneԿf~wT[wSK K'Ծ!|B&ou'm (4^ְm3RKqjP^AV>|*t}~+ ZI4x|Z]yB_r\x%Λa[FZA~妋a'xA/L / ZVx:C?gWՕ,,6ח -X. EV~܍r?O0ky5ۭKRM|o|SO )]:u3]j~o$4+j0.4!|%~iVڥ=`2 ;H@+io~ 0_FxH׼#x?h&3~Vhr'o垣 XѴ5}4;1xZGˣC/I 4/x#Go|[|veqYE!4 O:KYMė_w>;x|1ċ_~>xw[ί~_zc(k!7#`)/(KQgU84~ؾ,ѡeg+(_~95MR[O\צ__I\]-Dž/C7g~ x5ɭ.w~>5g>j7P\x\zeukm^xtˢw|{xxItϊc>K=?]|7q/a{xw^h*$.4i^$M_j: URt|g5SGnM,o<\.u/xR (Ž֌1<+S_\9xOZυI-ƳyCm{{|Fn4 [\EQ%i&?\ӼA޽iw5犴M ˍs?<o:mofiuW-]{Lo ,t2x,'iZf^#_kVVGk?>xtOx_@za&@grfEuS8:^^[x+d?<ֵ`.(t]Y9sgr5>?_j n-J6)i{Núֻ/|e?|?|([Xi-kM7e{|}Α^LwcΩwyi忎_j@Қi}[jv44"PiΟ῎_ٓ_aoMhhv7:K-#^UMG=[Aȟkz+cFDuT4y?  i. |[y&/мE6io OƥeX1?-g6]~נh?ß/ ovo×:m~x~+GTUxDSG+?@4u k^zgx+ŅZGQPVE]MEu KUٓtCB67ĺ5< GNh>> #KWw$~?E:4|=AyWP;D3o@B7Qώgix{Pm45^>$)`?[OYh#f ljl=NOQ-G.W,|MbFYal? ]X5K)o=s^ω|D&qtXi%%_XΏ&_OO^24? Rd^xR{$}Aq]sG@Uׅ{^('›;-OOgӴt3}׋:[/*lt,wIĽǚ5T柏?gNᗄ#\-oτ-'|Nq+OJU?omx_ᕯ_>,Y'4o &-z_'\hO4RVWo7{}߆7a/kZ7ĭ_᎗?`Zמ*4/?.5ϰ\w2\ſiq^Zhx[w41 |,𞕥i7?xz|OqYZ[0Bzv<=~M醏ß؛jM˦*;MA4O>뛓myym்lRkZՂ~-tQug͝ ccyj(]Ե+x7 i;Z1;]ma?6_0=O:F{3޳[:橧:@Of Jk+Xlm^? ӴCŦ:9|[×fO}<#4xJ $o:,{?WQ6i7m"|F~.Y>H[]QSC n|5|?2mpB?`x jſ(Wm?WRcOOiWfOk5|#7;6¾ t/_ߊCyT0KmC]BKӴCM_]F?>:i _@B%E?[;;׀tGCw5 xV_kЬ ;+O&t{ 6Nt i[O|V_94i=WO$mTKܿ?j/wfs]|597>Q|>weӬ'ľ |S!'%ݿO(Gm?ų[-닙5{O/2G {$}P>)x^EuO~~7/sCYӮ5vfua//W0旦.oK+fV[(Gw]jM_xfSH)$wu hj>iHch~>>!xO7G!wߵS,Mqk+m]/G:volGa|?>5i& wK?ovc\\'x(\ު5o-N=w/v^j"<-|KJ|S_Q]Iyl.I+ή kޡj <}0 twQ:|*> jv֗cOfM+KA+M?',o].7upn)oCUkuZtZ=΍>xí o/ᰞKk5)u;g6qj5]'MԵj_ .-_h_ ͭxB`5|UNpKfP_>{M*+_fi>7`3SKAw1Kĺdٓ|<{g; Ws߉mDgux36 w:nY{c~i>'^k7&^6^]|$wV^u x3H<g> _t-K`}.5yw˻ YA6^O Oee?.|1/ ~zAPWß3R3U'cxm/smLB!XO .:vr& zmχ_)E+t;I/ao|IEo OlE'l Ě-^&MQHAAT\ZJDw|(=Ҽ!>t~~*|f E >om{񆯬jڦC/Oxw D! ;m'@ђWvs?/@&u9|#?_%W]Z ~ qZi??RMOe{|2xHoc:O}|ra~)?|CGJ}[rxP|ax?sD-tυxo)~8el'Z?nJ]rY\iZ_); WIn5-Zxro4{ˋ½3k^/о-?ÿ#O ηgŝ⽇˝3V;Gw MgkϋrI I ޕv?[Xh~ ִMw^'ϋς4az 3>-WK? Y%]:ޫ\wڦqxߴgux36 w:nY{c~i>'^k7&^6^]|$wV^u x3H<g> _t-K`}.5yw˻ YA6^O Oee?.|1/ ~zAPWß3R3U'cxm/smLB!XO .:vr& zmχ_)E+t;I/ao|IEo OlE'l Ě-^&MQHAAT\ZJDw|(=Ҽ!>t~~*|f E >om{񆯬jڦC/Oxw D! ;m'@ђWvs?/@&u9|#?_%W]Z ~ qZi??RMOe{|2xHoc:O}|ra~)?|CGJ}[rxP|ax?sD-tυxo)~8el'Z?nJ]rY\iZ_); WIn5-Zxro4{ˋ½3k^/о-?ÿ#O ηgŝ⽇˝3V;Gw MgkϋrI I ޕv?[Xh~ ִMw^'ϋς4az 3>-WK? Y%]:ޫ\wڦqxߴgux36 w:nY{c~i>'^k7&^6^]|$wV^u x3H<g> _t-K`}.5yw˻ YA6^O Oee?.|1/ ~zAPWß3R3U'cxm/smLB!XO .:vr& zmχ_)E+t;I/ao|IEo OlE'l Ě-^&MQHAAT\ZJDw|(=Ҽ!>t~~*|f E >om{񆯬jڦC/Oxw D! ;m'@ђWvs?/@9_^ ǿa/x+~XG/Oχ464KY/t>Vko$3o~ @Mtּ&)ڽůښq|x|;k _ifOzm?lO=k7?k[/~|LӿkW|=K|x[ ;t?~:.EM' zu(/KOm[o_x;e/ h~̠ͪ4{ˋ½3k^/о-?ÿ#O ηgŝ⽇˝3V;Gw MgkϋrI I ޕv?[Xh~ ִMw^'ϋς4az 3>-WK? Y%]:ޫ\wڦqxߴgux36 w:nY{c~i>'^k7&^6^]|$wV^u x3H<g> _t-K`}.5yw˻ YA6^O Oee?.|1/ ~zAPWß3R3U'cxm/smLB!XO .:vr& zmχ_)E+t;I/ao|IEo OlE'l Ě-^&MQHAAT\ZJDw|(=Ҽ!>t~~*|f E >om{񆯬jڦC/Oxw D.nnOnOsoڋǑͬ <kWrtOOIeCi^&|`?0kkk:T@uK_OM&FWYr/x9-t~ӿ@*j=2?oO |E%OڗŞ{ejہv^Gk}Ε{x{zFh:~(D |AO M߇bմv׺l|QgPS־|%<[xmԾ?g _ ^[.ּM O kA_/ۣ⺖O}7_GSGO x+J<KO7g i>"v? u_Voknh_'gMBkU>>>#iڟ_=E7i uu_ju+x;9o,9z3a >O÷:bzNv(e|(Qkz xo|KYN|r|r䷾Ɨ sskfk-ÖV -?o[Y |PM~>.nnOnOsoڋǑͬ <kWrtOOIeCi^&|`?0kkk:T@uK_OM&FWYr/x9-t~ӿ@*j=2?oO |E%OڗŞ{ejہv^Gk}Ε{x{zFh:~(D |AO M߇bմv׺l|QgPS־|%<[xmԾ?g _ ^[.ּM O kA_/ۣ⺖O}7_GSGO x+J<KO7g i>"v? u_Voknh_'gMBkU>>>#iڟ_=E7x10/߄d ~૽CQ_UfxRc_<m/Pϣ';si/w o[2/Zw‹vYǁ|Vľ%/(+ ~K{y^(M TKs?mw꺬_!L^_l-h1m ],|B~(]ĝ?Ş*s?׊ymg/ق߆7"jP񖱭M0 ũxPռ!~ t_^6GUԵd:W!|1u/ M̿8hM&\ዿ~ɀii:u]?OxFwÚEaſ^׊?hFhWGa_~|t ? 'í; |m*[&_xW! Ҭ,~5f|d&SR>_ kt_xC/xKӼJ/eyOVGiυ|asD|0wo'!]EKS4cơ/ 3>/<kNj^>uk1ľ~_ 5_FƝcM),?cؒ6qGƏ4VQEkh;` 7z}꺧J~/;m+XiiGGӯ|1z|[\h|Z?}Ö?jƣ GMPh >i uu_ju+x;9o,9z3a >O÷:bzNv(e|(Qkz xo|KYN|r|r䷾Ɨ sskfk-ÖV -?o[Y |PM~>.nnOnOsoڋǑͬ <kWrtOOIeCi^&|`?0kkk:T@uK_OM&FWYr/x9-t~ӿ@*j=2?oO |E%OڗŞ{ejہv^Gk}Ε{x{zFh:~(D |AO M߇>7~'> <}u}Ii}r:z' .Ne_ Ltbï!O}{ c(iAM$%Ox];:xk#A]zaϋ+JN~!eMn>bմv׺l|QgPS־|%<[xmԾ?g _ ^[.ּM O kA_/ۣ⺖O}7_GSGO x+J<KO7g i>"v? u_Voknh_'gMBkU>>>#iڟ_=E7x10/߄d ~૽CQ_UfxRc_<m/Pϣ';si/w o[2/Zw‹vYǁ|Vľ%/(+ ~K{y^(M TKs?mw꺬_!L^_l-h1m ],|B~(]ĝ?Ş*s?׊ymg/ق߆7"jP񖱭M0 ũxPռ!~ t_^6GUԵd:W!|1u/ M̿8hM&\ዿ~ɀii:u]?OxFwÚEaſ^׊?hFhWGa_~|yI>2Ь|E{&ޫ SVw;ZZw5{mkXRSPe]-/1|85E~<*gR%_gVE}m[x_ীoX#ƚ0>qѴm< / 5wGPVP{W[[kkZ[_x_Y𾙦`z-NkO~2^|@DŽ#j7>eK?jgk0|:Ï֕gk^í;Cs-O&#>~Ksu~~1|dMS]zKៈ^y#-D6ϋ?tx:K oO3}ѭ'iŖ5ψ)V߲(GH7Rx'މľ*K֥ٷB&~Z^:;ҵ]#Н"Y4 yσ)Qq2i*&MxsğtLs&q?G + cPӓ>9J<_x^ xK% GL_j;\xc[_x ۍOgɯQ[¾3ѵ/z!i"oi ,ӵ-Gh_o r g_:⟍:}|4ث=[?q5YjCK] hlږm ᮙž+okK: +4}:Jռs>meo4K=gC<#,V̶  x}v^յ(U{H fm#Du?dHѵWZ ULψ  ^"'dFo uqOG~߱ux_C'gsė_)D~)|ԵxXǭSxP2+MeS/^ů_ſ؟ơ2޷Y~ҟZ75CNGmoo|c@EO_Q_č(}FΟK@Q|\ukoU}.kM &eh ovg"tO!Zx% xO6s~^)ړȶë-<|8kiVzf |:Ӵ?:|4l@/no3o.|D 7^wȶKmT> 9]ǩD|aK/?i$O3jOxo>''ߊk~ţ|5>Eqyo]5[Mcƺ~ WUdH _ iOͪEj٩m7teޗXb?v\Yj\š߅nM"T{X4_^~1u'~ |K⯄j^t-boYUO㯎>1k;__+U<m /mxJx\9/Ÿ)& x,|Es~4Z_^j5; KI?ڤ[h7 `y29|oXxS&umGx-bk k^2|><_kCSǞ5'4 )ghZ/xGÿ5RKWw{~ݚi7:R=GVEC_,u&?ouo k,+=F|3I3\N+]iZkFQm%o{vFÝ+ޥ##C5KȭMic⮟k ?ڝׇ)Ե~7 >&Pޭh^>fо [⿁v dӠҿa?GӬ4[:v_6cKdt=.!{[s?omP>|07eM[Q M^״ of4MQ\FI4X_|?:%Y˿<nM\|)wYޟ/W4/*JO^hyz_?> j?<ޭw}ja >|D,ֶ}3M1=;Zi+Od Fn|9/>OR~7_`uye u*Lּ9ᏇZvP[φ SMMF| 7ψ;Þ.cmO'?4[ (?<=4IecG[M7ĉmSß~" $t_w=\/x{;φÈ/-c }S>xROj,u=_B ?iV>%SE7dxׁQoƋK[+CFy)ux"> |'TP4ml_<__>ύjc;_ͨu{|\2Ŭ^Mo{kZNjmujwSƿ$a?=?LcM ^_wF\~Poo۳Tu &[\Ǩk e-{ş@}?GӴo|U 7k{˭+]hZ[?}6~ x~HsxԴx/PqzFiyß>,|UMaS?mX!M6WNơ'|s6xH'񍦗K3x?Ƙ>+^/vƷqGK߳" )'_.|gj^3|B3|j|:5]/;@gj;յ- ,]3W|W.QὌZtW'huyxV}.w iz z·/| xGXm7׾' j>iQث:Am=~F6?k&k+GD6w?@-^}^+?=:[_> &x%gL-;B>2[rE>|1afKo+Ú--x7O x?⦳sx{qе??s]?j/ε'ZZ[O+`tmO:=/KgC' G烼sQ"ծUoV>6/Z喹xz|/i=xCӭ>Siߌ<1?ڍχ4ͪxs]?6Ğ~+G[/sgy@q忌~$wCֽo|G5V|I@~"~?>+|c;x+;Awwuo¿߱v|XWtX+߃x%b~$xW_@k?'x ?3«~^BrW|S?gxGҬ4 A4%)Q~T7~ +ohj h :A[1τEB׼W{>Ѭj:_/55CI(1:/-Yc0{xk^g_Onǂ4_Mw7^J~/kZ5֖l_Mi/߆}+߀?}?÷7^-7 z^EmoOtXi&9Os:V~&|`M#Ӈ1inx/a^j9՟K^%q wÞ+f[hzI/jڏZox?*h[~_6h2IhNJ+Q-Fͦ] v:m~EEOý~NςI |Y;'tPܑEoo? XxYĺ~xkeo~ o/MǁmSGžt-zz\w3Gڋ:zxIVVF"|JFΟK@Q|\ukoU}.kM &eh ovg"tO!Zx% xO6s~^)ړȶë-<|8kiVzf |:Ӵ?:|4l@/no3o.|D 7^wȶKmT> 9]ǩD|aK/?i$O3jOxo>''ߊk~ţ|5>Eqyo]5[Mcƺ~ WUdH _ iOͪEj٩m7teޗXb?v\Yj\š߅nM"T{X4_^~1u'~ |K⯄j^t-boYUO㯎>1k;__+U<m /mxJx\9/Ÿ)& x,|Es~4Z_^j5; KI?ڤ< >Z7啷gε#Búlv7f]E}.%K/w^&,\|LOm[esQViǚA| osk2W+ou luZa;|Y~"Ӿi?;@! h>&~$_j>!H;<~(U L-ΰ-c9>4zTOďkFi>3j>*Gc?4 Um~?.m3iV5ǽ(xoV>"^|@WKҮ>&\k>>}/῅+(Hdm(m|&ǟ|_"i?>#h7mㆭu&Ook٪ꋤ|G/o>$45}BWҼyxk o᫛Y|z??|gYxZ $iUi'mt'_v~dKH&t#N𷎴]šnை:|`&M{{EWnm9ܾ. Ew;{~;Css&-Z9mkO$6zG6^.u766G/6xN#:瀵o i^@#cҼ=X»?Zԋ+(,`G[}D2V :u4 \ o~i^Co~nϪZo(WŻM]R?4b{Y/6q:/ //;ÖZAEizgv0x?/XjZjw:vwy>6/!mS|+~4d][Ǿ/< ߀ڗxW|g_).C=#Akw:yI2x^}7m  h$>ЧW~ؿ '|^k?f~7~ Ѵo+u 0Wů#g"|}<g> #i=Sǀ<~)ZWk;h7F:d/5t c>(ּ{ }Cͪ to5|#xWkUͦZ4֓?Z[xWY^^M/Jsyƿ:g#YE?cأM|y|XDxcP=}kKTXHuſK_G.!aO-Û1[l>'d\K"_TCE:--o¯xM|#x/Ėz׿>Cy~߷f.{QW \ _J U_٬{sH4_^,>7׾)7_gҼA{TѮPm˟'ῆlmfRšq| |;hG@ Z-Eeh,K_?VQ{_Wӣ,~.q/#U";:t? iG 1g>=Ěvq5&^մQrDiX!II ̚NJlk?xENxFxGDWk?o =9I{HWK_W=K}x'௄]F/Ɲ7Ro֥_Zf(n+ϊƩ|HEҴO~.{<PWxwHּoi6hVm;\ռ-xKQUJc |"jR/xG3𯈣i٢Xx[Y_]MoVzX4#xǀ<5s/UeC~KIy#Z> i_5v+-Jldk~נ{-/K_ooaS>+|PΣ٧zloTMԞ8j'֏~ƛ,h,.<Yi]_`aj 5ޓ%|O:\IOxW[wjCDE|5Ӭ~2x=G71_x.t~_$xzkÁcÚ֙eCӾ.tq8śa[G]|xÿ6VՍp_x$+|E;|weefC|MI2|CIw/x1φQ_xB[`[{y>UŗRW5+cs|&?|o ZM#vz!?o۳UI~(_+|IisXjx*x~H]i//I/3i^ hV~|W66| )seM8>>մ# -"I{%şF|O=~+іOn8*XMozFoh4#_t3 Y?M;_ƋOt(s_|]A4v$w$Mc6ZsxTּS#HOh~ֵo<#WQy4l,<-|Y.&+= et i*߃!?%Ӥ- ݟUŇPvIq6 ixI5׉?k =/é R>(jQzSj7{jO~~5G|_mnMu^4Z?_^w,iJω{`0_][]ܰԵ{S tI}>mg'^_EiCڧ+?;5䯵߇G1<x>#vߴL_Sf%tmkM|[jQx;sI洺u@>\e1x_5#|c7S7v#ruG};lW,?]S |:% C]ߌ,5|5_o>#xkiῂo5W/5˿2w~Ŀ+Y/:kwhK x—xh>~>!x_z>[ῄ!w5WH~ PxPa_:_h^,VK}ώw x/1hv~ٍ_ovKa>"JX 7ڤ"-/AԼ)ime? ~xVo(Kػ~$զ\W?nkn<7m?NM|-pծ>ic5]QtW⏈ҾMGĚ5_Wo<`۟Fbd)O=֕ڦunڇn\`x~? 5sck76^ӏ=/Gc[G>Rl?+/ Ad2ZY?m7#dvÌ ai֋SM<O<՟$ӵ~/|h7JޭG5ۗ$HZoqO'Hnnd/O>8DںZ¿[C?|':6~4麗/R5/_ @4|cuY^|U5M{E.|#wMiğRH`=&úEε}FHFҴOiv\m+_zzW_^^7Wu=kVzx?|EM?fͧşh~"мo_ A<᫝!;/_ :K|m"Э__XxO iYjWgƟ_k'4]xiz]{{|:_/xC↮u~>׭E6c~׺n7Q>|&4gPeAauExrH6/L׺յ KW??P NNѮ/'~|V:Mx;º߃cP %-;᭦cǖ)?'Ꮘs9s}'Wfmk_ ~ ?ִ/:u '/ş>,K 2=ɶ:m/.a$Xx{/-ރ+/4mMďOÿx|7Z?>:㟉> cLkKI>$H0n4f6xѼ|=>3:A_YwVn6hZL>8{҇k )nu]gzߊduy4*e>["tfMHb6l?NL?!ŭjz'| FW|=/$ޫGJխtoo-GlbŚƿ(;}n|{yKto^*Ei557 7K?ON]`}_Wl&Ե? ~%0|]-ޥ?6>}{?'8VokW^_k^,֑x]/^|K/K(<[:ov]ZCeĖ+io> }:/?OJdJ.|@ƞ!4Wڧği:ׅ> \#]OmDH|6VαVmƝJMKo ~ˠ[[gZ,3:/NOo?2?pf#?uٯ Q|1|96K~޿Wd*~2yֵ?Eţxh~ϟwG  U~i ~6߳ǏWg [о9׆O_x_^Ww^^E.j/ok F?X~߳OEq⇏boo𖇦ڿ _&XMGR74ox|c-W?V>'|iмE |KO 4~ |a[KÚ7mxm_|)Oςp0쯮="ּY#$W-޻_OZ#_Qx tgㆻ+,WP|u_~-S]KN㿃+Ӥu |vGH‰+ml4+c67/:6Oծ"o ^@.xXӴ]Wĭ{;jí sGmm4q,jgn=CL5?A񖷣\k>! ֑]Co^_ -!g #f}{WO~pԛRtJǓM5 xI-׉k ~}mGO/C߄+ۼ9-wVӍX~Z.Y_s4/~.Nl]?'?TR_|2'YIcf7t_h:ğ,~!dx?xOͺ:qP|:Q$xL,tbß{ď>&׵MF|I>1AM/mӭIm&m+-*m'V5m'W^'γo[#4I>4sC^ |)g>h/]I^-32llf'Y|JxwR5 ZFx4ou}'O.>|?ZMa_+oxF(,t#;k5/W}Vo^]KS·]cė:6%i$gƾ/g7ZM s:s|W94f#]]7]meGU7ĺSQ^{_>,CZw{I(]Y鷿 ~dx]ſզ|{"~ԟ#iOV S?3_‰|S7b S~?eOc4yu vxnh'z/A?euW6~"~?G5=kNj_7 xN;icEiKn '~ ?R|~=j~$ƙCث?5-[%xeX|mxvk?e}<UkϾ,5ƱYWE]j?ڷǞ;^/ Pw,]^xwƑxw*j?l:/NOo?2?$xLA &̶wiˤmom66㖕6i{gYηug/OE> t_.~Ŷ6v3_NҬ%|@<;xY-mt#S<_7|q'_ >zUkx߰|Mio<#c,5@1vp] m|C~\R-cM5lY)]Ni_|te7o.gC.K _jzV__᛭&z]o |9վ+WscNۿ.6fA]_w)j=xeSHA" }6L>)jx?nb_+÷>+ܥ):wt{еoG_@ ~"兿&d⧌G]#F +~~-Ro.U?Oυ?m,to xKoG i|AV_6,|EƦn/h~!]᷷|;~?> ·3x_|?xZgx_pz=k_ď_GKq)/د$]CO |cױ|qzS$:WO|Ou-;4[Z>$NIּ)g"{o $ZG Юu0h4Vm?VX|?ռ'xc]}cNu_? H5ץ?gDӵŸ 2XtZލqZ@ OkZGuI y~$Ԅ:>2O'}\O-?7RmKMҵ+O4&[Q'ķ^%@+[=!>>~n[N7amjھd/GG=~'(?į[Үn~i^{gWğߍp]AJWqꟷ xjFӣO/y<)jpi&-o¿؟?u VJc_ğ|-O?YRNoEtַ>O~xi/t=D_oM6-uC}K}GG3T5|C5rZj>$O^ti4o'g4w(eӿ`N]&kk{i_[Hմ]x:φuo@> ӭ$=x2)Ş0Mu%x-wĞne+Kֺψ|1kki8ѽK+|OKc?txUCR_^.uՌz¿{O4j|i׾#i~,x>|G]w/i<~O\E@kyeƺƩK]KğX xT~3j7~ylU&mӛSFҴٴ|{&7Vuu/[:_!Ns?ƟCg/0gŸ .uc-2'OwtO6&Դ[_ ho|85t ~-\ZӾKNޙ:g>eֹs޻ˍw~q^_>]|=~͠?Cx&~~-x4G.)nbH$φh/;IѬ, '\'$ O/W~uÞ#cG ,OφP궭 hfV'FOG#ӼKeX5 {֏>_'2s/=? `uQ.um7ǚƣBcşx=K[ׯxPm|'6ZD33f#?| >{ǟ2xcfO~߉NޭM*m'ǚ_෇$,t[ω]YOƯVS떺6 cZ5~5CLKxW mH:xR]F5y<7|5cKVRQ5/3ƓYZßk^!N=oi!kmAvS#/x3vcⲴP?z!>| o!Ҽ;xCP?d ^O&Mi@'l~ & CM#ſ_ڧi#J=ƍ/φ~]x Gl.J;t+EC^ e+x<9wpy7zQ!t x54ЛiT&Ro:m?/ř|Ov/kn?g~)ˈ~ o,Y1T׼5X>#k|A@ !ojmF|U_3?-Am:sjvhV64DV׎ x[+2Y.gt ,SEԴ_.voeDINUfږkkS< ./ūZw‰~i5gLݧ vQω-3B>3x+gc#:~`sW0aTWZ4_x/(缽Dj7&g|Q_ķ6WIihڷcƛ}=ai<@,Sg=̳?nU|9qO.4KK]CT=յ{7/oٴb?>*5o 2? N|Um|Q'ӟd<^%G?({O Go S@ x{;_W-'ݷ~<Bg6iZſx׈?fگß7MLJ.|7h7? ߋ 7?n=K4_ω2>u}Z xO-K}k)OkexPsxC{$Z'4/x_?GM~(?i3ƭ657jC᭞6'S<9,}Qďxž4_'zot?:W_V_zU~ W>>î~ x~t߇^cy+)_gK ;R}"|'5ܝg6oV֡E%+ |gx">|b֤Ӽ?ʼ?#|DtڳH<;u+?x^i?;᧏t hӴ g߲C7ok u>UIJ~2x[ooBOƿ.-5/M|oA[ۯ</i#v隧߃: ʿ l#} w_E\֤ӿk >'D|SuOWmo^oǿl5ljisZ~ȿns]|'G𶿥|rޝWž#?Ei?k-[^G~*M{GU=j (:o[𽧆oأY^'xM5NG R,ř}u/:eΉϏO]{<ߋ|-M_05| u/xYĿ|C?go#ş/cTҵo Toh֥y꺍kx,okƗكz?ퟬj^'g&ֵ/>ּC>{,C ڃu7KƧfG[^ g0ǫeiak|B u Cow*|t-5 &Cyxw\~@?MEOA/A`WEoOxrUn9>G>Co ՗ ^k1YkN WdӾ(\- 79iτzgu~wr]\hτ{kqxn_x_hP}h:^wō|CFˊoۃؒ <7sῃ=< f;xtk -I OlƳ/TK[MkqixXgA)aR52>,>xğ 7|qV<LbYAOO̧x7߄`Fӭcw|gJIW"-n{K#aDVzfU宩oA mcvhkfPÑO\>F sßg|AY迳wض~$~t;Z=. M>9^%]E>a~>tNJN_+ fP"v^h3HoGm>Ţ/tkqKᵟ/ev^ (0Jb|P?5l ]7Mޡ/''GtmẲ {:4&*xQu->[i<~Ӿ.;|@gxY6cDxKKj֝_wgY<7i~]zosKoP$+ie7ߵX7,~%X|)>5u.Ş <#{y/~4牯,+l7W-: Zk6`OaXio&.<3~/>-<>A,۟n\kKR9P<umx/ mT_jm^ 4#vk=~(yqMp~A'|7GG߇qOaei:7?  a|,iY|SvhwawMSObCд/XXx#R<3ooudvڃFxF.u\w6:<3>uUl4-_S?[ƞ4O-gilgҴ [~3~#U_]~ȠjV\L}>xş |6Α8{To 鿱Gu[h' rVh,~퍲zޟxkn{O* ~ l4i^.?b׺y(x9~o4-?Aa46źƙh.Xƕ{m|^B6qď w=}sQ/S| k}+L?fMd|^4'_w/-]Z|:*f?o|=;/E|Aqޟc>񵶧w/E8>'1B7ZxQ{hsxG֓?ژ޹=x;m';o x_5 ~^omWgWm#ƷPkk^!NgGoYiԮ]=nkk˽6=Co Mҧ 5r [^X3[&P ĺG];⏁xW9|W]K4njڦOG#[h:]48>|2 7xh.(h4> ּxAM3_׌|9~4doxOx=CQּ3kޱ%Ծ"MuYB?>iO˨kQjm~?v{+Kվ>+m<';_ k~5&qiz_>|YoF𝮛~ZExϏ7x_DHl|O\ZXVTѼ@{|=K?QqUmuk+C/a_x|#h-1@5i,V?.!jw,a^KeG'_-|M{oo'^ĺW6 7ynj|]4xKEDe?5.EVUo=Voj~<<;u|$IxZO𱻻>o2TMKTtm^WÛOoŽ:]7^Ūhۃ՞HѮ|1W:)τ+a`E[Yi:&xkᩓŭ _im2xWS4-'\ѭ7۫P[_+oC[l,tCL񎓮fm-/Xr|DKjBaеۛ>=Q!k|#Z^m8Xϩxź'tnc^xoxZU/(i#*QMc.}>.__Lj^"o4߈~=4Tm=NG{CB Loo|[\i6iWZ/ٜjOKHx5UM :h|D` xF(_+}g4o54k^;tMSXQVBkN’|Gyw߄<7|M7?__ xG|+VK}Yv~+Z^kf&_xP׿d{k? >xr^fz熴 æ)տ_G . ~|ax@Լ-oj?૏`y?f3ßSZw Q]O|0}*߯6\T|KO:]ׇ /ol ۋY + ? ?l; A]A}C׿kAOg^𖳧GWg!GMxkxoŚϊ|AV__o/-Pm=Νs~Ğ3~,oxoŞ~23>]-?࡚ d~9kj{)_||?Ij]xNA?f]+@~iz=_>~xj+i:]ë{MѼk4?G'j?log[O76X` ?AnύWl㵴φ(i~gon S|=i?~*?I:b WߴJ+?l~Ge*Ikxp=l/k},~xT(Y?d߂1i ~]|FQע_w; [۾BxH3G|)? | }/ j+hƹo~g!xދ♭4}zN}3A~zO,m|e|i]OXдsFߊnqAo|[5uGl:Ͳ^5 3:Ni-C`byÿ,>2_ IB׿nof7 D\ j{x^c>*ּCDY5u{ƕ⹼I}kW[ɤxGF}7! ;iK~]}3{ O`/v 3Mnqh/:v^&[{jпfpͨ\x}3#-2MPo[Al?j \."ז> ){~ɠ4sxBF.Nct~*ڣDia-LJM;N2 ō>-ZFƓm~0qq0u<~G]İêxu],x@]gi 5M?O5xŞSLWuj>+6_o+ÿ!^=Pm Ʒxl/|F~VEе}O⏆gx"7ox>rZiJ5o|}ϺO mW߅|Mu"fIiZ^ys3>E_|-:GQ'k֑m/>#|D/>4o^_i>;\|t]ZJj7^,nχ.|9̠,gR4C׼?U<oNM׾1j5džag4k |=펇 s xX`ZNhxjdkxBZwƛ I4k ~ſ[P0~ì.#PKK A<;'%дt-{mOsqA5~֧ׅN3^'nk?@#[}X׾,i^+Ğ7־xſ <&@o|S!繼дl 4fwmckUe{- glڅLJR>.o&GOxW5/3@g6GwzX4V:6xL|ukq xQPHyq EWz}? ڝܾ3O i-FWaXWZOj` zK?|_hI_w/H!?jtKi>쎆ymvx{DӴ mʀ,X ޑOդkZ\i6_w\?DzK :WUͭv#XD$ZY4~^1e0~V;^Kg.E-kt.V7ߌ!f|-W_(dƕ7?<9~x^5g ~>voQi*I><}7K"Y>qic[=SF>_e.<EWMկ4ľ | h"-\էZ+lKo<{clSJ_z› /ǚ}mO؟~,5D|ik/?w{+o_\0K5櫣k1w [M-/K4K?,/=ZkW[;yS֥&uk>rÞ7Ry5-SMѴ={/_m>/xt{\xfnV{}#F ^> me wO,m|e|i]OXдsFߊnqAo|[5uGl:Ͳ^5 3:Ni-C` +g^Ş֫ jW>9}l~au7<iX|!)%mcV yezR/xD>x?YxU޵Mox]v>I>?ULZmWx@bޱg&xWU|}ofgcs sY;_/LҼ_ψ5VT]?:6xB TҬ!w໏ g4T7=it> 4 k?|so?^++z|iom_x^M=c~>[C;UngƏi`ǟj׊u+O^$ԴХ7u{W%@ eUĉxq}ƿtO|.Zu˨ϩ/h:O,<iGЖ\'iu ږ_ l5Cٛo쿍_ohfᑢ[߅zM<9c[ ?R0 ar/'%x[u'%0/F?"*FeIe⿂zf%X?1kΠuMĺƣOF]u}zSׯ.:i$񞋢x᥿_7O{mA|tW.~/>Ӽ'?<Z?f̚e1B-Fko~2߈O+q{NhwO𮃭C{>x`xH~iz[K߉1|Oj~˺֩&uO~ MKC|05o_RQ>%RO?s]j~ >0|[ڿ^G\cD任5 |+O֡q<[v|6  O&i/ WÞ:%# ~"xS.xnO 4m[fEM_$I'm7LC0jVn{E^$u췩j->0UƝH[|35/zmW v:;(T"O^xP'ަuωLY֦}ğ7{ [⟈<1ڞE??gυ0xU!GAo&u- :p ej/g͆u]7T_‹ ?ÿ٨\+Z _RjGĻG+2W~VUt#4Zw<3cF|̳~>(Ӵ>:ѭ{mԢwϭ0wcYe{ <m'm;{LW5\@xcWpX {O[|SRn(-hZd^+'k Z7w#QŎTKj>nxهWׯ5=z쮍s&O ϡ'~[|EItߴK_xr;s#zpu6m ɦ_i g"n&|7/ 4|3u=Oƽ>M5|3 &k&lkO |4o kG-l ֿ|9OZ}\ixƺnҷ t-Wt+[O :$7xS' LjfaGY~5컭jh^4 Դ?݇ mV-_^ /$9;5֧ gŰ,ux~(-?ef84In> xn^K x^»?Ϥΐ]j:ŷkGb 4 k?|so?^++z|iom_x^M=c~>[C;UngƏi`ǟj׊u+O^$ԴХ7u{W%@ eUĉxq}ƿtO|.Zu˨ϩ/h:O,<iGЖ\'iu ږ_ l5Cٛo쿍_ohfᑢ[߅zM<9c[ ?R0 ar/'%x[u'%0/F?"*FeIe⿂zf%X?1kΠuMĺƣOF]u}zSׯ.:i$񞋢x᥿_7O{mA|tW.~/>Ӽ'?<Z?f̚e1B-Fko~2߈O+q{NhwO𮃭C{>x`xH~iz[K߉1|Oj~˺֩&uO~ MKC|05o_RQ>%RO?s]j~ >0|[ڿ^G\cD任5 |+O֡q<[v|6  O&i/ WÞ:%# ~"xS.xnO 4m[fEM_$I'm7LC0jVn{E^$u췩j->0UƝH[|35/zmW v:;(T"O^xP'ަuωLY֦}ğ7{ [⟈<1ڞE??gυ0xU!GAo&u- :p ej/g͆u]7T_‹ ?ÿ٨\+Z _RjGĻG+2W~VUt#4Zw<3cF|̳~>(Ӵ>:ѭ{mԢwϭ0wcYe{ <m'm;{LW5\@xcWpX {O[|SRn(-hZd^+'k Z7w#QŎTKj>nxهWׯ5=z쮍s&O ϡ'~[|EItߴK_xr;s#zpu6m ɦ_i g"n&|7/ 4|3u=Oƽ>M5|3 &k&lkO |4o kG-l ֿ|9OZ}\ixƺnҷ t-Wt+[O :$7xS' LjfaGY~5컭jh^4 Դ?݇ mV-_^ /$9;5֧ gŰ,ux~(-?ef84In> xn^K x^»?Ϥΐ]j:ŷkGb 4 k?|so?^++z|iom_x^M=c~>[C;UngƏi`ǟj׊u+O^$ԴХ7u{W%@ eUĉxq}ƿtO|.Zu˨ϩ/h:O,<iGЖ\'iu ږ_ l5Cٛo쿍_ohfᑢ[߅zM<9c[ ?R0 ar/'``getdp-2.4.2-source/doc/texinfo/CoreMassive.pro000644 001750 001750 00000004032 11266605602 022766 0ustar00geuzainegeuzaine000000 000000 /* ------------------------------------------------------------------- File "CoreMassive.pro" This file defines the problem dependent data structures for the dynamic core-inductor problem. To compute the solution: getdp CoreMassive -msh Core.msh -solve MagDyn_av_2D To compute post-results: getdp CoreMassive -msh Core.msh -pos Map_a getdp CoreMassive -msh Core.msh -pos U_av ------------------------------------------------------------------- */ Group { Air = Region[ 101 ]; Core = Region[ 102 ]; Ind = Region[ 103 ]; AirInf = Region[ 111 ]; SurfaceGh0 = Region[ 1100 ]; SurfaceGe0 = Region[ 1101 ]; SurfaceGInf = Region[ 1102 ]; Val_Rint = 200.e-3; Val_Rext = 250.e-3; DomainCC_Mag = Region[ {Air, AirInf} ]; DomainC_Mag = Region[ {Ind, Core} ]; // Massive inductor + conducting core DomainB_Mag = Region[ {} ]; DomainS_Mag = Region[ {} ]; DomainInf = Region[ {AirInf} ]; Domain_Mag = Region[ {DomainCC_Mag, DomainC_Mag} ]; } Function { mu0 = 4.e-7 * Pi; murCore = 100.; nu [ #{Air, Ind, AirInf} ] = 1. / mu0; nu [ Core ] = 1. / (murCore * mu0); sigma [ Ind ] = 5.9e7; sigma [ Core ] = 2.5e7; Freq = 1.; } Constraint { { Name MagneticVectorPotential_2D; Case { { Region SurfaceGe0 ; Value 0.; } { Region SurfaceGInf; Value 0.; } } } { Name SourceCurrentDensityZ; Case { } } Val_I_ = 0.01 * 1000.; { Name Current_2D; Case { { Region Ind; Value Val_I_; } } } { Name Voltage_2D; Case { { Region Core; Value 0.; } } } } Include "Jacobian_Lib.pro" Include "Integration_Lib.pro" Include "MagDyn_av_2D.pro" PostOperation { { Name Map_a; NameOfPostProcessing MagDyn_av_2D; Operation { Print[ az, OnElementsOf Domain_Mag, File "Core_m_a.pos" ]; Print[ j, OnElementsOf Domain_Mag, File "Core_m_j.pos" ]; } } { Name U_av; NameOfPostProcessing MagDyn_av_2D; Operation { Print[ U, OnRegion Ind ]; Print[ I, OnRegion Ind ]; } } } getdp-2.4.2-source/doc/texinfo/EleSta_v.pro000644 001750 001750 00000004422 11266605602 022253 0ustar00geuzainegeuzaine000000 000000 /* ------------------------------------------------------------------- File "EleSta_v.pro" Electrostatics - Electric scalar potential v formulation ------------------------------------------------------------------- I N P U T --------- Global Groups : (Extension '_Ele' is for Electric problem) ------------- Domain_Ele Whole electric domain (not used) DomainCC_Ele Nonconducting regions DomainC_Ele Conducting regions (not used) Function : -------- epsr[] Relative permittivity Constraint : ---------- ElectricScalarPotential Fixed electric scalar potential (classical boundary condition) Physical constants : ------------------ */ eps0 = 8.854187818e-12; Group { DefineGroup[ Domain_Ele, DomainCC_Ele, DomainC_Ele ]; } Function { DefineFunction[ epsr ]; } FunctionSpace { { Name Hgrad_v_Ele; Type Form0; BasisFunction { // v = v s , for all nodes // n n { Name sn; NameOfCoef vn; Function BF_Node; Support DomainCC_Ele; Entity NodesOf[ All ]; } } Constraint { { NameOfCoef vn; EntityType NodesOf; NameOfConstraint ElectricScalarPotential; } } } } Formulation { { Name Electrostatics_v; Type FemEquation; Quantity { { Name v; Type Local; NameOfSpace Hgrad_v_Ele; } } Equation { Galerkin { [ epsr[] * Dof{d v} , {d v} ]; In DomainCC_Ele; Jacobian Vol; Integration GradGrad; } } } } Resolution { { Name EleSta_v; System { { Name Sys_Ele; NameOfFormulation Electrostatics_v; } } Operation { Generate[Sys_Ele]; Solve[Sys_Ele]; SaveSolution[Sys_Ele]; } } } PostProcessing { { Name EleSta_v; NameOfFormulation Electrostatics_v; Quantity { { Name v; Value { Local { [ {v} ]; In DomainCC_Ele; Jacobian Vol; } } } { Name e; Value { Local { [ -{d v} ]; In DomainCC_Ele; Jacobian Vol; } } } { Name d; Value { Local { [ -eps0*epsr[] * {d v} ]; In DomainCC_Ele; Jacobian Vol; } } } } } } getdp-2.4.2-source/doc/texinfo/MagSta_a_2D.pro000644 001750 001750 00000005452 11266605602 022556 0ustar00geuzainegeuzaine000000 000000 /* ------------------------------------------------------------------- File "MagSta_a_2D.pro" Magnetostatics - Magnetic vector potential a formulation (2D) ------------------------------------------------------------------- I N P U T --------- GlobalGroup : (Extension '_Mag' is for Magnetic problem) ----------- Domain_Mag Whole magnetic domain DomainS_Mag Inductor regions (Source) Function : -------- nu[] Magnetic reluctivity Constraint : ---------- MagneticVectorPotential_2D Fixed magnetic vector potential (2D) (classical boundary condition) SourceCurrentDensityZ Fixed source current density (in Z direction) */ Group { DefineGroup[ Domain_Mag, DomainS_Mag ]; } Function { DefineFunction[ nu ]; } FunctionSpace { // Magnetic vector potential a (b = curl a) { Name Hcurl_a_Mag_2D; Type Form1P; BasisFunction { // a = a s // e e { Name se; NameOfCoef ae; Function BF_PerpendicularEdge; Support Domain_Mag; Entity NodesOf[ All ]; } } Constraint { { NameOfCoef ae; EntityType NodesOf; NameOfConstraint MagneticVectorPotential_2D; } } } // Source current density js (fully fixed space) { Name Hregion_j_Mag_2D; Type Vector; BasisFunction { { Name sr; NameOfCoef jsr; Function BF_RegionZ; Support DomainS_Mag; Entity DomainS_Mag; } } Constraint { { NameOfCoef jsr; EntityType Region; NameOfConstraint SourceCurrentDensityZ; } } } } Formulation { { Name Magnetostatics_a_2D; Type FemEquation; Quantity { { Name a ; Type Local; NameOfSpace Hcurl_a_Mag_2D; } { Name js; Type Local; NameOfSpace Hregion_j_Mag_2D; } } Equation { Galerkin { [ nu[] * Dof{d a} , {d a} ]; In Domain_Mag; Jacobian Vol; Integration CurlCurl; } Galerkin { [ - Dof{js} , {a} ]; In DomainS_Mag; Jacobian Vol; Integration CurlCurl; } } } } Resolution { { Name MagSta_a_2D; System { { Name Sys_Mag; NameOfFormulation Magnetostatics_a_2D; } } Operation { Generate[Sys_Mag]; Solve[Sys_Mag]; SaveSolution[Sys_Mag]; } } } PostProcessing { { Name MagSta_a_2D; NameOfFormulation Magnetostatics_a_2D; Quantity { { Name a; Value { Local { [ {a} ]; In Domain_Mag; Jacobian Vol; } } } { Name az; Value { Local { [ CompZ[{a}] ]; In Domain_Mag; Jacobian Vol; } } } { Name b; Value { Local { [ {d a} ]; In Domain_Mag; Jacobian Vol; } } } { Name h; Value { Local { [ nu[] * {d a} ]; In Domain_Mag; Jacobian Vol; } } } } } } getdp-2.4.2-source/doc/texinfo/Core.geo000644 001750 001750 00000003762 11266605602 021421 0ustar00geuzainegeuzaine000000 000000 /* ------------------------------------------------------------------- File "Core.geo" This file is the geometrical description used by GMSH to produce the file "Core.msh". ------------------------------------------------------------------- */ dxCore = 50.e-3; dyCore = 100.e-3; xInd = 75.e-3; dxInd = 25.e-3; dyInd = 50.e-3; rInt = 200.e-3; rExt = 250.e-3; s = 1.; p0 = 12.e-3 *s; pCorex = 4.e-3 *s; pCorey0 = 8.e-3 *s; pCorey = 4.e-3 *s; pIndx = 5.e-3 *s; pIndy = 5.e-3 *s; pInt = 12.5e-3*s; pExt = 12.5e-3*s; Point(1) = {0,0,0,p0}; Point(2) = {dxCore,0,0,pCorex}; Point(3) = {dxCore,dyCore,0,pCorey}; Point(4) = {0,dyCore,0,pCorey0}; Point(5) = {xInd,0,0,pIndx}; Point(6) = {xInd+dxInd,0,0,pIndx}; Point(7) = {xInd+dxInd,dyInd,0,pIndy}; Point(8) = {xInd,dyInd,0,pIndy}; Point(9) = {rInt,0,0,pInt}; Point(10) = {rExt,0,0,pExt}; Point(11) = {0,rInt,0,pInt}; Point(12) = {0,rExt,0,pExt}; Line(1) = {1,2}; Line(2) = {2,5}; Line(3) = {5,6}; Line(4) = {6,9}; Line(5) = {9,10}; Line(6) = {1,4}; Line(7) = {4,11}; Line(8) = {11,12}; Line(9) = {2,3}; Line(10) = {3,4}; Line(11) = {6,7}; Line(12) = {7,8}; Line(13) = {8,5}; Circle(14) = {9,1,11}; Circle(15) = {10,1,12}; Line Loop(16) = {-6,1,9,10}; Plane Surface(17) = {16}; Line Loop(18) = {11,12,13,3}; Plane Surface(19) = {18}; Line Loop(20) = {7,-14,-4,11,12,13,-2,9,10}; Plane Surface(21) = {20}; Line Loop(22) = {8,-15,-5,14}; Plane Surface(23) = {22}; Physical Surface(101) = {21}; /* Air */ Physical Surface(102) = {17}; /* Core */ Physical Surface(103) = {19}; /* Ind */ Physical Surface(111) = {23}; /* AirInf */ Physical Line(1000) = {1,2}; /* Cut */ Physical Line(1001) = {2}; /* CutAir */ Physical Line(202) = {9,10}; /* SkinCore */ Physical Line(203) = {11,12,13}; /* SkinInd */ Physical Line(1100) = {1,2,3,4,5}; /* SurfaceGh0 */ Physical Line(1101) = {6,7,8}; /* SurfaceGe0 */ Physical Line(1102) = {15}; /* SurfaceGInf */ getdp-2.4.2-source/doc/texinfo/mStrip.geo000644 001750 001750 00000003745 11266605602 022010 0ustar00geuzainegeuzaine000000 000000 /* ------------------------------------------------------------------- File "mStrip.geo" This file is the geometrical description used by GMSH to produce the file "mStrip.msh". ------------------------------------------------------------------- */ /* Definition of some parameters for geometrical dimensions, i.e. h (height of 'Diel1'), w (width of 'Line'), t (thickness of 'Line') xBox (width of the air box) and yBox (height of the air box) */ h = 1.e-3 ; w = 4.72e-3 ; t = 0.035e-3 ; xBox = w/2. * 6. ; yBox = h * 12. ; /* Definition of parameters for local mesh dimensions */ s = 1. ; p0 = h / 10. * s ; pLine0 = w/2. / 10. * s ; pLine1 = w/2. / 50. * s ; pxBox = xBox / 10. * s ; pyBox = yBox / 8. * s ; /* Definition of gemetrical points */ Point(1) = { 0 , 0, 0, p0} ; Point(2) = { xBox, 0, 0, pxBox} ; Point(3) = { xBox, h, 0, pxBox} ; Point(4) = { 0 , h, 0, pLine0} ; Point(5) = { w/2., h, 0, pLine1} ; Point(6) = { 0 , h+t, 0, pLine0} ; Point(7) = { w/2., h+t, 0, pLine1} ; Point(8) = { 0 , yBox, 0, pyBox} ; Point(9) = { xBox, yBox, 0, pyBox} ; /* Definition of gemetrical lines */ Line(1) = {1,2}; Line(2) = {2,3}; Line(3) = {3,9}; Line(4) = {9,8}; Line(5) = {8,6}; Line(7) = {4,1}; Line(8) = {5,3}; Line(9) = {4,5}; Line(10) = {6,7}; Line(11) = {5,7}; /* Definition of geometrical surfaces */ Line Loop(12) = {8,-2,-1,-7,9}; Plane Surface(13) = {12}; Line Loop(14) = {10,-11,8,3,4,5}; Plane Surface(15) = {14}; /* Definition of Physical entities (surfaces, lines). The Physical entities tell GMSH the elements and their associated region numbers to save in the file 'mStrip.msh'. For example, the Region 111 is made of elements of surface 13, while the Region 121 is made of elements of lines 9, 10 and 11 */ Physical Surface (101) = {15} ; /* Air */ Physical Surface (111) = {13} ; /* Diel1 */ Physical Line (120) = {1} ; /* Ground */ Physical Line (121) = {9,10,11} ; /* Line */ Physical Line (130) = {2,3,4} ; /* SurfInf */ getdp-2.4.2-source/doc/texinfo/CoreSta.pro000644 001750 001750 00000003305 11266605602 022110 0ustar00geuzainegeuzaine000000 000000 /* ------------------------------------------------------------------- File "CoreSta.pro" This file defines the problem dependent data structures for the static core-inductor problem. To compute the solution: getdp CoreSta -msh Core.msh -solve MagSta_a_2D To compute post-results: getdp CoreSta -msh Core.msh -pos Map_a ------------------------------------------------------------------- */ Group { Air = Region[ 101 ]; Core = Region[ 102 ]; Ind = Region[ 103 ]; AirInf = Region[ 111 ]; SurfaceGh0 = Region[ 1100 ]; SurfaceGe0 = Region[ 1101 ]; SurfaceGInf = Region[ 1102 ]; Val_Rint = 200.e-3; Val_Rext = 250.e-3; DomainCC_Mag = Region[ {Air, AirInf, Core, Ind} ]; DomainC_Mag = Region[ {} ]; DomainS_Mag = Region[ {Ind} ]; // Stranded inductor DomainInf = Region[ {AirInf} ]; Domain_Mag = Region[ {DomainCC_Mag, DomainC_Mag} ]; } Function { mu0 = 4.e-7 * Pi; murCore = 100.; nu [ Region[{Air, Ind, AirInf}] ] = 1. / mu0; nu [ Core ] = 1. / (murCore * mu0); Sc[ Ind ] = 2.5e-2 * 5.e-2; } Constraint { { Name MagneticVectorPotential_2D; Case { { Region SurfaceGe0 ; Value 0.; } { Region SurfaceGInf; Value 0.; } } } Val_I_1_ = 0.01 * 1000.; { Name SourceCurrentDensityZ; Case { { Region Ind; Value Val_I_1_/Sc[]; } } } } Include "Jacobian_Lib.pro" Include "Integration_Lib.pro" Include "MagSta_a_2D.pro" e = 1.e-5; p1 = {e,e,0}; p2 = {0.12,e,0}; PostOperation { { Name Map_a; NameOfPostProcessing MagSta_a_2D; Operation { Print[ az, OnElementsOf Domain_Mag, File "CoreSta_a.pos" ]; Print[ b, OnLine{{List[p1]}{List[p2]}} {1000}, File "k_a" ]; } } } getdp-2.4.2-source/doc/texinfo/getdp.texi000644 001750 001750 00000636536 12221300353 022031 0ustar00geuzainegeuzaine000000 000000 \input texinfo.tex @c -*-texinfo-*- @c GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine @c @c See the LICENSE.txt file for license information. Please report all @c bugs and problems to the public mailing list . @c @c ========================================================================= @c @c This is the GetDP documentation texinfo source file @c @c Things to do -> "Ctrl+s todo:" @c @c Indexing: @cindex = concept index, e.g. "Numerical tools, overview" @c @vindex = (metasyntactic) variable index, e.g. "constraint-type" @c /@tindex = type index (=frozen syntax ossature), e.g. "DefineGroup" @c \@findex = function index (=all types in the objects), e.g. "Curl" @c @c Before release, run C-u C-c C-u C-a in GNU Emacs @c This updates all node pointers and menus @c @c ========================================================================= @c %**start of header @setfilename getdp.info @set GETDP-VERSION 2.4 @set COPYRIGHT @copyright{} 1997-2013 Patrick Dular, Christophe Geuzaine @settitle GetDP @value{GETDP-VERSION} @footnotestyle separate @setchapternewpage odd @paragraphindent 0 @finalout @c %**end of header @c merge function index into type index @syncodeindex fn tp @c ========================================================================= @c Info directives @c ========================================================================= @ifinfo @dircategory Math @direntry * GetDP: (getdp). General finite element solver @end direntry @noindent This is the @cite{GetDP Reference Manual} for GetDP @value{GETDP-VERSION} (@today{}). @noindent Copyright @value{COPYRIGHT}. @end ifinfo @c ========================================================================= @c Title page @c ========================================================================= @shorttitlepage GetDP @titlepage @title GetDP Reference Manual @subtitle The documentation for GetDP @value{GETDP-VERSION} @subtitle A General environment for the treatment of Discrete Problems @subtitle @subtitle @today{} @author Patrick Dular @author Christophe Geuzaine @page @vskip 0pt plus 1filll Copyright @value{COPYRIGHT} @sp 1 University of Li@`ege @* Department of Electrical Engineering @* Institut d'@'Electricit@'e Montefiore @* Sart Tilman Campus, Building B28 @* B-4000 Li@`ege @* BELGIUM @sp 1 Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice are preserved on all copies. @end titlepage @c ========================================================================= @c Table of contents @c ========================================================================= @ifnothtml @summarycontents @end ifnothtml @contents @c ========================================================================= @c Top node (for all output, except TeX) @c ========================================================================= @ifnottex @node Top, Obtaining GetDP, (dir), (dir) @top GetDP Patrick Dular and Christophe Geuzaine GetDP is a general finite element solver that uses mixed finite elements to discretize de Rham-type complexes in one, two and three dimensions. This is the @cite{GetDP Reference Manual} for GetDP @value{GETDP-VERSION} (@today{}). @end ifnottex @c ========================================================================= @c Master menu @c ========================================================================= @menu * Obtaining GetDP:: * Copying conditions:: Terms and conditions of use. * Overview:: What is GetDP? * How to Read this Manual:: Which parts of this manual should you read? * Running GetDP:: How to run GetDP on your machine. * Expressions:: Definition of basic expressions in GetDP. * Objects:: Definition of the 10 GetDP objects. * Types for objects:: Definition of all available types for the 10 objects. * Short examples:: Simple object examples. * Complete examples:: Some simple complete examples. * File formats:: Input and output file formats. * Gmsh examples:: Sample Gmsh input files. * Compiling the source code:: Information on how to comile GetDP from source * Frequently asked questions:: The GetDP FAQ * Tips and tricks:: Some tips to make your life easier with GetDP. * Version history:: Changelog * Copyright and credits:: Copyright information and list of contributors * License:: Complete copy of the license. * Concept index:: Index of concepts. * Metasyntactic variable index:: Index of metasyntactic variables used in this manual. * Syntax index:: Index of reserved keywords in the GetDP language. @detailmenu --- The Detailed Node Listing --- Overview * Numerical tools as objects:: * Which problems can GetDP actually solve?:: * Bug reports:: How to read this manual * Syntactic rules:: Expressions * Comments:: * Includes:: * Expression definition:: * Constants:: * Operators:: * Functions:: * Current values:: * Arguments:: * Registers:: * Fields:: * Loops and conditionals:: Expressions definition * Operators:: * Constants:: * Functions:: * Current values:: * Fields:: Operators * Operator types:: * Evaluation order:: Objects * Group:: * Function:: * Constraint:: * FunctionSpace:: * Jacobian:: * Integration:: * Formulation:: * Resolution:: * PostProcessing:: * PostOperation:: Types for objects * Types for Group:: * Types for Function:: * Types for Constraint:: * Types for FunctionSpace:: * Types for Jacobian:: * Types for Integration:: * Types for Formulation:: * Types for Resolution:: * Types for PostProcessing:: * Types for PostOperation:: Types for @code{Function} * Math functions:: * Extended math functions:: * Green functions:: * Type manipulation functions:: * Coordinate functions:: * Miscellaneous functions:: Short examples * Constant expression examples:: * Group examples:: * Function examples:: * Constraint examples:: * FunctionSpace examples:: * Jacobian examples:: * Integration examples:: * Formulation examples:: * Resolution examples:: * PostProcessing examples:: * PostOperation examples:: @code{FunctionSpace} examples * Conform space:: * High order space:: * Global values:: * Curl-conform space:: * Gauge condition:: * Coupled spaces:: * Multiply connected domains:: @code{Formulation} examples * Electrostatics:: * Electrostatics 2:: * Magnetostatics:: * Magnetodynamics:: * Other formulations:: @code{Resolution} examples * Static resolution:: * Frequency domain resolution:: * Time domain resolution:: * Nonlinear resolution:: * Coupled formulations:: Complete examples * Electrostatic problem:: * Magnetostatic problem:: * Magnetodynamic problem:: File formats * Input file format:: * Output file format:: Output file format * File pre:: * File res:: Frequently asked questions * The basics:: * Installation:: * Usage:: @end detailmenu @end menu @c ========================================================================= @c Obtaining GetDP @c ========================================================================= @node Obtaining GetDP, Copying conditions, Top, Top @unnumbered Obtaining GetDP @cindex Web site @cindex Internet address @cindex Download The source code and various pre-compiled versions of GetDP (for Unix, Windows and Mac OS) can be downloaded from @uref{http://geuz.org/getdp}. If you use GetDP, we would appreciate that you mention it in your work. References and the latest news about GetDP are always available on @url{http://geuz.org/getdp}. @c ========================================================================= @c Copying Conditions @c ========================================================================= @node Copying conditions, Overview, Obtaining GetDP, Top @unnumbered Copying conditions @cindex Copyright @cindex License @cindex Web site @cindex Internet address @cindex Mailing list @cindex Download GetDP is ``free software''; this means that everyone is free to use it and to redistribute it on a free basis. GetDP is not in the public domain; it is copyrighted and there are restrictions on its distribution, but these restrictions are designed to permit everything that a good cooperating citizen would want to do. What is not allowed is to try to prevent others from further sharing any version of GetDP that they might get from you. Specifically, we want to make sure that you have the right to give away copies of GetDP, that you receive source code or else can get it if you want it, that you can change GetDP or use pieces of GetDP in new free programs, and that you know you can do these things. To make sure that everyone has such rights, we have to forbid you to deprive anyone else of these rights. For example, if you distribute copies of GetDP, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. Also, for our own protection, we must make certain that everyone finds out that there is no warranty for GetDP. If GetDP is modified by someone else and passed on, we want their recipients to know that what they have is not what we distributed, so that any problems introduced by others will not reflect on our reputation. The precise conditions of the license for GetDP are found in the General Public License that accompanies the source code (@pxref{License}). Further information about this license is available from the GNU Project webpage @uref{http://www.gnu.org/copyleft/gpl-faq.html}. Detailed copyright information can be found in @ref{Copyright and credits}. If you want to integrate parts of GetDP into a closed-source software, or want to sell a modified closed-source version of GetDP, you will need to obtain a different license. Please @uref{http://geuz.org, contact us directly} for more information. @c ========================================================================= @c Overview @c ========================================================================= @node Overview, How to Read this Manual, Copying conditions, Top @chapter Overview @cindex Introduction @cindex Overview GetDP (a ``General environment for the treatment of Discrete Problems'') is a scientific software environment for the numerical solution of integro-differential equations, open to the coupling of physical problems (electromagnetic, thermal, etc.) as well as of numerical methods (finite element method, integral methods, etc.). It can deal with such problems of various dimensions (1D, 2D or 3D) and time states (static, transient or harmonic). The main feature of GetDP is the closeness between its internal structure (written in C), the organization of data defining discrete problems (written by the user in ASCII data files) and the symbolic mathematical expressions of these problems. Its aim is to be welcoming and of easy use for both development and application levels: it consists of a working environment in which the definition of any problem makes use of a limited number of objects, which makes the environment structured and concise. It therefore gives researchers advanced developing tools and a large freedom in adding new functionalities. The modeling tools provided by GetDP can be tackled at various levels of complexity: this opens the software to a wide range of activities, such as research, collaboration, education, training and industrial studies. @c ------------------------------------------------------------------------- @c Numerical Tools as Objects @c ------------------------------------------------------------------------- @menu * Numerical tools as objects:: * Which problems can GetDP actually solve?:: * Bug reports:: @end menu @node Numerical tools as objects, Which problems can GetDP actually solve?, Overview, Overview @section Numerical tools as objects @cindex Objects, dependences @cindex Dependences, objects @cindex Linking, objects @cindex Tools, order of definition @cindex Philosophy, general @cindex Processing cycle An assembly of computational tools (or objects) in GetDP leads to a problem definition structure, which is a transcription of the mathematical expression of the problem, and forms a text data file: the equations describing a phenomenon, written in a mathematical form adapted to a chosen numerical method, directly constitute data for GetDP. The resolution of a discrete problem with GetDP requires the definition, in a text data file, of the GetDP objects listed (together with their dependencies) in the following figure and table. @image{objects-wrap,13.5cm,} @sp 1 @example Group @var{---} Function Group Constraint Group, Function, (Resolution) FunctionSpace Group, Constraint, (Formulation), (Resolution) Jacobian Group Integration @var{---} Formulation Group, Function, (Constraint), FunctionSpace, Jacobian, Integration Resolution Function, Formulation PostProcessing Group, Function, Jacobian, Integration, Formulation, Resolution PostOperation Group, PostProcessing @end example @sp 1 The gathering of all these objects constitutes the problem definition structure, which is a copy of the formal mathematical formulation of the problem. Reading the first column of the table from top to bottom pictures the working philosophy and the linking of operations peculiar to GetDP, from group definition to results visualization. The decomposition highlighted in the figure points out the separation between the objects defining the method of resolution, which may be isolated in a ``black box'' (bottom) and those defining the data peculiar to a given problem (top). The computational tools which are in the center of a problem definition structure are formulations (@code{Formulation}) and function spaces (@code{FunctionSpace}). Formulations define systems of equations that have to be built and solved, while function spaces contain all the quantities, i.e., functions, fields of vectors or covectors, known or not, involved in formulations. Each object of a problem definition structure must be defined before being referred to by others. A linking which always respects this property is the following: it first contains the objects defining particular data of a problem, such as geometry, physical characteristics and boundary conditions (i.e., @code{Group}, @code{Function} and @code{Constraint}) followed by those defining a resolution method, such as unknowns, equations and related objects (i.e., @code{Jacobian}, @code{Integration}, @code{FunctionSpace}, @code{Formulation}, @code{Resolution} and @code{PostProcessing}). The processing cycle ends with the presentation of the results (i.e., lists of numbers in various formats), defined in @code{PostOperation} fields. This decomposition points out the possibility of building black boxes, containing objects of the second group, adapted to treatment of general classes of problems that share the same resolution methods. @c ------------------------------------------------------------------------- @c Which Problems can GetDP actually solve? @c ------------------------------------------------------------------------- @node Which problems can GetDP actually solve?, Bug reports, Numerical tools as objects, Overview @section Which problems can GetDP actually solve? @cindex Scope of GetDP @cindex Future developments @cindex Developments, future @cindex Physical problems @cindex Method of Moments @cindex Finite Element Method @cindex Integral Equation Method @cindex Boundary Element Method @cindex Finite Difference Method @cindex Finite Volume Method @cindex Electromagnetism @cindex Mechanics @cindex Thermics The preceding explanations may seem very (too) general. Which are the problems that GetDP can actually solve? To answer this question, here is a list of methods that we have considered and coupled until now: @table @asis @item Numerical methods finite element method@* boundary element method (experimental, undocumented)@* volume integral methods (experimental, undocumented) @item Geometrical models one-dimensional models (1D)@* two-dimensional models (2D), plane and axisymmetric@* three-dimensional models (3D) @item Time states static states@* sinusoidal and harmonic states@* transient states@* eigenvalue problems @end table These methods have been successfully applied to build coupled physical models involving electromagnetic phenomena (magnetostatics, magnetodynamics, electrostatics, electrokinetics, electrodynamics, wave propagation, lumped electric circuits), acoustic phenomena, thermal phenomena and mechanical phenomena (elasticity, rigid body movement). As can be guessed from the preceding list, GetDP has been initially developed in the field of computational electromagnetics, which fully uses all the offered coupling features. We believe that this does not interfere with the expected generality of the software because a particular modeling forms a problem definition structure which is totally external to the software: GetDP offers computational tools; the user freely applies them to define and solve his problem. Nevertheless, specific numerical tools will @emph{always} need to be implemented to solve specific problems in areas other than those mentionned above. If you think the general phisosophy of GetDP is right for you and your problem, but you discover that GetDP lacks the tools necessary to handle it, let us know: we would love to discuss it with you. For example, at the time of this writing, many areas of GetDP would need to be improved to make GetDP as useful for computational mechanics or computational fluid dynamics as it is for computational electromagnetics... So if you have the skills and some free time, feel free to join the project: we gladly accept all code contributions! @c ------------------------------------------------------------------------- @c Bug reports @c ------------------------------------------------------------------------- @node Bug reports, , Which problems can GetDP actually solve?, Overview @section Bug reports @cindex Bugs, reporting @cindex Reporting bugs @cindex Contact information @cindex Mailing list @cindex Authors, e-mail @cindex E-mail, authors If you think you have found a bug in GetDP, you can report it by electronic mail to the GetDP mailing list at @email{getdp@@geuz.org}, or file it directly into our bug tracking system at @url{https://geuz.org/trac/getdp/report} (login: getdp, password: getdp). Please send as precise a description of the problem as you can, including sample input files that produce the bug (problem definition and mesh files). Don't forget to mention both the version of GetDP and the version of your operation system (@pxref{Running GetDP} to see how to get this information). See @ref{Frequently asked questions}, and the bug tracking system to see which problems we already know about. @c ========================================================================= @c How to Read this Manual @c ========================================================================= @node How to Read this Manual, Running GetDP, Overview, Top @chapter How to read this manual @cindex Reading, guidelines After reading @ref{Overview}, which depicts the general philosophy of GetDP, you might want to skip @ref{Expressions}, @ref{Objects} and @ref{Types for objects} and directly run the demo files bundled in the distribution on your computer (@pxref{Running GetDP}). You should then open these examples with a text editor and compare their structure with the examples given in @ref{Short examples} and @ref{Complete examples}. For each new syntax element that you fall onto, you can then go back to @ref{Expressions}, @ref{Objects}, and @ref{Types for objects}, and find in these chapters the detailed description of the syntactic rules as well as all the available options. Indexes for many concepts (@pxref{Concept index}) and for all the syntax elements (@pxref{Syntax index}) are available at the end of this manual. @c ------------------------------------------------------------------------- @c Syntactic Rules Used in this Document @c ------------------------------------------------------------------------- @menu * Syntactic rules:: @end menu @node Syntactic rules, , How to Read this Manual, How to Read this Manual @section Syntactic rules used in this document @cindex Syntax, rules @cindex Rules, syntactic @cindex Document syntax @vindex @dots{} @vindex <, > @vindex | @vindex : @vindex @var{etc} Here are the rules we tried to follow when writing this user's guide. Note that metasyntactic variable definitions stay valid throughout all the manual (and not only in the sections where the definitions appear). See @ref{Metasyntactic variable index}, for an index of all metasyntactic variables. @enumerate @item Keywords and literal symbols are printed like @code{this}. @item Metasyntactic variables (i.e., text bits that are not part of the syntax, but stand for other text bits) are printed like @var{this}. @item A colon (@code{:}) after a metasyntactic variable separates the variable from its definition. @item Optional rules are enclosed in @code{<} @code{>} pairs. @item Multiple choices are separated by @code{|}. @item Three dots (@dots{}) indicate a possible repetition of the preceding rule. @item For conciseness, the notation @code{@var{rule} <, @var{rule} > @dots{}} is replaced by @code{@var{rule} <,@dots{}>}. @item The @var{etc} symbol replaces nonlisted rules. @end enumerate @c ========================================================================= @c Running GetDP @c ========================================================================= @node Running GetDP, Expressions, How to Read this Manual, Top @chapter Running GetDP @cindex Operating system @cindex Platforms @cindex Command line options @cindex Options, command line @cindex Running GetDP GetDP has no graphical interface@footnote{If you are looking for a graphical front-end to GetDP, you may consider using Gmsh (available at @url{http://geuz.org/gmsh}). Gmsh permits to construct geometries, generate meshes, launch computations and visualize results directly from within a user-friendly graphical interface. The file formats used by Gmsh for mesh generation and post-processing are the default file formats accepted by GetDP (see @ref{Input file format}, and @ref{Types for PostOperation}).}. It is a command-line driven program that reads a problem definition file once at the beginning of the processing. This problem definition file is a regular ASCII text file (@pxref{Numerical tools as objects}), hence created with whatever text editor you like. If you just type the program name at your shell prompt (without any argument), you will get a short help on how to run GetDP. All GetDP calls look like @example getdp @var{filename} @var{options} @end example @noindent where @var{filename} is the ASCII file containing the problem definition, i.e., the structures this user's guide has taught you to create. This file can include other files (@pxref{Includes}), so that only one problem definition file should always be given on the command line. The input files containing the problem definition structure are usually given the @file{.pro} extension (if so, there is no need to specify the extension on the command line). The name of this file (without the extension) is used as a basis for the creation of intermediate files during the pre-processing and the processing stages. The @var{options} are a combination of the following commands (in any order): @ftable @code @item -pre @var{resolution-id} Performs the pre-processing associated with the resolution @var{resolution-id}. In the pre-processing stage, GetDP creates the geometric database (from the mesh file), identifies the degrees of freedom (the unknowns) of the problem and sets up the constraints on these degrees of freedom. The pre-processing creates a file with a @file{.pre} extension. If @var{resolution-id} is omitted, the list of available choices is displayed. @item -cal Performs the processing. This requires that a pre-processing has been performed previously, or that a @code{-pre} option is given on the same command line. The performed resolution is the one given as an argument to the @code{-pre} option. In the processing stage, GetDP executes all the commands given in the @code{Operation} field of the selected @code{Resolution} object (such as matrix assemblies, system resolutions, @dots{}). @item -pos @var{post-operation-id} @dots{} Performs the operations in the @code{PostOperation}(s) selected by the @var{post-operation-id}(s). This requires that a processing has been performed previously, or that a @code{-cal} option is given on the same command line. If @var{post-operation-id} is omitted, the list of available choices is displayed. @item -msh @var{filename} Reads the mesh (in @code{.msh} format) from @var{filename} (@pxref{File formats}) rather than from the default problem file name (with the @file{.msh} extension appended). @item -gmshread @var{filename} @dots{} Read gmsh data files (same as GmshRead in @code{Resolution} operations). Allows to use such datasets outside resolutions (e.g. in pre-processing). @item -split Saves processing results in separate files (one for each timestep). @item -res @var{filename} @dots{} Loads processing results from file(s). @item -name @var{string} Uses @var{string} as the default generic file name for input or output of mesh, pre-processing and processing files. @item -restart Restarts processing of a time stepping resolution interrupted before being complete. @item -solve @var{resolution-id} Same as @code{-pre @var{resolution-id} -cal}. @item -solver @var{filename} Specifies a solver option file (whose format varies depending on the linear algebra toolkit used). @item -adapt @var{file} Reads adaptation constraints from file. @item -order @var{real} Specifies the maximum interpolation order. @item -cache Caches network computations to disk. @item -bin Selects binary format for output files. @item -v2 Creates mesh-based Gmsh output files when possible. @item -check Lets you check the problem structure interactively. @item -v @itemx -verbose @var{integer} Sets the verbosity level. A value of 0 means that no information will be displayed during the processing. @item -p @itemx -progress @var{integer} Sets the progress update rate. This controls the refreshment rate of the counter indicating the progress of the current computation (in %). @item -onelab @var{name} <@var{address}> Communicates with OneLab (file or server address) @item -setnumber @var{name} @var{value} Sets constant number @var{name} to @var{value} @item -setstring @var{name} @var{value} Sets constant string @var{name} to @var{value} @item -info Displays the version information. @item -version Displays the version number. @item -help Displays a message listing basic usage and available options. @end ftable @c ========================================================================= @c Expressions @c ========================================================================= @node Expressions, Objects, Running GetDP, Top @chapter Expressions This chapter and the next two describe in a rather formal way all the commands that can be used in the ASCII text input files. If you are just beginning to use GetDP, or just want to see what GetDP is all about, you should skip this chapter and the next two for now, have a quick look at @ref{Running GetDP}, and run the demo problems bundled in the distribution on your computer. You should then open the @file{.pro} files in a text editor and compare their structure with the examples given in @ref{Short examples} and @ref{Complete examples}. Once you have a general idea of how the files are organized, you might want to come back here to learn more about the specific syntax of all the objects, and all the available options. @menu * Comments:: * Includes:: * Expression definition:: * Constants:: * Operators:: * Functions:: * Current values:: * Arguments:: * Registers:: * Fields:: * Loops and conditionals:: @end menu @c ------------------------------------------------------------------------- @c Comments @c ------------------------------------------------------------------------- @node Comments, Includes, Expressions, Expressions @section Comments @cindex Comments @cindex File, comment @tindex /*, */ @tindex // Both C and C++ style comments are supported and can be used in the input data files to comment selected text regions: @enumerate @item the text region comprised between @code{/*} and @code{*/} pairs is ignored; @item the rest of a line after a double slash @code{//} is ignored. @end enumerate Comments cannot be used inside double quotes or inside GetDP keywords. @c ------------------------------------------------------------------------- @c Includes @c ------------------------------------------------------------------------- @node Includes, Expression definition, Comments, Expressions @section Includes @cindex Includes @cindex File, include @tindex Include @tindex #include An input data file can be included in another input data file by placing one of the following commands (@var{expression-char} represents a file name) on a separate line, outside the GetDP objects. Any text placed after an include command on the same line is ignored. @example @code{Include @var{expression-char}} @code{#include @var{expression-char}} @end example See @ref{Constants}, for the definition of the character expression @var{expression-char}. @c ------------------------------------------------------------------------- @c Definition @c ------------------------------------------------------------------------- @node Expression definition, Constants, Includes, Expressions @section Expressions definition @cindex Expression, definition @vindex @var{expression} @vindex @var{expression-list} Expressions are the basic tool of GetDP. They cover a wide range of functional expressions, from constants to formal expressions containing functions (built-in or user-defined, depending on space and time, etc.), arguments, discrete quantities and their associated differential operators, etc. Note that `white space' (spaces, tabs, new line characters) is ignored inside expressions (as well as inside all GetDP objects). Expressions are denoted by the metasyntactic variable @var{expression} (remember the definition of the syntactic rules in @ref{Syntactic rules}): @example @var{expression}: ( @var{expression} ) | @var{integer} | @var{real} | @var{constant-id} | @var{quantity} | @var{argument} | @var{current-value} | @var{register-value-set} | @var{register-value-get} | @var{operator-unary} @var{expression} | @var{expression} @var{operator-binary} @var{expression} | @var{expression} @var{operator-ternary-left} @var{expression} @var{operator-ternary-right} @var{expression} | @var{built-in-function-id} [ < @var{expression-list} > ] < @{ @var{expression-cst-list} @} > | @var{function-id} [ < @var{expression-list} > ] | < Real | Complex > [ @var{expression} ] | Dt [ @var{expression} ] | AtAnteriorTimeStep [ @var{expression}, @var{integer} ] | Order [ @var{quantity} ] | Trace [ @var{expression}, @var{group-id} ] | @var{expression} ##@var{integer} @end example @noindent The following sections introduce the quantities that can appear in expressions, i.e., constant terminals (@var{integer}, @var{real}) and constant expression identifiers (@var{constant-id}, @var{expression-cst-list}), discretized fields (@var{quantity}), arguments (@var{argument}), current values (@var{current-value}), register values (@var{register-value-set}, @var{register-value-get}), operators (@var{operator-unary}, @var{operator-binary}, @var{operator-ternary-left}, @var{operator-ternary-right}) and built-in or user-defined functions (@var{built-in-function-id}, @var{function-id}). The last seven cases in this definition permit to cast an expression as real or complex, get the time derivative or evaluate an expression at an anterior time step, retrieve the interpolation order of a discretized quantity, evaluate the trace of an expression, and print the value of an expression for debugging purposes. List of expressions are defined as: @example @var{expression-list}: @var{expression} <,@dots{}> @end example @menu * Operators:: * Constants:: * Functions:: * Current values:: * Fields:: @end menu @c ------------------------------------------------------------------------- @c Constants @c ------------------------------------------------------------------------- @node Constants, Operators, Expression definition, Expressions @section Constants @cindex Constant, definition @cindex Constant, evaluation @cindex Evaluation mechanism @cindex Integer numbers @cindex Real numbers @cindex Floating point numbers @cindex Numbers, real @cindex Numbers, integer @cindex String @tindex DefineConstant @tindex List @tindex ListAlt @tindex Pi @tindex 0D @tindex 1D @tindex 2D @tindex 3D @tindex = @tindex ~ @vindex @var{integer} @vindex @var{real} @vindex @var{string} @vindex @var{expression-cst} @vindex @var{expression-cst-list} @vindex @var{expression-cst-list-item} @vindex @var{constant-id} @vindex @var{constant-def} @vindex @var{string-id} @vindex @var{expression-char} @vindex @var{affectation} The three constant types used in GetDP are @var{integer}, @var{real} and @var{string}. These types have the same meaning and syntax as in the C or C++ programming languages. Besides general expressions (@var{expression}), purely constant expressions, denoted by the metasyntactic variable @var{expression-cst}, are also used: @example @var{expression-cst}: ( @var{expression-cst} ) | @var{integer} | @var{real} | @var{constant-id} | @var{operator-unary} @var{expression-cst} | @var{expression-cst} @var{operator-binary} @var{expression-cst} | @var{expression-cst} @var{operator-ternary-left} @var{expression-cst} @var{operator-ternary-right} @var{expression-cst} | @var{math-function-id} [ < @var{expression-cst-list} > ] | #@var{constant-id}() | @var{constant-id}(@var{expression-cst}) @end example List of constant expressions are defined as: @example @var{expression-cst-list}: @var{expression-cst-list-item} <,@dots{}> @end example @noindent with @example @var{expression-cst-list-item}: @var{expression-cst} | @var{expression-cst} : @var{expression-cst} | @var{expression-cst} : @var{expression-cst} : @var{expression-cst} | @var{constant-id} () | @var{constant-id} ( @{ @var{expression-cst-list} @} ) | List[ @var{constant-id} ] | ListAlt[ @var{constant-id}, @var{constant-id} ] | LinSpace[ @var{expression-cst}, @var{expression-cst}, @var{expression-cst} ] | LogSpace[ @var{expression-cst}, @var{expression-cst}, @var{expression-cst} ] | - @var{expression-cst-list-item} | @var{expression-cst} * @var{expression-cst-list-item} | @var{expression-cst-list-item} * @var{expression-cst} | @var{expression-cst} / @var{expression-cst-list-item} | @var{expression-cst-list-item} / @var{expression-cst} | @var{expression-cst-list-item} ^ @var{expression-cst} | @var{expression-cst-list-item} + @var{expression-cst-list-item} | @var{expression-cst-list-item} - @var{expression-cst-list-item} | @var{expression-cst-list-item} * @var{expression-cst-list-item} | @var{expression-cst-list-item} / @var{expression-cst-list-item} @end example The second case in this last definition permits to create a list containing the range of numbers comprised between the two @var{expression-cst}, with a unit incrementation step. The third case also permits to create a list containing the range of numbers comprised between the two @var{expression-cst}, but with a positive or negative incrementation step equal to the third @var{expression-cst}. The fourth and fifth cases permit to reference constant identifiers (@var{constant-id}s) of lists of constants and constant identifiers of sublists of constants (see below for the definition of constant identifiers) . The sixth case is a synonym for the fourth. The seventh case permits to create alternate lists: the arguments of @code{ListAlt} must be @var{constant-id}s of lists of constants of the same dimension. The result is an alternate list of these constants: first constant of argument 1, first constant of argument 2, second constant of argument 1, etc. These kinds of lists of constants are for example often used for function parameters (@pxref{Functions}). The next two cases permit to create linear and logarithmic lists of numbers, respectively. The remaining cases permit to apply arithmetic operators item-wise in lists. Contrary to a general @var{expression} which is evaluated at runtime (thanks to an internal stack mechanism), an @var{expression-cst} is completely evaluated during the syntactic analysis of the problem (when GetDP reads the @file{.pro} file). The definition of such constants or lists of constants with identifiers can be made outside or inside any GetDP object. The syntax for the definition of constants is: @example @var{affectation}: DefineConstant [ @var{constant-id} < = @var{expression-cst} > <,@dots{}> ]; | DefineConstant [ @var{constant-id} = @{ @var{expression-cst} <, @var{string} @var{string} > @} <,@dots{}> ]; | DefineConstant [ @var{string-id} < = @var{string-def} > <,@dots{}> ]; | DefineConstant [ @var{string-id} = @{ @var{string-def} <, @var{string} @var{string} > @} <,@dots{}> ]; | @var{constant-id} = @var{constant-def}; | @var{string-id} = @var{string-def}; | Printf [ "@var{string}" ]; | Printf [ "@var{string}", @var{expression-cst-list} ]; | Read [ @var{constant-id} ] ; | Read [ @var{constant-id} , @var{expression-cst} ]; @end example @noindent with @example @var{constant-id}: @var{string} | @var{string} ( @var{expression-cst-list} ) | @var{string} ~ @{ @var{expression-cst} @} @var{constant-def}: @var{expression-cst-list-item} | @{ @var{expression-cst-list} @} | ListFromFile [ @var{expression-char} ] @var{string-id}: @var{string} | @var{string} ~ @{ @var{expression-cst} @} @var{string-def}: "@var{string}" | Str[ @var{expression-char} ] | StrCat[ @var{expression-char}, @var{expression-char} ] @end example @noindent Notes: @enumerate @item Five constants are predefined in GetDP: @code{Pi} (3.1415926535897932), @code{0D} (0), @code{1D} (1), @code{2D} (2) and @code{3D} (3). @item When @code{~@{@var{expression-cst}@}} is appended to a string @var{string}, the result is a new string formed by the concatenation of @var{string}, @code{_} (an underscore) and the value of the @var{expression-cst}. This is most useful in loops (@pxref{Loops and conditionals}), where it permits to define unique strings automatically. For example, @example For i In @{1:3@} x~@{i@} = i; EndFor @end example is the same as @example x_1 = 1; x_2 = 2; x_3 = 3; @end example @item The assignment in @code{DefineConstant} (zero if no @var{expression-cst} is given) is performed only if @var{constant-id} has not yet been defined. This kind of explicit default definition mechanism is most useful in general problem definition structures making use of a large number of generic constants, functions or groups. When exploiting only a part of a complex problem definition structure, the default definition mechanism allows to define the quantities of interest only, the others being assigned a default value (that will not be used during the processing but that avoids the error messages produced when references to undefined quantities are made). @end enumerate See @ref{Constant expression examples}, as well as @ref{Function examples}, for some examples. Character expressions are defined as follows: @example @var{expression-char}: "@var{string}" | @var{string-id} | StrCat[ @var{expression-char} , @var{expression-char} ] | Str[ @var{expression-char} <, @dots{}> ] Sprintf [ @var{expression-char} ] | Sprintf[ @var{expression-char}, @var{expression-cst-list} ] | Date @end example @noindent @code{StrCat} and @code{Str} permit to concatenate character expressions (@code{Str} adds a newline character after each string except the last). @code{Sprintf} is equivalent to the @code{sprintf} C function (where @var{char-expression} is a format string that can contain floating point formatting characters: @code{%e}, @code{%g}, etc.). @code{Date} permits to access the current date. @c ------------------------------------------------------------------------- @c Operators @c ------------------------------------------------------------------------- @node Operators, Functions, Constants, Expressions @section Operators @menu * Operator types:: * Evaluation order:: @end menu @c ......................................................................... @c Types @c ......................................................................... @node Operator types, Evaluation order, Operators, Operators @subsection Operator types The operators in GetDP are similar to the corresponding operators in the C or C++ programming languages. @cindex Operators, definition @cindex Unary operators @cindex Binary operators @cindex Ternary operators @vindex @var{operator-unary} @vindex @var{operator-binary} @vindex @var{operator-ternary-left} @vindex @var{operator-ternary-right} @tindex - @tindex ! @tindex + @tindex - @tindex * @tindex /\ @tindex / @tindex ^ @tindex % @tindex > @tindex < @tindex >= @tindex <= @tindex == @tindex != @tindex || @tindex && @tindex | @tindex & @tindex ?: @noindent @var{operator-unary}: @table @code @item - Unary minus. @item ! Logical not. @end table @noindent @var{operator-binary}: @table @code @item ^ Exponentiation. The evaluation of the both arguments must result in a scalar value. @item * Multiplication or scalar product, depending on the type of the arguments. @item /\ Cross product. The evaluation of both arguments must result in vectors. @item / Division. @item % Modulo. The evaluation of the second argument must result in a scalar value. @item + Addition. @item - Subtraction. @item == Equality. @item != Inequality. @item > Greater. The evaluation of both arguments must result in scalar values. @item >= Greater or equality. The evaluation of both arguments must result in scalar values. @item < Less. The evaluation of both arguments must result in scalar values. @item <= Less or equality. The evaluation of both arguments must result in scalar values. @item && Logical `and'. The evaluation of both arguments must result in scalar values. @item || Logical `or'. The evaluation of both arguments must result in floating point values. Warning: the logical `or' always (unlike in C or C++) implies the evaluation of both arguments. That is, the second operand of @code{||} is evaluated even if the first one is true. @item & Binary `and'. @item | Binary `or'. @end table @noindent @var{operator-ternary-left}: @table @code @item ? @end table @var{operator-ternary-right}: @table @code @item : The only ternary operator, formed by @var{operator-ternary-left} and @var{operator-ternary-right} is defined as in the C or C++ programming languages. The ternary operator first evaluates its first argument (the @var{expression-cst} located before the @code{?}), which must result in a scalar value. If it is true (non-zero) the second argument (located between @code{?} and @code{:}) is evaluated and returned; otherwise the third argument (located after @code{:}) is evaluated and returned. @end table @c ......................................................................... @c Evaluation @c ......................................................................... @node Evaluation order, , Operator types, Operators @subsection Evaluation order @cindex Evaluation, order @cindex Order of evaluation @cindex Operation, priorities @cindex Priorities, operations @tindex () The evaluation priorities are summarized below (from stronger to weaker, i.e., @code{^} has the highest evaluation priority). Parentheses @code{()} may be used anywhere to change the order of evaluation. @table @code @item ^ @item - (unary), ! @item | & @item /\ @item *, /, % @item +, - @item <, >, <=, >= @item !=, == @item &&, || @item ?: @end table @c ------------------------------------------------------------------------- @c Functions @c ------------------------------------------------------------------------- @node Functions, Current values, Operators, Expressions @section Functions @cindex Function, definition @cindex Built-in functions @cindex Piecewise functions @cindex Arguments @cindex Parameters @vindex @var{built-in-function-id} Two types of functions coexist in GetDP: user-defined functions (@var{function-id}, see @ref{Function}) and built-in functions (@var{built-in-function-id}, defined in this section). Both types of functions are always followed by a pair of brackets @code{[]} that can possibly contain arguments (@pxref{Arguments}). This makes it simple to distinguish a @var{function-id} or a @var{built-in-function-id} from a @var{constant-id}. As shown below, built-in functions might also have parameters, given between braces @code{@{@}}, and which are completely evaluated during the analysis of the syntax (since they are of @var{expression-cst-list} type): @example @var{built-in-function-id} [ < @var{expression-list} > ] < @{ @var{expression-cst-list} @} > @end example @noindent with @example @var{built-in-function-id}: @var{math-function-id} | @var{extended-math-function-id} | @var{green-function-id} | @var{type-function-id} | @var{coord-function-id} | @var{misc-function-id} @end example @noindent Notes: @enumerate @item All possible values for @var{built-in-function-id} are listed in @ref{Types for Function}. @item Classical mathematical functions (@pxref{Math functions}) are the only functions allowed in a constant definition (see the definition of @var{expression-cst} in @ref{Constants}). @end enumerate @c ------------------------------------------------------------------------- @c Current Values @c ------------------------------------------------------------------------- @node Current values, Arguments, Functions, Expressions @section Current values @cindex Current values @cindex Values, current @tindex $Time @tindex $DTime @tindex $Theta @tindex $TimeStep @tindex $Breakpoint @tindex $Iteration @tindex $EigenvalueReal @tindex $EigenvalueImag @tindex $X @tindex $XS @tindex $Y @tindex $YS @tindex $Z @tindex $ZS @tindex $A @tindex $B @tindex $C Current values are a special kind of arguments (@pxref{Arguments}) which return the current integer or floating point value of an internal GetDP variable: @table @code @item $Time Value of the current time. This value is set to zero for non time dependent analyses. @item $DTime Value of the current time increment used in a time stepping algorithm. @item $Theta Current theta value in a theta time stepping algorithm. @item $TimeStep Number of the current time step in a time stepping algorithm. @item $Breakpoint In case of a breakpoint hit in TimeLoopAdaptive it is the number of the current breakpoint. In the other case when $Time corresponds not to a breakpoint the value is -1. @item $Iteration Number of the current iteration in a nonlinear loop. @item $EigenvalueReal Real part of the current eigenvalue. @item $EigenvalueImag Imaginary part of the current eigenvalue. @item $X, $XS Value of the current (destination or source) X-coordinate. @item $Y, $YS Value of the current (destination or source) Y-coordinate. @item $Z, $ZS Value of the current (destination or source) Z-coordinate. @item $A, $B, $C Value of the current parametric coordinates used in the parametric @code{OnGrid} @code{PostOperation} (@pxref{Types for PostOperation}). @end table @noindent Note: @enumerate @item The current X, Y and Z coordinates refer to the `physical world' coordinates, i.e., coordinates in which the mesh is expressed. @end enumerate @c ------------------------------------------------------------------------- @c Arguments @c ------------------------------------------------------------------------- @node Arguments, Registers, Current values, Expressions @section Arguments @cindex Arguments, definition @vindex @var{argument} @tindex $@var{integer} Function arguments can be used in expressions and have the following syntax (@var{integer} indicates the position of the argument in the @var{expression-list} of the function, starting from 1): @example @var{argument}: $@var{integer} @end example See @ref{Function}, and @ref{Function examples}, for more details. @c ------------------------------------------------------------------------- @c Registers @c ------------------------------------------------------------------------- @node Registers, Fields, Arguments, Expressions @section Registers @cindex Registers, definition @vindex @var{register-value-set} @vindex @var{register-value-get} @tindex #@var{integer} In many situations, identical parts of expressions are used more than once. If this is not a problem with constant expressions (since @var{expression-cst}s are evaluated only once during the analysis of the problem definition structure, cf.@: @ref{Constants}), it may introduce some important overhead while evaluating complex @var{expression}s (which are evaluated at runtime, thanks to an internal stack mechanism). In order to circumvent this problem, the evaluation result of any part of an @var{expression} can be saved in a register: a memory location where this partial result will be accessible without any costly reevaluation of the partial expression. Registers have the following syntax: @example @var{register-value-set}: @var{expression}#@var{integer} @var{register-value-get}: #@var{integer} @end example @noindent Thus, to store any part of an expression in the register 5, one should add @code{#5} directly after the expression. To reuse the value stored in this register, one simply uses @code{#5} instead of the expression it should replace. See @ref{Function examples}, for an example. @c ------------------------------------------------------------------------- @c Fields @c ------------------------------------------------------------------------- @node Fields, Loops and conditionals, Registers, Expressions @section Fields @cindex Fields @cindex Operators, differential @cindex Differential operators @cindex Discrete quantities @cindex Quantities, discrete @cindex Interpolation @cindex Gradient @cindex Curl @cindex Divergence @cindex Exterior derivative @cindex Derivative, exterior @vindex @var{quantity} @vindex @var{quantity-id} @vindex @var{quantity-dof} @vindex @var{quantity-operator} A discretized quantity (defined in a function space, cf.@: @ref{FunctionSpace}) is represented between braces @code{@{@}}, and can only appear in well-defined expressions in @code{Formulation} (@pxref{Formulation}) and @code{PostProcessing} (@pxref{PostProcessing}) objects: @example @var{quantity}: < @var{quantity-dof} > @{ < @var{quantity-operator} > @var{quantity-id} @} | @{ < @var{quantity-operator} > @var{quantity-id} @} [ @var{expression-cst-list} ] @end example @noindent with @example @var{quantity-id}: @var{string} | @var{string} ~ @{ @var{expression-cst} @} @end example @noindent and @noindent @var{quantity-dof}: @ftable @code @item Dof Defines a vector of discrete quantities (vector of @code{D}egrees @code{o}f @code{f}reedom), to be used only in @code{Equation} terms of formulations to define (elementary) matrices. Roughly said, the @code{Dof} symbol in front of a discrete quantity indicates that this quantity is an unknown quantity, and should therefore not be considered as already computed. An @code{Equation} term must be linear with respect to the @code{Dof}. Thus, for example, a nonlinear term like @example Galerkin @{ [ f[] * Dof@{T@}^4 , @{T@} ]; @dots{} @} @end example must first be linearized; and while @example Galerkin @{ [ f[] * Dof@{T@} , @{T@} ]; @dots{} @} Galerkin @{ [ -f[] * 12 , @{T@} ]; @dots{} @} @end example is valid, the following, which is affine but not linear, is not: @example Galerkin @{ [ f[] * (Dof@{T@} - 12) , @{T@} ]; @dots{} @} @end example GetDP supports two linearization techniques. The first is functional iteration (or Picard method), where one simply plugs the value obtained at the previous iteration into the nonlinear equation (the previous value is known, and is accessed e.g. with @code{@{T@}} instead @code{Dof@{T@}}). The second is the Newton-Raphson iteration, where the Jacobian is specified with a @code{JacNL} equation term (see @url{https://geuz.org/trac/getdp} for an example). @item BF Indicates that only a basis function will be used (only valid with basis functions associated with regions). @end ftable @noindent @var{quantity-operator}: @ftable @code @item d Exterior derivative (d): applied to a @var{p}-form, gives a (@var{p+1})-form. @item Grad Gradient: applied to a scalar field, gives a vector. @item Curl @itemx Rot Curl: applied to a vector field, gives a vector. @item Div Divergence (div): applied to a vector field, gives a scalar. @item dInv d^(-1): applied to a p-form, gives a (p-1)-form. @item GradInv Inverse grad: applied to a gradient field, gives a scalar. @item CurlInv @itemx RotInv Inverse curl: applied to a curl field, gives a vector. @item DivInv Inverse div: applied to a divergence field. @end ftable @noindent Notes: @enumerate @item While the operators @code{Grad}, @code{Curl} and @code{Div} can be applied to 0, 1 and 2-forms respectively, the exterior derivative operator @code{d} is usually preferred with such fields. @item The second case permits to evaluate a discretized quantity at a certain position X, Y, Z (when @var{expression-cst-list} contains three items) or at a specific time, N time steps ago (when @var{expression-cst-list} contains a single item). @end enumerate @c ------------------------------------------------------------------------- @c Loops and conditionals @c ------------------------------------------------------------------------- @node Loops and conditionals, , Fields, Expressions @section Loops and conditionals @cindex Loops @cindex Conditionals @vindex @var{loop} Loops and conditionals are defined as follows, and can be imbricated: @var{loop}: @ftable @code @item For ( @var{expression-cst} : @var{expression-cst} ) Iterates from the value of the first @var{expression-cst} to the value of the second @var{expression-cst}, with a unit incrementation step. At each iteration, the commands comprised between `@code{For ( @var{expression-cst} : @var{expression-cst} )}' and the matching @code{EndFor} are executed. @item For ( @var{expression-cst} : @var{expression-cst} : @var{expression-cst} ) Iterates from the value of the first @var{expression-cst} to the value of the second @var{expression-cst}, with a positive or negative incrementation step equal to the third @var{expression-cst}. At each iteration, the commands comprised between `@code{For ( @var{expression-cst} : @var{expression-cst} : @var{expression-cst} )}' and the matching @code{EndFor} are executed. @item For @var{string} In @{ @var{expression-cst} : @var{expression-cst} @} Iterates from the value of the first @var{expression-cst} to the value of the second @var{expression-cst}, with a unit incrementation step. At each iteration, the value of the iterate is affected to an expression named @var{string}, and the commands comprised between `@code{For @var{string} In @{ @var{expression-cst} : @var{expression-cst} @}}' and the matching @code{EndFor} are executed. @item For @var{string} In @{ @var{expression-cst} : @var{expression-cst} : @var{expression-cst} @} Iterates from the value of the first @var{expression-cst} to the value of the second @var{expression-cst}, with a positive or negative incrementation step equal to the third @var{expression-cst}. At each iteration, the value of the iterate is affected to an expression named @var{string}, and the commands comprised between `@code{For @var{string} In @{ @var{expression-cst} : @var{expression-cst} : @var{expression-cst} @}}' and the matching @code{EndFor} are executed. @item EndFor Ends a matching @code{For} command. @item If ( @var{expression-cst} ) The body enclosed between `@code{If ( @var{expression-cst} )}' and the matching @code{Endif} is evaluated if @var{expression-cst} is non-zero. @item EndIf Ends a matching @code{If} command. @end ftable Loops and conditionals can be used in any of the following objects: Group, Function, Constraint (as well as in a contraint-case), FunctionSpace, Formulation (as well as in the quantity and equation defintions), Resolution (as well as resolution-term, system defintion and operations), PostProcessing (in the definition of the PostQuantities) and PostOperation (as well as in the operation list). @c ========================================================================= @c Objects @c ========================================================================= @node Objects, Types for objects, Expressions, Top @chapter Objects @cindex Objects, definition This chapter presents the formal definition of the ten GetDP objects mentioned in @ref{Overview}. To be concise, all the possible parameters for these objects are not given here (cf.@: the @var{etc} syntactic rule defined in @ref{Syntactic rules}). Please refer to @ref{Types for objects}, for the list of all available options. @menu * Group:: * Function:: * Constraint:: * FunctionSpace:: * Jacobian:: * Integration:: * Formulation:: * Resolution:: * PostProcessing:: * PostOperation:: @end menu @c ------------------------------------------------------------------------- @c Group @c ------------------------------------------------------------------------- @node Group, Function, Objects, Objects @section @code{Group}: defining topological entities @cindex Mesh @cindex Grid @cindex Discretized Geometry @cindex Group, definition @cindex Topology @cindex Entities, topological @cindex Region groups @cindex Function groups @cindex Tree @tindex Group @tindex DefineGroup @tindex = @vindex @var{group-id} @vindex @var{group-def} @vindex @var{group-type} @vindex @var{group-list} @vindex @var{group-list-item} @vindex @var{group-sub-type} Meshes (grids) constitute the input data of GetDP. All that is needed by GetDP as a mesh is a file containing a list of nodes (with their coordinates) and a list of geometrical elements with, for each one, a number characterizing its geometrical type (i.e., line, triangle, quadrangle, tetrahedron, hexahedron, prism, etc.), a number characterizing the physical region to which it belongs and the list of its nodes. This minimal input set should be easy to extract from most of the classical mesh file formats (@pxref{Input file format}, for a complete description of the mesh file format read by GetDP). Groups of geometrical entities of various types can be considered and are used in many objects. There are region groups, of which the entities are regions, and function groups, with nodes, edges, facets, volumes, groups of nodes, edges of tree, facets of tree, @dots{} of regions. Amongst region groups, elementary and global groups can be distinguished: elementary groups are relative to single regions (e.g., physical regions in which piecewise defined functions or constraints can be defined) while global groups are relative to sets of regions for which given treatments have to be performed (e.g., domain of integration, support of a function space, etc.). Groups of function type contain lists of entities built on some region groups (e.g., nodes for nodal elements, edges for edge elements, edges of tree for gauge conditions, groups of nodes for floating potentials, elements on one side of a surface for cuts, etc.). A definition of initially empty groups can be obtained thanks to a @code{DefineGroup} command, so that their identifiers exist and can be referred to in other objects, even if these groups are not explicitly defined. This procedure is similar to the @code{DefineConstant} procedure introduced for constants in @ref{Constants}. The syntax for the definition of groups is: @example Group @{ < DefineGroup [ @var{group-id} <@{@var{integer}@}> <,@dots{}> ]; > @dots{} < @var{group-id} = @var{group-def}; > @dots{} < @var{group-id} += @var{group-def}; > @dots{} < @var{affectation} > @dots{} < @var{loop} > @dots{} @} @end example @noindent with @example @var{group-id}: @var{string} | @var{string} ~ @{ @var{expression-cst} @} @var{group-def}: @var{group-type} [ @var{group-list} <, @var{group-sub-type} @var{group-list} > ] | @var{group-id} <@{<@var{integer}>@}> | #@var{group-list} @var{group-type}: Region | Global | NodesOf | EdgesOf | @var{etc} @var{group-list}: All | @var{group-list-item} | @{ @var{group-list-item} <,@dots{}> @} @var{group-list-item}: @var{integer} | @var{integer} : @var{integer} | @var{integer} : @var{integer} : @var{integer} | @var{group-id} <@{<@var{integer}>@}> @var{group-sub-type}: Not | StartingOn | OnOneSideOf | @var{etc} @end example @noindent Notes: @enumerate @item @var{integer} as a @var{group-list-item} is the only interface with the mesh; with each element is associated a region number, being this @var{integer}, and a geometrical type (@pxref{Input file format}). Ranges of integers can be specified in the same way as ranges of constant expressions in an @var{expression-cst-list-item} (@pxref{Constants}). For example, @code{@var{i}:@var{j}} replaces the list of consecutive integers @var{i}, @var{i}+1, @dots{}, @var{j}-1, @var{j}. @item Array of groups: @code{DefineGroup[@var{group-id}@{@var{n}@}]} defines the empty groups @code{@var{group-id}@{@var{i}@}}, @var{i}=1, @dots{}, n. Such a definition is optional, i.e., each @code{@var{group-id}@{@var{i}@}} can be separately defined, in any order. @item @code{#@var{group-list}} is an abbreviation of @code{Region[@var{group-list}]}. @end enumerate See @ref{Types for Group}, for the complete list of options and @ref{Group examples}, for some examples. @c ------------------------------------------------------------------------- @c Function @c ------------------------------------------------------------------------- @node Function, Constraint, Group, Objects @section @code{Function}: defining global and piecewise expressions @cindex Function, definition @cindex Piecewise functions @cindex User-defined functions @tindex Function @tindex DefineFunction @tindex = @vindex @var{function-id} A user-defined function can be global in space or piecewise defined in region groups. A physical characteristic is an example of a piecewise defined function (e.g., magnetic permeability, electric conductivity, etc.) and can be simply a constant, for linear materials, or a function of one or several arguments for nonlinear materials. Such functions can of course depend on space coordinates or time, which can be needed to express complex constraints. A definition of initially empty functions can be made thanks to the @code{DefineFunction} command so that their identifiers exist and can be referred to (but cannot be used) in other objects. The syntax for the definition of functions is: @example Function @{ < DefineFunction [ @var{function-id} <,@dots{}> ]; > @dots{} < @var{function-id} [ < @var{group-def} > ] = @var{expression}; > @dots{} < @var{affectation} > @dots{} < @var{loop} > @dots{} @} @end example @noindent with @example @var{function-id}: @var{string} @end example @noindent Note: @enumerate @item The optional @var{group-def} in brackets must be of @code{Region} type, and indicates on which region the (piecewise) function is defined. Warning: it is incorrect to write @code{f[reg1]=1; g[reg2]=f[]+1;} since the domains of definition of @code{f[]} and @code{g[]} don't match. @item One can also define initially empty functions inline by replacing the expression with @code{***}. @end enumerate See @ref{Types for Function}, for the complete list of built-in functions and @ref{Function examples}, for some examples. @c ------------------------------------------------------------------------- @c Constraint @c ------------------------------------------------------------------------- @node Constraint, FunctionSpace, Function, Objects @section @code{Constraint}: specifying constraints on function spaces and formulations @cindex Constraint, definition @cindex Circuit equations @cindex Boundary conditions @cindex Networks @tindex Constraint @tindex Name @tindex Type @tindex Case @tindex Region @tindex SubRegion @tindex TimeFunction @vindex @var{constraint-id} @vindex @var{constraint-type} @vindex @var{constraint-val} @vindex @var{constraint-case-id} @vindex @var{constraint-case-val} Constraints can be referred to in @code{FunctionSpace} objects to be used for boundary conditions, to impose global quantities or to initialize quantities. These constraints can be expressed with functions or be imposed by the pre-resolution of another discrete problem. Other constraints can also be defined, e.g., constraints of network type for the definition of circuit connections, to be used in @code{Formulation} objects. The syntax for the definition of constraints is: @example Constraint @{ @{ Name @var{constraint-id}; Type @var{constraint-type}; Case @{ @{ Region @var{group-def}; < Type @var{constraint-type}; > < SubRegion @var{group-def}; > < TimeFunction @var{expression}; > < RegionRef @var{group-def}; > < SubRegionRef @var{group-def}; > < Coefficient @var{expression}; > < Function @var{expression}; > < Filter @var{expression}; > @var{constraint-val}; @} @dots{} < @var{loop} > @dots{} @} | Case @var{constraint-case-id} @{ @{ Region @var{group-def}; < Type @var{constraint-type}; > @var{constraint-case-val}; @} @dots{} < @var{loop} > @dots{} @} @dots{} @} @dots{} < @var{affectation} > @dots{} < @var{loop} > @dots{} @} @end example @noindent with @example @var{constraint-id}: @var{constraint-case-id}: @var{string} | @var{string} ~ @{ @var{expression-cst} @} @var{constraint-type}: Assign | Init | Network | Link | @var{etc} @var{constraint-val}: Value @var{expression} | NameOfResolution @var{resolution-id} | @var{etc} @var{constraint-case-val}: Branch @{ @var{integer}, @var{integer} @} | @var{etc} @end example @noindent Notes: @enumerate @item The constraint type @var{constraint-type} defined outside the @code{Case} fields is applied to all the cases of the constraint, unless other types are explicitly given in these cases. The default type is @code{Assign}. @item The region type @code{Region @var{group-def}} will be the main @var{group-list} argument of the @var{group-def} to be built for the constraints of @code{FunctionSpace}s. The optional region type @code{SubRegion @var{group-def}} will be the argument of the associated @var{group-sub-type}. @item @var{expression} in @code{Value} of @var{constraint-val} cannot be time dependent (@code{$Time}) because it is evaluated only once during the pre-processing (for efficiency reasons). Time dependences must be defined in @code{TimeFunction @var{expression}}. @end enumerate See @ref{Types for Constraint}, for the complete list of options and @ref{Constraint examples}, for some examples. @c ------------------------------------------------------------------------- @c FunctionSpace @c ------------------------------------------------------------------------- @node FunctionSpace, Jacobian, Constraint, Objects @section @code{FunctionSpace}: building function spaces @cindex Function space, definition @cindex Discrete function spaces @cindex Spaces, discrete @cindex Approximation spaces @cindex Basis Functions @cindex Interpolation @cindex Hierarchical basis functions @tindex FunctionSpace @tindex Name @tindex Type @tindex BasisFunction @tindex NameOfCoef @tindex Function @tindex Quantity @tindex Formulation @tindex Group @tindex Resolution @tindex Support @tindex Entity @tindex SubSpace @tindex NameOfBasisFunction @tindex GlobalQuantity @tindex Constraint @tindex EntityType @tindex EntitySubType @tindex NameOfConstraint @vindex @var{function-space-id} @vindex @var{function-space-type} @vindex @var{basis-function-id} @vindex @var{basis-function-type} @vindex @var{coef-id} @vindex @var{sub-space-id} @vindex @var{basis-function-list} @vindex @var{global-quantity-id} @vindex @var{global-quantity-type} A @code{FunctionSpace} is characterized by the type of its interpolated fields, one or several basis functions and optional constraints (in space and time). Subspaces of a function space can be defined (e.g., for the use with hierarchical elements), as well as direct associations of global quantities (e.g., floating potential, electric charge, current, voltage, magnetomotive force, etc.). A key point is that basis functions are defined by any number of subsets of functions, being added. Each subset is characterized by associated built-in functions for evaluation, a support of definition and a set of associated supporting geometrical entities (e.g., nodes, edges, facets, volumes, groups of nodes, edges incident to a node, etc.). The freedom in defining various kinds of basis functions associated with different geometrical entities to interpolate a field permits to build made-to-measure function spaces adapted to a wide variety of field approximations (@pxref{FunctionSpace examples}). The syntax for the definition of function spaces is: @example FunctionSpace @{ @{ Name @var{function-space-id}; Type @var{function-space-type}; BasisFunction @{ @{ Name @var{basis-function-id}; NameOfCoef @var{coef-id}; Function @var{basis-function-type} < @{ Quantity @var{quantity-id}; Formulation @var{formulation-id} @{#@var{integer}@}; Group @var{group-def}; Resolution @var{resolution-id} @{@} @} >; Support @var{group-def}; Entity @var{group-def}; @} @dots{} @} < SubSpace @{ @{ Name @var{sub-space-id}; NameOfBasisFunction @var{basis-function-list}; @} @dots{} @} > < GlobalQuantity @{ @{ Name @var{global-quantity-id}; Type @var{global-quantity-type}; NameOfCoef @var{coef-id}; @} @dots{} @} > < Constraint @{ @{ NameOfCoef @var{coef-id}; EntityType @var{group-type}; < EntitySubType @var{group-sub-type}; > NameOfConstraint @var{constraint-id} <@{@}>; @} @dots{} @} > @} @dots{} < @var{affectation} > @dots{} < @var{loop} > @dots{} @} @end example @noindent with @example @var{function-space-id}: @var{formulation-id}: @var{resolution-id}: @var{string} | @var{string} ~ @{ @var{expression-cst} @} @var{basis-function-id}: @var{coef-id}: @var{sub-space-id}: @var{global-quantity-id}: @var{string} @var{function-space-type}: Scalar | Vector | Form0 | Form1 | @var{etc} @var{basis-function-type}: BF_Node | BF_Edge | @var{etc} @var{basis-function-list}: @var{basis-function-id} | @{ @var{basis-function-id} <,@dots{}> @} @var{global-quantity-type}: AliasOf | AssociatedWith @end example @noindent Notes: @enumerate @item When the definition region of a function type group used as an @code{Entity} of a @code{BasisFunction} is the same as that of the associated @code{Support}, it is replaced by @code{All} for more efficient treatments during the computation process (this prevents the construction and the analysis of a list of geometrical entities). @item Piecewise defined basis functions: the same @code{Name} for several @code{BasisFunction} fields permits to define piecewise basis functions; separate @code{NameOfCoef}s must be defined for those fields. @item Constraint: a constraint is associated with geometrical entities defined by an automatically created @code{Group} of type @var{group-type}, using the @code{Region} defined in a @code{Constraint} object as its main argument, and the optional @code{SubRegion} in the same object as a @var{group-sub-type} argument. @item Function: a global basis function (@code{BF_Global} or @code{BF_dGlobal}) needs parameters, i.e., it is given by the quantity (@var{quantity-id}) pre-computed from multiresolutions performed on multiformulations. @end enumerate See @ref{Types for FunctionSpace}, for the complete list of options and @ref{FunctionSpace examples}, for some examples. @c ------------------------------------------------------------------------- @c Jacobian @c ------------------------------------------------------------------------- @node Jacobian, Integration, FunctionSpace, Objects @section @code{Jacobian}: defining jacobian methods @cindex Jacobian, definition @cindex Transformations, geometric @cindex Geometric transformations @cindex Coordinate change @cindex Change of coordinates @cindex Axisymmetric, transformation @tindex Jacobian @tindex Name @tindex Case @tindex Region @tindex All @vindex @var{jacobian-id} @vindex @var{jacobian-type} Jacobian methods can be referred to in @code{Formulation} and @code{PostProcessing} objects to be used in the computation of integral terms and for changes of coordinates. They are based on @code{Group} objects and define the geometrical transformations applied to the reference elements (i.e., lines, triangles, quadrangles, tetrahedra, prisms, hexahedra, etc.). Besides the classical lineic, surfacic and volume Jacobians, the @code{Jacobian} object allows the construction of various transformation methods (e.g., infinite transformations for unbounded domains) thanks to dedicated jacobian methods. The syntax for the definition of Jacobian methods is: @example Jacobian @{ @{ Name @var{jacobian-id}; Case @{ @{ Region @var{group-def} | All; Jacobian @var{jacobian-type} < @{ @var{expression-cst-list} @} >; @} @dots{} @} @} @dots{} @} @end example @noindent with @example @var{jacobian-id}: @var{string} @var{jacobian-type}: Vol | Sur | VolAxi | @var{etc} @end example @noindent Note: @enumerate @item The default case of a @code{Jacobian} object is defined by @code{Region All} and must follow all the other cases. @end enumerate See @ref{Types for Jacobian}, for the complete list of options and @ref{Jacobian examples}, for some examples. @c ------------------------------------------------------------------------- @c Integration @c ------------------------------------------------------------------------- @node Integration, Formulation, Jacobian, Objects @section @code{Integration}: defining integration methods @cindex Integration, definition @cindex Analytical integration @cindex Numerical integration @cindex Gauss, integration @tindex Integration @tindex Name @tindex Criterion @tindex Case @tindex Type @tindex GeoElement @tindex NumberOfPoints @tindex Analytic @vindex @var{integration-id} @vindex @var{element-type} @vindex @var{integration-type} Various numerical or analytical integration methods can be referred to in @code{Formulation} and @code{PostProcessing} objects to be used in the computation of integral terms, each with a set of particular options (number of integration points for quadrature methods---which can be linked to an error criterion for adaptative methods, definition of transformations for singular integrations, etc.). Moreover, a choice can be made between several integration methods according to a criterion (e.g., on the proximity between the source and computation points in integral formulations). The syntax for the definition of integration methods is: @example Integration @{ @{ Name @var{integration-id}; < Criterion @var{expression}; > Case @{ < @{ Type @var{integration-type}; Case @{ @{ GeoElement @var{element-type}; NumberOfPoints @var{expression-cst} @} @dots{} @} @} @dots{} > < @{ Type Analytic; @} @dots{} > @} @} @dots{} @} @end example @noindent with @example @var{integration-id}: @var{string} @var{integration-type}: Gauss | @var{etc} @var{element-type}: Line | Triangle | Tetrahedron @var{etc} @end example See @ref{Types for Integration}, for the complete list of options and @ref{Integration examples}, for some examples. @c ------------------------------------------------------------------------- @c Formulation @c ------------------------------------------------------------------------- @node Formulation, Resolution, Integration, Objects @section @code{Formulation}: building equations @cindex Formulation, definition @cindex Equations @cindex Time derivative @cindex Derivative, time @cindex Elementary matrices @cindex Matrices, elementary @cindex Local quantity @cindex Global quantity @cindex Integral quantity @cindex Quantity, local @cindex Quantity, global @cindex Quantity, integral @cindex Symmetry, integral kernel @tindex Formulation @tindex Name @tindex Type @tindex Quantity @tindex NameOfSpace @tindex Symmetry @tindex In @tindex Jacobian @tindex Integration @tindex IndexOfSystem @tindex Equation @tindex GlobalTerm @tindex GlobalEquation @tindex Network @tindex NameOfConstraint @tindex Node @tindex Loop @vindex @var{formulation-id} @vindex @var{formulation-type} @vindex @var{local-term-type} @vindex @var{quantity-type} @vindex @var{term-op-type} The @code{Formulation} tool permits to deal with volume, surface and line integrals with many kinds of densities to integrate, written in a form that is similar to their symbolic expressions (it uses the same @var{expression} syntax as elsewhere in GetDP), which therefore permits to directly take into account various kinds of elementary matrices (e.g., with scalar or cross products, anisotropies, nonlinearities, time derivatives, various test functions, etc.). In case nonlinear physical characteristics are considered, arguments are used for associated functions. In that way, many formulations can be directly written in the data file, as they are written symbolically. Fields involved in each formulation are declared as belonging to beforehand defined function spaces. The uncoupling between formulations and function spaces allows to maintain a generality in both their definitions. A @code{Formulation} is characterized by its type, the involved quantities (of local, global or integral type) and a list of equation terms. Global equations can also be considered, e.g., for the coupling with network relations. The syntax for the definition of formulations is: @example Formulation @{ @{ Name @var{formulation-id}; Type @var{formulation-type}; Quantity @{ @{ Name @var{quantity-id}; Type @var{quantity-type}; NameOfSpace @var{function-space-id} <@{@}> < [ @var{sub-space-id} | @var{global-quantity-id} ] >; < Symmetry @var{expression-cst}; > < [ @var{expression} ]; In @var{group-def}; Jacobian @var{jacobian-id}; Integration @var{integration-id}; > < IndexOfSystem @var{integer}; > @} @dots{} @} Equation @{ < @var{local-term-type} @{ < @var{term-op-type} > [ @var{expression}, @var{expression} ]; In @var{group-def}; Jacobian @var{jacobian-id}; Integration @var{integration-id}; @} > @dots{} < GlobalTerm @{ < @var{term-op-type} > [ @var{expression}, @var{expression} ]; In @var{group-def}; @} > @dots{} < GlobalEquation @{ Type Network; NameOfConstraint @var{constraint-id}; @{ Node @var{expression}; Loop @var{expression}; Equation @var{expression}; In @var{group-def}; @} @dots{} @} > @dots{} < @var{affectation} > @dots{} < @var{loop} > @dots{} @} @} @dots{} < @var{affectation} > @dots{} < @var{loop} > @dots{} @} @end example @noindent with @example @var{formulation-id}: @var{string} | @var{string} ~ @{ @var{expression-cst} @} @var{formulation-type}: FemEquation | @var{etc} @var{local-term-type}: Galerkin | deRham @var{quantity-type}: Local | Global | Integral @var{term-op-type}: DtDof | DtDtDof | JacNL | @var{etc} @end example @noindent Note: @enumerate @item @code{IndexOfSystem} permits to resolve ambiguous cases when several quantities belong to the same function space, but to different systems of equations. The @var{integer} parameter then specifies the index in the list of an @code{OriginSystem} command (@pxref{Resolution}). @item A @code{GlobalTerm} defines a term to be assembled in an equation associated with a global quantity. This equation is a finite element equation if that global quantity is linked with local quantities. @item A @code{GlobalEquation} defines a global equation to be assembled in the matrix of the system. @end enumerate See @ref{Types for Formulation}, for the complete list of options and @ref{Formulation examples}, for some examples. @c ------------------------------------------------------------------------- @c Resolution @c ------------------------------------------------------------------------- @node Resolution, PostProcessing, Formulation, Objects @section @code{Resolution}: solving systems of equations @cindex Resolution, definition @cindex Linear system solving @cindex Nonlinear system solving @cindex Iterative loop @cindex Relaxation factor @cindex Newton, nonlinear scheme @cindex Picard, nonlinear scheme @cindex Newmark, time scheme @cindex Theta, time scheme @cindex Solving, system @cindex Time stepping @cindex Time, discretization @cindex Frequency @cindex System, definition @cindex Complex-valued, system @tindex Resolution @tindex Name @tindex System @tindex NameOfFormulation @tindex Type @tindex Frequency @tindex DestinationSystem @tindex OriginSystem @tindex NameOfMesh @tindex Solver @tindex Operation @vindex @var{resolution-id} @vindex @var{system-id} @vindex @var{system-type} @vindex @var{formulation-list} @vindex @var{resolution-op} The operations available in a @code{Resolution} include: the generation of a linear system, its solving with various kinds of linear solvers, the saving of the solution or its transfer to another system, the definition of various time stepping methods, the construction of iterative loops for nonlinear problems (Newton-Raphson and fixed point methods), etc. Multi-harmonic resolutions, coupled problems (e.g., magneto-thermal) or linked problems (e.g., pre-computations of source fields) are thus easily defined in GetDP. The @code{Resolution} object is characterized by a list of systems to build and their associated formulations, using time or frequency domain, and a list of elementary operations: @example Resolution @{ @{ Name @var{resolution-id}; System @{ @{ Name @var{system-id}; NameOfFormulation @var{formulation-list}; < Type @var{system-type}; > < Frequency @var{expression-cst-list-item} | Frequency @{ @var{expression-cst-list} @}; > < DestinationSystem @var{system-id}; > < OriginSystem @var{system-id}; | OriginSystem @{ @var{system-id} <,@dots{}> @}; > < NameOfMesh @var{expression-char} > < Solver @var{expression-char} > < @var{loop} > @} @dots{} < @var{loop} > @dots{} @} Operation @{ < @var{resolution-op}; > @dots{} < @var{loop} > @dots{} @} @} @dots{} < @var{affectation} > @dots{} < @var{loop} > @dots{} @} @end example @noindent with @example @var{resolution-id}: @var{system-id}: @var{string} | @var{string} ~ @{ @var{expression-cst} @} @var{formulation-list}: @var{formulation-id} <@{@}> | @{ @var{formulation-id} <@{@}> <,@dots{}> @} @var{system-type}: Real | Complex @var{resolution-op}: Generate[@var{system-id}] | Solve[@var{system-id}] | @var{etc} @end example @noindent Notes: @enumerate @item The default type for a system of equations is @code{Real}. A frequency domain analysis is defined through the definition of one or several frequencies (@code{Frequency @var{expression-cst-list-item} | Frequency @{ @var{expression-cst-list} @}}). Complex systems of equations with no predefined list of frequencies (e.g., in modal analyses) can be explicitely defined with @code{Type Complex}. @item @code{NameOfMesh} permits to explicitely specify the mesh to be used for the construction of the system of equations. @item @code{Solver} permits to explicitely specify the name of the solver parameter file to use for the solving of the system of equations. This is ony valid if GetDP was compiled against the default solver library (it is the case if you downloaded a pre-compiled copy of GetDP from the internet). @item @code{DestinationSystem} permits to specify the destination system of a @code{TransferSolution} operation (@pxref{Types for Resolution}). @item @code{OriginSystem} permits to specify the systems from which ambiguous quantity definitions can be solved (@pxref{Formulation}). @end enumerate See @ref{Types for Resolution}, for the complete list of options and @ref{Resolution examples}, for some examples. @c ------------------------------------------------------------------------- @c PostProcessing @c ------------------------------------------------------------------------- @node PostProcessing, PostOperation, Resolution, Objects @section @code{PostProcessing}: exploiting computational results @cindex Post-processing, definition @cindex Quantity, post-processing @cindex Results, exploitation @tindex PostProcessing @tindex Name @tindex NameOfFormulation @tindex NameOfSystem @tindex Quantity @tindex Value @tindex Local @tindex Integral @tindex In @tindex Integration @tindex Jacobian @vindex @var{post-processing-id} @vindex @var{post-quantity-id} @vindex @var{post-quantity-type} @vindex @var{post-value} @vindex @var{local-value} @vindex @var{integral-value} The @code{PostProcessing} object is based on the quantities defined in a @code{Formulation} and permits the construction (thanks to the @var{expression} syntax) of any useful piecewise defined quantity of interest: @example PostProcessing @{ @{ Name @var{post-processing-id}; NameOfFormulation @var{formulation-id} <@{@}>; < NameOfSystem @var{system-id}; > Quantity @{ @{ Name @var{post-quantity-id}; Value @{ @var{post-value} @dots{} @} @} @dots{} < @var{loop} > @dots{} @} @} @dots{} < @var{affectation} > @dots{} < @var{loop} > @dots{} @} @end example @noindent with @example @var{post-processing-id}: @var{post-quantity-id}: @var{string} | @var{string} ~ @{ @var{expression-cst} @} @var{post-value}: Local @{ @var{local-value} @} | Integral @{ @var{integral-value} @} @var{local-value}: [ @var{expression} ]; In @var{group-def}; Jacobian @var{jacobian-id}; @var{integral-value}: [ @var{expression} ]; In @var{group-def}; Integration @var{integration-id}; Jacobian @var{jacobian-id}; @end example @noindent Notes: @enumerate @item The quantity defined with @var{integral-value} is piecewise defined over the elements of the mesh of @var{group-def}, and takes, in each element, the value of the integration of @var{expression} over this element. The global integral of @var{expression} over a whole region (being either @var{group-def} or a subset of @var{group-def}) has to be defined in the @code{PostOperation} with the @code{@var{post-quantity-id}[@var{group-def}]} command (@pxref{PostOperation}). @item If @code{NameOfSystem @var{system-id}} is not given, the system is automatically selected as the one to which the first quantity listed in the @code{Quantity} field of @var{formulation-id} is associated. @end enumerate See @ref{Types for PostProcessing}, for the complete list of options and @ref{PostProcessing examples}, for some examples. @c ------------------------------------------------------------------------- @c PostOperation @c ------------------------------------------------------------------------- @node PostOperation, , PostProcessing, Objects @section @code{PostOperation}: exporting results @cindex Post-operation, definition @cindex Exporting results @cindex Results, export @cindex Sections @cindex Maps @cindex Format, output @tindex PostOperation @tindex Name @tindex NameOfPostProcessing @tindex Format @tindex Operation @tindex UsingPost @tindex Print @vindex @var{post-operation-id} @vindex @var{post-operation-op} @vindex @var{post-operation-fmt} @vindex @var{print-support} @vindex @var{print-option} The @code{PostOperation} is the bridge between results obtained with GetDP and the external world. It defines several elementary operations on @code{PostProcessing} quantities (e.g., plot on a region, section on a user-defined plane, etc.), and outputs the results in several file formats. @example PostOperation @{ @{ Name @var{post-operation-id}; NameOfPostProcessing @var{post-processing-id}; < Format @var{post-operation-fmt}; > < Append @var{expression-char}; > < ResampleTime[@var{expression-cst}, @var{expression-cst}, @var{expression-cst}]; > Operation @{ < @var{post-operation-op}; > @dots{} @} @} @dots{} < @var{affectation} > @dots{} < @var{loop} > @dots{} @} | PostOperation @var{post-operation-id} UsingPost @var{post-processing-id} @{ < @var{post-operation-op}; > @dots{} @} @dots{} @end example @noindent with @example @var{post-operation-id}: @var{string} | @var{string} ~ @{ @var{expression-cst} @} @var{post-operation-op}: Print[ @var{post-quantity-term}, @var{print-support} <,@var{print-option}> @dots{} ] | Print[ "@var{string}", @var{expression} <,@var{print-option}> @dots{} ] | Print[ "@var{string}", Str[ @var{expression-char} ] <,@var{print-option}> @dots{} ] | Echo[ "@var{string}" <,@var{print-option}> @dots{} ] | PrintGroup[ @var{group-id}, @var{print-support} <,@var{print-option}> @dots{} ] | < @var{loop} > @dots{} @var{etc} @var{post-quantity-term}: @var{post-quantity-id} <[@var{group-def}]> | @var{post-quantity-id} @var{post-quantity-op} @var{post-quantity-id}[@var{group-def}] | @var{post-quantity-id}[@var{group-def}] @var{post-quantity-op} @var{post-quantity-id} @var{post-quantity-op}: + | - | * | / @var{print-support}: OnElementsOf @var{group-def} | OnRegion @var{group-def} | OnGlobal | @var{etc} @var{print-option}: File @var{expression-char} | Format @var{post-operation-fmt} | @var{etc} @var{post-operation-fmt}: Table | TimeTable | @var{etc} @end example @noindent Notes: @enumerate @item Both @code{PostOperation} syntaxes are equivalent. The first one conforms to the overall interface, but the second one is more concise. @item The format @var{post-operation-fmt} defined outside the @code{Operation} field is applied to all the post-processing operations, unless other formats are explicitly given in these operations with the @code{Format} option (@pxref{Types for PostOperation}). The default format is @code{Gmsh}. @item The @code{ResampleTime} option allows equidistant resampling of the time steps by a spline interpolation. The parameters are: start time, stop time, time step. @item The optional argument @code{[@var{group-def}]} of the @var{post-quantity-id} can only be used when this quantity has been defined as an @var{integral-value} (@pxref{PostProcessing}). In this case, the sum of all elementary integrals is performed over the region @var{group-def}. @item The @var{post-quantity-op} allows the simple combination of space-dependent quantities (@var{post-quantity-id}) with global integral quantities (@code{@var{post-quantity-id}[@var{group-def}]}). @end enumerate See @ref{Types for PostOperation}, for the complete list of options and @ref{PostOperation examples}, for some examples. @c ========================================================================= @c Types for Objects @c ========================================================================= @node Types for objects, Short examples, Objects, Top @chapter Types for objects This chapter presents the complete list of choices associated with metasyntactic variables introduced for the ten GetDP objects. @cindex Types, definition @cindex Objects, types @menu * Types for Group:: * Types for Function:: * Types for Constraint:: * Types for FunctionSpace:: * Types for Jacobian:: * Types for Integration:: * Types for Formulation:: * Types for Resolution:: * Types for PostProcessing:: * Types for PostOperation:: @end menu @c ------------------------------------------------------------------------- @c Group @c ------------------------------------------------------------------------- @node Types for Group, Types for Function, Types for objects, Types for objects @section Types for @code{Group} @cindex Group, types @vindex @var{group-type} @noindent Types in @example @var{group-type} [ @var{R1} <, @var{group-sub-type} @var{R2} > ] @end example @noindent @code{@var{group-type} < @var{group-sub-type} >}: @ftable @code @item Region Regions in @var{R1}. @item Global Regions in @var{R1} (variant of @code{Region} used with global @code{BasisFunction}s @code{BF_Global} and @code{BF_dGlobal}). @item NodesOf Nodes of elements of @var{R1} < @code{Not}: but not those of @var{R2} >. @item EdgesOf Edges of elements of @var{R1} < @code{Not}: but not those of @var{R2} >. @item FacetsOf Facets of elements of @var{R1} < @code{Not}: but not those of @var{R2} >. @item VolumesOf Volumes of elements of @var{R1} < @code{Not}: but not those of @var{R2} >. @item ElementsOf Elements of regions in @var{R1} < @code{OnOneSideOf}: only elements on one side of @var{R2}) >. @item GroupsOfNodesOf Groups of nodes of elements of @var{R1} (a group is associated with each region). @item GroupsOfEdgesOf Groups of edges of elements of @var{R1} (a group is associated with each region). < @code{InSupport}: in a support @var{R2} being a group of type @code{ElementOf}, i.e., containing elements >. @item GroupsOfEdgesOnNodesOf Groups of edges incident to nodes of elements of @var{R1} (a group is associated with each node). < @code{Not}: but not those of @var{R2}) >. @item EdgesOfTreeIn Edges of a tree of edges of @var{R1} < @code{StartingOn}: a complete tree is first built on @var{R2} >. @item FacetsOfTreeIn Facets of a tree of facets of @var{R1} < @code{StartingOn}: a complete tree is first built on @var{R2} >. @item DualNodesOf Dual nodes of elements of @var{R1}. @item DualEdgesOf Dual edges of elements of @var{R1}. @item DualFacetsOf Dual facets of elements of @var{R1}. @item DualVolumesOf Dual volumes of elements of @var{R1}. @end ftable @c ------------------------------------------------------------------------- @c Function @c ------------------------------------------------------------------------- @node Types for Function, Types for Constraint, Types for Group, Types for objects @section Types for @code{Function} @menu * Math functions:: * Extended math functions:: * Green functions:: * Type manipulation functions:: * Coordinate functions:: * Miscellaneous functions:: @end menu @c ......................................................................... @c Math functions @c ......................................................................... @node Math functions, Extended math functions, Types for Function, Types for Function @subsection Math functions @vindex @var{math-function-id} The following functions are the equivalent of the functions of the C math library, and always return real-valued expressions. These are the only functions allowed in constant expressions (@var{expression-cst}, see @ref{Constants}). @noindent @var{math-function-id}: @ftable @code @item Exp @code{[@var{expression}]} Exponential function: e^@var{expression}. @item Log @code{[@var{expression}]} Natural logarithm: ln(@var{expression}), @var{expression}>0. @item Log10 @code{[@var{expression}]} Base 10 logarithm: log10(@var{expression}), @var{expression}>0. @item Sqrt @code{[@var{expression}]} Square root, @var{expression}>=0. @item Sin @code{[@var{expression}]} Sine of @var{expression}. @item Asin @code{[@var{expression}]} Arc sine (inverse sine) of @var{expression} in [-Pi/2,Pi/2], @var{expression} in [-1,1]. @item Cos @code{[@var{expression}]} Cosine of @var{expression}. @item Acos @code{[@var{expression}]} Arc cosine (inverse cosine) of @var{expression} in [0,Pi], @var{expression} in [-1,1]. @item Tan @code{[@var{expression}]} Tangent of @var{expression}. @item Atan @code{[@var{expression}]} Arc tangent (inverse tangent) of @var{expression} in [-Pi/2,Pi/2]. @item Atan2 @code{[@var{expression},@var{expression}]} Arc tangent (inverse tangent) of the first @var{expression} divided by the second, in [-Pi,Pi]. @item Sinh @code{[@var{expression}]} Hyperbolic sine of @var{expression}. @item Cosh @code{[@var{expression}]} Hyperbolic cosine of @var{expression}. @item Tanh @code{[@var{expression}]} Hyperbolic tangent of @var{expression}. @item Fabs @code{[@var{expression}]} Absolute value of @var{expression}. @item Fmod @code{[@var{expression},@var{expression}]} Remainder of the division of the first @var{expression} by the second, with the sign of the first. @end ftable @c ......................................................................... @c Extended Math @c ......................................................................... @node Extended math functions, Green functions, Math functions, Types for Function @subsection Extended math functions @vindex @var{extended-math-function-id} @noindent @var{extended-math-function-id}: @ftable @code @item Cross @code{[@var{expression},@var{expression}]} Cross product of the two arguments; @var{expression} must be a vector. @item Hypot @code{[@var{expression},@var{expression}]} Square root of the sum of the squares of its arguments. @item Norm @code{[@var{expression}]} Absolute value if @var{expression} is a scalar; euclidian norm if @var{expression} is a vector. @item SquNorm @code{[@var{expression}]} Square norm: @code{Norm[@var{expression}]^2}. @item Unit @code{[@var{expression}]} Normalization: @code{@var{expression}/Norm[@var{expression}]}. Returns 0 if the norm is smaller than 1.e-30. @item Transpose @code{[@var{expression}]} Transposition; @var{expression} must be a tensor. @item TTrace @code{[@var{expression}]} Trace; @var{expression} must be a tensor. @item F_Cos_wt_p @code{[]@{@var{expression-cst},@var{expression-cst}@}} The first parameter represents the angular frequency and the second represents the phase. If the type of the current system is @code{Real}, @code{F_Cos_wt_p[]@{w,p@}} is identical to @code{Cos[w*$Time+p]}. If the type of the current system is @code{Complex}, it is identical to @code{Complex[Cos[w],Sin[w]]}. @item F_Sin_wt_p @code{[]@{@var{expression-cst},@var{expression-cst}@}} The first parameter represents the angular frequency and the second represents the phase. If the type of the current system is @code{Real}, @code{F_Sin_wt_p[]@{w,p@}} is identical to @code{Sin[w*$Time+p]}. If the type of the current system is @code{Complex}, it is identical to @code{Complex[Sin[w],-Cos[w]]}. @item F_Period @code{[@var{expression}]@{@var{expression-cst}@}} @code{Fmod[@var{expression},@var{expression-cst}]} @code{+} @code{(@var{expression}<0 ? @var{expression-cst} : 0)}; the result is always in [0,@var{expression-cst}[. @end ftable @c ......................................................................... @c Green functions @c ......................................................................... @node Green functions, Type manipulation functions, Extended math functions, Types for Function @subsection Green functions @vindex @var{green-function-id} The Green functions are only used in integral quantities (@pxref{Formulation}). The first parameter represents the dimension of the problem: @itemize @bullet @item @code{1D}: @code{r = Fabs[$X-$XS]} @item @code{2D}: @code{r = Sqrt[($X-$XS)^2+($Y-$YS)^2]} @item @code{3D}: @code{r = Sqrt[($X-$XS)^2+($Y-$YS)^2+($Z-$ZS)^2]} @end itemize The triplets of values given in the definitions below correspond to the @code{1D}, @code{2D} and @code{3D} cases. @noindent @var{green-function-id}: @ftable @code @item Laplace @code{[]@{@var{expression-cst}@}} @code{r/2}, @code{1/(2*Pi)*ln(1/r)}, @code{1/(4*Pi*r)}. @item GradLaplace @code{[]@{@var{expression-cst}@}} Gradient of @code{Laplace} relative to the destination point (@code{$X}, @code{$Y}, @code{$Z}). @item Helmholtz @code{[]@{@var{expression-cst}, @var{expression-cst}@}} @code{exp(j*k0*r)/(4*Pi*r)}, where @code{k0} is given by the second parameter. @item GradHelmholtz @code{[]@{@var{expression-cst}, @var{expression-cst}@}} Gradient of @code{Helmholtz} relative to the destination point (@code{$X}, @code{$Y}, @code{$Z}). @end ftable @c ......................................................................... @c Type @c ......................................................................... @node Type manipulation functions, Coordinate functions, Green functions, Types for Function @subsection Type manipulation functions @vindex @var{type-function-id} @noindent @var{type-function-id}: @ftable @code @item Complex @code{[@var{expression-list}]} Creates a (multi-harmonic) complex expression from an number of real-valued expressions. The number of expressions in @var{expression-list} must be even. @item Re @code{[@var{expression}]} Takes the real part of a complex-valued expression. @item Im @code{[@var{expression}]} Takes the imaginary part of a complex-valued expression. @item Vector @code{[@var{expression},@var{expression},@var{expression}]} Creates a vector from 3 scalars. @item Tensor @code{[@var{expression},@var{expression},@var{expression},@var{expression},@var{expression},@var{expression},} @code{@var{expression},@var{expression},@var{expression}]} Creates a second-rank tensor of order 3 from 9 scalars. @item TensorV @code{[@var{expression},@var{expression},@var{expression}]} Creates a second-rank tensor of order 3 from 3 vectors. @item TensorSym @code{[@var{expression},@var{expression},@var{expression},@var{expression},@var{expression},@var{expression}]} Creates a symmetrical second-rank tensor of order 3 from 6 scalars. @item TensorDiag @code{[@var{expression},@var{expression},@var{expression}]} Creates a diagonal second-rank tensor of order 3 from 3 scalars. @item CompX @code{[@var{expression}]} Gets the X component of a vector. @item CompY @code{[@var{expression}]} Gets the Y component of a vector. @item CompZ @code{[@var{expression}]} Gets the Z component of a vector. @item CompXX @code{[@var{expression}]} Gets the XX component of a tensor. @item CompXY @code{[@var{expression}]} Gets the XY component of a tensor. @item CompXZ @code{[@var{expression}]} Gets the XZ component of a tensor. @item CompYX @code{[@var{expression}]} Gets the YX component of a tensor. @item CompYY @code{[@var{expression}]} Gets the YY component of a tensor. @item CompYZ @code{[@var{expression}]} Gets the YZ component of a tensor. @item CompZX @code{[@var{expression}]} Gets the ZX component of a tensor. @item CompZY @code{[@var{expression}]} Gets the ZY component of a tensor. @item CompZZ @code{[@var{expression}]} Gets the ZZ component of a tensor. @end ftable @c ......................................................................... @c Coord @c ......................................................................... @node Coordinate functions, Miscellaneous functions, Type manipulation functions, Types for Function @subsection Coordinate functions @vindex @var{coord-function-id} @noindent @var{coord-function-id}: @ftable @code @item X @code{[]} Gets the X coordinate. @item Y @code{[]} Gets the Y coordinate. @item Z @code{[]} Gets the Z coordinate. @item XYZ @code{[]} Gets X, Y and Z in a vector. @c todo: @c @item F_aX_bY_cZ @c @code{[]@{@var{expression-cst},@var{expression-cst},@var{expression-cst}@}} @c @item F_aX21_bY21_cZ21 @c @code{[]@{@var{expression-cst},@var{expression-cst},@var{expression-cst}@}} @end ftable @c ......................................................................... @c Misc @c ......................................................................... @node Miscellaneous functions, , Coordinate functions, Types for Function @subsection Miscellaneous functions @vindex @var{misc-function-id} @noindent @var{misc-function-id}: @ftable @code @item Printf @code{[@var{expression}]} Prints the value of @var{expression} when evaluated. @item Rand @code{[@var{expression}]} Returns a pseudo-random number in [0, @var{expression}]. @item Normal @code{[]} Computes the normal to the element. @item NormalSource @code{[]} Computes the normal to the source element (only valid in a quantity of Integral type). @item F_CompElementNum @code{[]} Returns 0 if the current element and the current source element are identical. @item InterpolationLinear @code{[]@{@var{expression-cst-list}@}} Linear interpolation of points. The number of constant expressions in @var{expression-cst-list} must be even. @item dInterpolationLinear @code{[]@{@var{expression-cst-list}@}} Derivative of linear interpolation of points. The number of constant expressions in @var{expression-cst-list} must be even. @item InterpolationBilinear @code{[]@{@var{expression-cst-list}@}} Bilinear interpolation of a table based on two variables. See @url{https://geuz.org/trac/getdp/wiki/UsageOfTables} for an example. @item dInterpolationBilinear @code{[]@{@var{expression-cst-list}@}} Derivative of bilinear interpolation of a table based on two variables. The result is a vector. See @url{https://geuz.org/trac/getdp/wiki/UsageOfTables} for an example. @item InterpolationAkima @code{[]@{@var{expression-cst-list}@}} Akima interpolation of points. The number of constant expressions in @var{expression-cst-list} must be even. @item dInterpolationAkima @code{[]@{@var{expression-cst-list}@}} Derivative of Akima interpolation of points. The number of constant expressions in @var{expression-cst-list} must be even. @item Order @code{[@var{quantity}]} Returns the interpolation order of the @var{quantity}. @item Field @code{[@var{expression}]} Evaluate the last one of the fields (``views'') loaded with @code{GmshRead} (@pxref{Types for Resolution}), at the point @var{expression}. Common usage is thus @code{Field[XYZ[]]}. @item Field @code{[@var{expression}]@{@var{expression-cst-list}@}} Idem, but evaluate all the fields corresponding to the tags in the list, and sum all the values. A field having no value at the given position does not produce an error: its contribution to the sum is simply zero. @item ScalarField @code{[@var{expression}]@{@var{expression-cst-list}@}} Idem, but consider only real-valued scalar fields. @item VectorField @code{[@var{expression}]@{@var{expression-cst-list}@}} Idem, but consider only real-valued vector fields. @item TensorField @code{[@var{expression}]@{@var{expression-cst-list}@}} Idem, but consider only real-valued tensor fields. @item ComplexScalarField @code{[@var{expression}]@{@var{expression-cst-list}@}} Idem, but consider only complex-valued scalar fields. @item ComplexVectorField @code{[@var{expression}]@{@var{expression-cst-list}@}} Idem, but consider only complex-valued vector fields. @item ComplexTensorField @code{[@var{expression}]@{@var{expression-cst-list}@}} Idem, but consider only complex-valued tensor fields. @end ftable @c ------------------------------------------------------------------------- @c Constraint @c ------------------------------------------------------------------------- @node Types for Constraint, Types for FunctionSpace, Types for Function, Types for objects @section Types for @code{Constraint} @cindex Constraint, types @vindex @var{constraint-type} @noindent @var{constraint-type}: @ftable @code @item Assign To assign a value (e.g., for boundary condition). @item Init To give an initial value (e.g., initial value in a time domain analysis). If two values are provided (with @code{Value [ @var{expression}, @var{expression} ]}), the first value can be used using the @code{InitSolution1} operation. This is mainly useful for the Newmark time-stepping scheme. @item AssignFromResolution To assign a value to be computed by a pre-resolution. @item InitFromResolution To give an initial value to be computed by a pre-resolution. @item Network To describe the node connections of branches in a network. @item Link To define links between degrees of freedom in the constrained region with degrees of freedom in a ``reference'' region, with some coefficient. For example, to link the degrees of freedom in the contrained region @code{Left} with the degrees of freedom in the reference region @code{Right}, located Pi units to the right of the region @code{Left} along the X-axis, with the coeficient @code{-1}, one could write: @example @{ Name periodic; Case @{ @{ Region Left; Type Link ; RegionRef Right; Coefficient -1; Function Vector[$X+Pi,$Y,$Z] ; @} @} @} @end example In this example, @code{Function} defines the mapping that translates the geometrical elements in the region @code{Left} by Pi units along the X-axis, so that they correspond with the elements in the region @code{Right}. For this mapping to work, the meshes of @code{Left} and @code{Right} must be identical. @item LinkCplx To define complex-valued links between degrees of freedom. The syntax is the same as for constraints of type @code{Link}, but @code{Coeficient} can be complex. @end ftable @c ------------------------------------------------------------------------- @c FunctionSpace @c ------------------------------------------------------------------------- @node Types for FunctionSpace, Types for Jacobian, Types for Constraint, Types for objects @section Types for @code{FunctionSpace} @cindex Function space, types @vindex @var{function-space-type} @vindex @var{basis-function-type} @vindex @var{global-quantity-type} @noindent @var{function-space-type}: @ftable @code @item Form0 0-form, i.e., scalar field of potential type. @item Form1 1-form, i.e., curl-conform field (associated with a curl). @item Form2 2-form, i.e., div-conform field (associated with a divergence). @item Form3 3-form, i.e., scalar field of density type. @item Form1P 1-form perpendicular to the @var{z}=0 plane, i.e., perpendicular curl-conform field (associated with a curl). @item Form2P 2-form in the @var{z}=0 plane, i.e., parallel div-conform field (associated with a divergence). @item Scalar Scalar field. @item Vector Vector field. @end ftable @noindent @var{basis-function-type}: @ftable @code @item BF_Node Nodal function (on @code{NodesOf}, value @code{Form0}). @item BF_Edge Edge function (on @code{EdgesOf}, value @code{Form1}). @item BF_Facet Facet function (on @code{FacetsOf}, value @code{Form2}). @item BF_Volume Volume function (on @code{VolumesOf}, value @code{Form3}). @item BF_GradNode Gradient of nodal function (on @code{NodesOf}, value @code{Form1}). @item BF_CurlEdge Curl of edge function (on @code{EdgesOf}, value @code{Form2}). @item BF_DivFacet Divergence of facet function (on @code{FacetsOf}, value @code{Form3}). @item BF_GroupOfNodes Sum of nodal functions (on @code{GroupsOfNodesOf}, value @code{Form0}). @item BF_GradGroupOfNodes Gradient of sum of nodal functions (on @code{GroupsOfNodesOf}, value @code{Form1}). @item BF_GroupOfEdges Sum of edge functions (on @code{GroupsOfEdgesOf}, value @code{Form1}). @item BF_CurlGroupOfEdges Curl of sum of edge functions (on @code{GroupsOfEdgesOf}, value @code{Form2}). @item BF_PerpendicularEdge 1-form (0, 0, @code{BF_Node}) (on @code{NodesOf}, value @code{Form1P}). @item BF_CurlPerpendicularEdge Curl of 1-form (0, 0, @code{BF_Node}) (on @code{NodesOf}, value @code{Form2P}). @item BF_GroupOfPerpendicularEdge Sum of 1-forms (0, 0, @code{BF_Node}) (on @code{NodesOf}, value @code{Form1P}). @item BF_CurlGroupOfPerpendicularEdge Curl of sum of 1-forms (0, 0, @code{BF_Node}) (on @code{NodesOf}, value @code{Form2P}). @item BF_PerpendicularFacet 2-form (90 degree rotation of @code{BF_Edge}) (on @code{EdgesOf}, value @code{Form2P}). @item BF_DivPerpendicularFacet Div of 2-form (90 degree rotation of @code{BF_Edge}) (on @code{EdgesOf}, value @code{Form3}). @item BF_Region Unit value 1 (on @code{Region}, value @code{Scalar}). @item BF_RegionX Unit vector (1, 0, 0) (on @code{Region}, value @code{Vector}). @item BF_RegionY Unit vector (0, 1, 0) (on @code{Region}, value @code{Vector}). @item BF_RegionZ Unit vector (0, 0, 1) (on @code{Region}, value @code{Vector}). @item BF_Global Global pre-computed quantity (on @code{Global}, value depends on parameters). @item BF_dGlobal Exterior derivative of global pre-computed quantity (on @code{Global}, value depends on parameters). @item BF_NodeX Vector (@code{BF_Node}, 0, 0) (on @code{NodesOf}, value @code{Vector}). @item BF_NodeY Vector (0, @code{BF_Node}, 0) (on @code{NodesOf}, value @code{Vector}). @item BF_NodeZ Vector (0, 0, @code{BF_Node}) (on @code{NodesOf}, value @code{Vector}). @item BF_Zero Zero value 0 (on all regions, value @code{Scalar}). @item BF_One Unit value 1 (on all regions, value @code{Scalar}). @end ftable @noindent @var{global-quantity-type}: @ftable @code @item AliasOf Another name for a name of coefficient of basis function. @item AssociatedWith A global quantity associated with a name of coefficient of basis function, and therefore with this basis function. @end ftable @c ------------------------------------------------------------------------- @c Jacobian @c ------------------------------------------------------------------------- @node Types for Jacobian, Types for Integration, Types for FunctionSpace, Types for objects @section Types for @code{Jacobian} @cindex Jacobian, types @vindex @var{jacobian-type} @noindent @var{jacobian-type}: @ftable @code @item Vol Volume Jacobian, for @var{n}-D regions in @var{n}-D geometries, @var{n} = 1, 2 or 3. @item Sur Surface Jacobian, for (@var{n}-1)-D regions in @var{n}-D geometries, @var{n} = 1, 2 or 3. @item Lin Line Jacobian, for (@var{n}-2)-D regions in @var{n}-D geometries, @var{n} = 2 or 3. @item VolAxi Axisymmetrical volume Jacobian (1st type: @math{r}), for 2-D regions in axisymmetrical geometries. @item SurAxi Axisymmetrical surface Jacobian (1st type: @math{r}), for 1-D regions in axisymmetrical geometries. @item VolAxiSqu Axisymmetrical volume Jacobian (2nd type: @math{r^2}), for 2-D regions in axisymmetrical geometries. @item VolSphShell Volume Jacobian with spherical shell transformation, for @var{n}-D regions in @var{n}-D geometries, @var{n} = 2 or 3. @i{Parameters}: @var{radius-internal}, @var{radius-external} <, @var{center-X}, @var{center-Y}, @var{center-Z}, @var{power}, @var{1/infinity} >. @item VolAxiSphShell Same as @code{VolAxi}, but with spherical shell transformation. @i{Parameters}: @var{radius-internal}, @var{radius-external} <, @var{center-X}, @var{center-Y}, @var{center-Z}, @var{power}, @var{1/infinity} >. @item VolAxiSquSphShell Same as @code{VolAxiSqu}, but with spherical shell transformation. @i{Parameters}: @var{radius-internal}, @var{radius-external} <, @var{center-X}, @var{center-Y}, @var{center-Z}, @var{power}, @var{1/infinity} >. @item VolRectShell Volume Jacobian with rectangular shell transformation, for @var{n}-D regions in @var{n}-D geometries, @var{n} = 2 or 3. @i{Parameters}: @var{radius-internal}, @var{radius-external} <, @var{direction}, @var{center-X}, @var{center-Y}, @var{center-Z}, @var{power}, @var{1/infinity} >. @item VolAxiRectShell Same as @code{VolAxi}, but with rectangular shell transformation. @i{Parameters}: @var{radius-internal}, @var{radius-external} <, @var{direction}, @var{center-X}, @var{center-Y}, @var{center-Z}, @var{power}, @var{1/infinity} >. @item VolAxiSquRectShell Same as @code{VolAxiSqu}, but with rectangular shell transformation. @i{Parameters}: @var{radius-internal}, @var{radius-external} <, @var{direction}, @var{center-X}, @var{center-Y}, @var{center-Z}, @var{power}, @var{1/infinity} >. @end ftable @c ------------------------------------------------------------------------- @c Integration @c ------------------------------------------------------------------------- @node Types for Integration, Types for Formulation, Types for Jacobian, Types for objects @section Types for @code{Integration} @cindex Integration, types @vindex @var{integration-type} @vindex @var{element-type} @noindent @var{integration-type}: @ftable @code @item Gauss Numerical Gauss integration. @item GaussLegendre Numerical Gauss integration obtained by application of a multiplicative rule on the one-dimensional Gauss integration. @end ftable @noindent @var{element-type}: @ftable @code @item Line Line (2 nodes, 1 edge, 1 volume) (#1). @item Triangle Triangle (3 nodes, 3 edges, 1 facet, 1 volume) (#2). @item Quadrangle Quadrangle (4 nodes, 4 edges, 1 facet, 1 volume) (#3). @item Tetrahedron Tetrahedron (4 nodes, 6 edges, 4 facets, 1 volume) (#4). @item Hexahedron Hexahedron (8 nodes, 12 edges, 6 facets, 1 volume) (#5). @item Prism Prism (6 nodes, 9 edges, 5 facets, 1 volume) (#6). @item Pyramid Pyramid (5 nodes, 8 edges, 5 facets, 1 volume) (#7). @item Point Point (1 node) (#15). @end ftable @noindent Note: @enumerate @item @var{n} in (#@var{n}) is the type number of the element (@pxref{Input file format}). @end enumerate @c ------------------------------------------------------------------------- @c Formulation @c ------------------------------------------------------------------------- @node Types for Formulation, Types for Resolution, Types for Integration, Types for objects @section Types for @code{Formulation} @cindex Formulation, types @vindex @var{formulation-type} @vindex @var{local-term-type} @vindex @var{quantity-type} @vindex @var{term-op-type} @noindent @var{formulation-type}: @ftable @code @item FemEquation Finite element method formulation (all methods of moments, integral methods). @end ftable @noindent @var{local-term-type}: @ftable @code @item Galerkin Integral of Galerkin type. @item deRham deRham projection (collocation). @end ftable @noindent @var{quantity-type}: @ftable @code @item Local Local quantity defining a field in a function space. In case a subspace is considered, its identifier has to be given between the brackets following the @code{NameOfSpace @var{function-space-id}}. @item Global Global quantity defining a global quantity from a function space. The identifier of this quantity has to be given between the brackets following the @code{NameOfSpace @var{function-space-id}}. @item Integral Integral quantity obtained by the integration of a @code{LocalQuantity} before its use in an @code{Equation} term. @end ftable @noindent @var{term-op-type}: @ftable @code @item Dt Time derivative applied to the whole term of the equation. (Not implemented yet.) @item DtDof Time derivative applied only to the @code{Dof@{@}} term of the equation. @item DtDt Time derivative of 2nd order applied to the whole term of the equation. (Not implemented yet.) @item DtDtDof Time derivative of 2nd order applied only to the @code{Dof@{@}} term of the equation. @item JacNL Nonlinear part of the Jacobian matrix (tangent stiffness matrix) to be assembled for nonlinear analysis. @item DtDofJacNL Nonlinear part of the Jacobian matrix for the first order time derivative (tangent mass matrix) to be assembled for nonlinear analysis. @item NeverDt No time scheme applied to the term (e.g., Theta is always 1 even if a theta scheme is applied). @end ftable @c ------------------------------------------------------------------------- @c Resolution @c ------------------------------------------------------------------------- @node Types for Resolution, Types for PostProcessing, Types for Formulation, Types for objects @section Types for @code{Resolution} @cindex Resolution, types @vindex @var{resolution-op} @noindent @var{resolution-op}: @ftable @code @item Generate @code{[@var{system-id}]} Generate the system of equations @var{system-id}. @item Solve @code{[@var{system-id}]} Solve the system of equations @var{system-id}. @item GenerateJac @code{[@var{system-id}]} Generate the system of equations @var{system-id} using a jacobian matrix (of which the unknowns are corrections @var{dx} of the current solution @var{x}). @item SolveJac @code{[@var{system-id}]} Solve the system of equations @var{system-id} using a jacobian matrix (of which the unknowns are corrections @var{dx} of the current solution @var{x}). Then, Increment the solution (@var{x}=@var{x}+@var{dx}) and compute the relative error @var{dx}/@var{x}. @item GenerateSeparate @code{[@var{system-id}]} Generate matrices separately for @code{DtDtDof}, @code{DtDof} and @code{NoDt} terms in @var{system-id}. The separate matrices can be used with the @code{Update} operation (for efficient time domain analysis of linear PDEs with constant coefficients), or with the @code{EigenSolve} operation (for solving generalized eigenvalue problems). @item GenerateOnly @code{[@var{system-id}, @var{expression-cst-list}]} Not documented yet. @item GenerateOnlyJac @code{[@var{system-id}, @var{expression-cst-list}]} Not documented yet. @item GenerateGroup Not documented yet. @item GenerateRHSGroup Not documented yet. @item Update @code{[@var{system-id}]} Update the system of equations @var{system-id} (built from sub-matrices generated separately with @code{GenerateSeparate}) with the @code{TimeFunction}(s) provided in @code{Assign} constraints. This assumes that the problem is linear, that the matrix coefficients are independent of time, and that all sources are imposed using @code{Assign} constraints. @item Update @code{[@var{system-id}, @var{expression}]} Update the system of equations @var{system-id} (built from sub-matrices generated separately with @code{GenerateSeparate}) with @var{expression}. This assumes that the problem is linear, that the matrix coefficients are independent of time, and that the right-hand-side of the linear system can simply be multiplied by @var{expression} at each step. @item UpdateConstraint @code{[@var{system-id}, @var{group-id}, @var{constraint-type}]} Recompute the constraint of type @var{constraint-type} acting on @var{group-id} during processing. @item InitSolution @code{[@var{system-id}]} Initialize the solution of @var{system-id} to zero (default) or to the values given in a @code{Constraint} of @code{Init} type. If two values are given in @code{Init}, the second value is used. @item InitSolution1 @code{[@var{system-id}]} Initialize the first of two time steps for a Newmark Scheme. Only works if two values are specified in @code{Init}. @item SaveSolution @code{[@var{system-id}]} Save the solution of the system of equations @var{system-id}. @item SaveSolutions @code{[@var{system-id}]} Save all the solutions available for the system of equations @var{system-id}. This should be used with algorithms that generate more than one solution at once, e.g., @code{EigenSolve} or @code{FourierTransform}. @item TransferSolution @code{[@var{system-id}]} Transfer the solution of system @var{system-id}, as an @code{Assign} constraint, to the system of equations defined with a @code{DestinationSystem} command. This is used with the @code{AssignFromResolution} constraint type (@pxref{Types for Constraint}). @item TransferInitSolution @code{[@var{system-id}]} Transfer the solution of system @var{system-id}, as an @code{Init} constraint, to the system of equations defined with a @code{DestinationSystem} command. This is used with the @code{InitFromResolution} constraint type (@pxref{Types for Constraint}). @item Evaluate @code{[@var{expression}]} Evaluate @var{expression}. @item SetTime @code{[@var{expression}]} Change the current time. @item SetFrequency @code{[@var{system-id}, @var{expression}]} Change the frequency of system @var{system-id}. @item SystemCommand @code{[@var{expression-char}]} Execute the system command given by @var{expression-char}. @item Test @code{[@var{expression}] @{ @var{resolution-op} @}} If @var{expression} is true (nonzero), perform the operations in @var{resolution-op}. @item Test @code{[@var{expression}] @{ @var{resolution-op} @}} @code{Else} @code{@{ @var{resolution-op} @}} If @var{expression} is true (nonzero), perform the operations in the first @var{resolution-op}, else perform the operations in the second @var{resolution-op}. @item Break Aborts an iterative loop or a time loop. @item Print @code{[ @{ @var{expression-list} @}, < File @var{expression-char} > ]} Print the expressions listed in @var{expression-list}. @item Print @code{[ @var{system-id} <, File @var{expression-char} > <, @{ @var{expression-cst-list} @} >}@* @code{<, TimeStep @{ @var{expression-cst-list} @} >]} Print the system @var{system-id}. If the @var{expression-cst-list} is given, print only the values of the degrees of freedom given in that list. If the @code{TimeStep} option is present, limit the printing to the selected time steps. @item EigenSolve @code{[@var{system-id}, @var{expression-cst}, @var{expression-cst}, @var{expression-cst}]} Eigenvalue/eigenvector computation using Arpack. The parameters are: the system (which has to be generated with @code{GenerateSeparate[]}), the number of eigenvalues/eigenvectors to compute and the real and imaginary spectral shift (around which to look for eigenvalues). @item Lanczos @code{[@var{system-id}, @var{expression-cst}, @{ @var{expression-cst-list} @} , @var{expression-cst}]} Eigenvalue/eigenvector computation using the Lanczos algorithm. The parameters are: the system (which has to be generated with @code{GenerateSeparate[]}), the size of the Lanczos space, the indices of the eigenvalues/eigenvectors to store, the spectral shift. This routine is deprecated: use @code{EigenSolve} instead. @item FourierTransform @code{[@var{system-id}, @var{system-id}, @{ @var{expression-cst-list} @}]} On-the-fly computation of a discrete Fourier transform. The parameters are: the (time domain) system, the destination system in which the result of the Fourier tranform is to be saved (it should be declared with @code{Type Complex}), the list of frequencies to consider in the discrete Fourier transform. @item TimeLoopTheta @code{[@var{expression-cst},@var{expression-cst},@var{expression},@var{expression-cst}]} @code{@{ @var{resolution-op} @}} Time loop of a theta scheme. The parameters are: the initial time, the end time, the time step and the theta parameter (e.g., 1 for implicit Euler, 0.5 for Crank-Nicholson). Warning: GetDP automatically handles time-dependent constraints when they are provided using the @code{TimeFunction} mechanism in an @code{Assign}-type @code{Constraint} (@pxref{Constraint}). However, GetDP cannot automatically transform general time-dependent source terms in weak formulations (time-dependent functions written in a @code{Galerkin} term). Such source terms will be correctly treated only for implicit Euler, as the expression in the @code{Galerkin} term is evaluated at the current time step. For other schemes, the source term should be written explicitly, by splitting it in two (@code{theta f_n+1 + (1-theta) f_n}), making use of the @code{AtAnteriorTimeStep[]} for the second part, and specifying @code{NeverDt} in the @code{Galerkin} term. @item TimeLoopNewmark @code{[@var{expression-cst},@var{expression-cst},@var{expression},@var{expression-cst},@var{expression-cst}]}@* @{ @var{resolution-op} @} Time loop of a Newmark scheme. The parameters are: the initial time, the end time, the time step, the beta and the gamma parameter. Warning: same restrictions apply for time-dependent functions in the weak formulations as for @code{TimeLoopTheta}. @item TimeLoopAdaptive @code{[@var{expression-cst},@var{expression-cst},@var{expression-cst},@var{expression-cst}, @var{expression-cst},@var{integration-method},<@var{expression-cst-list}>,@* System @{ @{@var{system-id},@var{expression-cst},@var{expression-cst},@var{norm-type}@} ... @} |@* PostOperation @{ @{@var{post-operation-id},@var{expression-cst},@var{expression-cst},@var{norm-type}@} ... @} ]}@* @code{@{ @var{resolution-op} @}}@* @code{@{ @var{resolution-op} @}} Time loop with variable time steps. The step size is adjusted according the local truncation error (LTE) of the specified Systems/PostOperations via a predictor-corrector method.@* The parameters are: start time, end time, initial time step, min. time step, max. time step, integration method, list of breakpoints (time points to be hit). The LTE calculation can be based on all DOFs of a system and/or on a PostOperation result. The parameters here are: System/PostOperation for LTE assessment, relative LTE tolerance, absolute LTE tolerance, norm-type for LTE calculation.@* Possible choices for @var{integration-method} are: @code{Euler, Trapezoidal, Gear_2, Gear_3, Gear_4, Gear_5, Gear_6}. The Gear methods correspond to backward differentiation formulas of order 2..6.@* Possible choices for @var{norm-type}: @code{L1Norm, MeanL1Norm, L2Norm, MeanL2Norm, LinfNorm}.@* @code{MeanL1Norm} and @code{MeanL2Norm} correspond to @code{L1Norm} and @code{L2Norm} divided by the number of degrees of freedom, respectively.@* The first @var{resolution-op} is executed every time step. The second one is only executed if the actual time step is accepted (LTE is in the specified range). E.g. @code{SaveSolution[]} is usually placed in the 2nd @var{resolution-op}.@* See @url{https://geuz.org/trac/getdp/wiki/TimeLoopAdaptive} for more details and an example. @item IterativeLoop @code{[@var{expression-cst},@var{expression},@var{expression-cst}<,@var{expression-cst}>]} @{ @var{resolution-op} @} Iterative loop for nonlinear analysis. The parameters are: the maximum number of iterations (if no convergence), the relaxation factor (multiplies the iterative correction @var{dx}) and the relative error to achieve. The optional parameter is a flag for testing purposes. @item IterativeLoopN @code{[@var{expression-cst},@var{expression},@* System @{ @{@var{system-id},@var{expression-cst},@var{expression-cst}, @var{assessed-object} @var{norm-type}@} ... @} |@* PostOperation @{ @{@var{post-operation-id},@var{expression-cst},@var{expression-cst}, @var{norm-type}@} ... @} ]}@* @{ @var{resolution-op} @} Similar to @code{IterativeLoop[]} but allows to specify in detail the tolerances and the type of norm to be calculated for convergence assessment.@* The parameters are: the maximum number of iterations (if no convergence), the relaxation factor (multiplies the iterative correction @var{dx}). The convergence assessment can be based on all DOFs of a system and/or on a PostOperation result. The parameters here are: System/PostOperation for convergence assessment, relative tolerance, absolute tolerance, assessed object (only applicable for a specified system), norm-type for error calculation.@* Possible choices for @var{assessed-object}: @code{Solution, Residual, RecalcResidual}. @code{Residual} assesses the residual from the last iteration whereas @code{RecalcResidual} calculates the residual once again after each iteration. This means that with @code{Residual} usually one extra iteration is performed, but @code{RecalcResidual} causes higher computational effort per iteration. Assessing the residual can only be used for Newton's method.@* Possible choices for @var{norm-type}: @code{L1Norm, MeanL1Norm, L2Norm, MeanL2Norm, LinfNorm}.@* @code{MeanL1Norm} and @code{MeanL2Norm} correspond to @code{L1Norm} and @code{L2Norm} divided by the number of degrees of freedom, respectively.@* See @url{https://geuz.org/trac/getdp/wiki/IterativeLoopN} for more details and an example. @item PostOperation @code{[@var{post-operation-id}]} Perform the specified @code{PostOperation}. @item GmshRead @code{[@var{expression-char}]} When GetDP is linked with the Gmsh library, read a file using Gmsh. This file can be in any format recognized by Gmsh. If the file contains one or multiple post-processing fields, these fields will be evaluated using the built-in @code{Field[]}, @code{ScalarField[]}, @code{VectorField[]}, etc., functions (@pxref{Miscellaneous functions}). @item GmshRead @code{[@var{expression-char}, @var{expression-cst}]} Same thing as the @code{GmshRead} command above, except that the field is forced to be stored with the given tag. The tag can be used to retrieve the given field with the built-in @code{Field[]}, @code{ScalarField[]}, @code{VectorField[]}, etc., functions (@pxref{Miscellaneous functions}). @item DeleteFile @code{[@var{expression-char}]} Delete a file. @item CreateDir | CreateDirectory @code{[@var{expression-char}]} Create a directory. @c todo: @c @item Perturbation @c @item ChangeOfCoordinates @c @item SaveMesh @c @item DeformeMesh @c @item IterativeTimeReduction @c @{ @var{iterative-time-reduction-arg}; @} @c @c Iterative reduction of time interval to delimit variations of solutions @c (e.g., used in types of nonlinear analyses). @end ftable @c todo: Patrick, la suite est-elle comprehensible ? @c @noindent @c @var{iterative-time-reduction-arg}: @c @ftable @code @c @item NbrMaxIteration @c @var{expression-cst} @c Maximum number of iterations (if no convergence). @c @item DivisionCoefficient @c @var{expression-cst} @c Division coefficient of the time interval (usually 2 for dichotomy). @c @item Criterion @c @var{expression-cst} @c Dimension of the time interval to achieve before stopping divisions. @c @item Flag @c @var{expression-cst} @c Option for test. [To be explained later.] @c @item System @c @var{system-id} @c System containing the quantities to test. @c @item ChangeOfState @c @{ @{ @var{change-of-state-arg} @} @dots{} @} @c Tests to perform. @c @item Operation @c @{ < @var{resolution-op}; > @dots{} @} @c Operations to perform at each step. @c @item OperationEnd @c @{ < @var{resolution-op}; > @dots{} @} @c Operations to perform after the last iteration (when leaving the loop). @c @end ftable @c @noindent @c @var{change-of-state-arg}: @c @ftable @code @c @item Type @c @var{change-of-state-type} @c Type of change of state analysis. @c @item Quantity @c @var{quantity-id} @c @itemx In @c @var{group-def} @c Global quantity to analyse. @c @item Criterion @c @var{expression-cst} @c Relative error accepted. @c @item Function @c @var{expression} @c Reference function. @c @end ftable @c @noindent @c @var{change-of-state-type}: @c @ftable @code @c @item ChangeSign @c Test of change of sign of quantities. @c @item ChangeLevel @c Test of change of level of quantities. @c @item ChangeReference @c Compare quantities to reference functions (e.g., for regulation). @c @item ChangeReference2 @c Compare quantities to reference functions (e.g., for regulation). @c @end ftable @c ------------------------------------------------------------------------- @c PostProcessing @c ------------------------------------------------------------------------- @node Types for PostProcessing, Types for PostOperation, Types for Resolution, Types for objects @section Types for @code{PostProcessing} @cindex Post-processing, types @vindex @var{post-value} @noindent @var{post-value}: @ftable @code @item Local @{ @var{local-value} @} To compute a local quantity. @item Integral @{ @var{integral-value} @} To integrate the expression over each element. @end ftable @c ------------------------------------------------------------------------- @c PostOperation @c ------------------------------------------------------------------------- @node Types for PostOperation, , Types for PostProcessing, Types for objects @section Types for @code{PostOperation} @cindex Post-operation, types @vindex @var{print-support} @noindent @var{print-support}: @ftable @code @item OnElementsOf @var{group-def} To compute a quantity on the elements belonging to the region @var{group-def}, where the solution was computed during the processing stage. @item OnRegion @var{group-def} To compute a global quantity associated with the region @var{group-def}. @item OnGlobal To compute a global integral quantity, with no associated region. @item OnSection @{ @{ @var{expression-cst-list} @} @{ @var{expression-cst-list} @} @{ @var{expression-cst-list} @} @} To compute a quantity on a section of the mesh defined by three points (i.e., on the intersection of the mesh with a cutting a plane, specified by three points). Each @var{expression-cst-list} must contain exactly three elements (the coordinates of the points). @item OnGrid @var{group-def} To compute a quantity in elements of a mesh which differs from the real support of the solution. @code{OnGrid @var{group-def}} differs from @code{OnElementsOf @var{group-def}} by the reinterpolation that must be performed. @item OnGrid @code{@{ @var{expression}, @var{expression}, @var{expression} @}}@* @code{@{ @var{expression-cst-list-item} | @{ @var{expression-cst-list} @} ,}@* @code{@: @: @var{expression-cst-list-item} | @{ @var{expression-cst-list} @} ,}@* @code{@: @: @var{expression-cst-list-item} | @{ @var{expression-cst-list} @} @}} To compute a quantity on a parametric grid. The three @var{expression}s represent the three cartesian coordinates @var{x}, @var{y} and @var{z}, and can be functions of the current values @code{$A}, @code{$B} and @code{$C}. The values for @code{$A}, @code{$B} and @code{$C} are specified by each @var{expression-cst-list-item} or @var{expression-cst-list}. For example, @code{OnGrid @{Cos[$A], Sin[$A], 0@} @{ 0:2*Pi:Pi/180, 0, 0 @}} will compute the quantity on 360 points equally distributed on a circle in the z=0 plane, and centered on the origin. @item OnPoint @{ @var{expression-cst-list} @} To compute a quantity at a point. The @var{expression-cst-list} must contain exactly three elements (the coordinates of the point). @item OnLine @{ @{ @var{expression-cst-list} @} @{ @var{expression-cst-list} @} @} @{ @var{expression-cst} @} To compute a quantity along a line (given by its two end points), with an associated number of divisions equal to @var{expression-cst}. The interpolation points on the line are equidistant. Each @var{expression-cst-list} must contain exactly three elements (the coordinates of the points). @item OnPlane @{ @{ @var{expression-cst-list} @} @{ @var{expression-cst-list} @} @{ @var{expression-cst-list} @} @}@* @code{@{ @var{expression-cst}, @var{expression-cst} @}} To compute a quantity on a plane (specified by three points), with an associated number of divisions equal to each @var{expression-cst} along both generating directions. Each @var{expression-cst-list} must contain exactly three elements (the coordinates of the points). @item OnBox @{ @{ @var{expression-cst-list} @} @{ @var{expression-cst-list} @} @{ @var{expression-cst-list} @}@* @code{@: @: @{ @var{expression-cst-list} @} @} @{ @var{expression-cst}, @var{expression-cst}, @var{expression-cst} @}} To compute a quantity in a box (specified by four points), with an associated number of divisions equal to each @var{expression-cst} along the three generating directions. Each @var{expression-cst-list} must contain exactly three elements (the coordinates of the points). @c todo: OnRegion WithArgument @c Il faudrait en fait plutot ajouter WithArgument comme une option @c accessible partout, et retravailler le post en ce sens... @c en tout cas, iul faut changer la syntaxe de WithArgument pour utiliser @c uniquement une expression-cst-list, et non plus uniquement start, end, num. @end ftable @vindex @var{print-option} @noindent @var{print-option}: @ftable @code @item File @code{@var{expression-char}} Outputs the result in a file named @var{expression-char}. @item File @code{> @var{expression-char}} Same as @code{File @var{expression-char}}, except that, if several @code{File > @var{expression-char}} options appear in the same @code{PostOperation}, the results are concatenated in the file @var{expression-char}. @item File @code{>> @var{expression-char}} Appends the result to a file named @var{expression-char}. @item Depth @var{expression-cst} Recursive division of the elements if @var{expression-cst} is greater than zero, derefinement if @var{expression-cst} is smaller than zero. If @var{expression-cst} is equal to zero, evaluation at the barycenter of the elements. @item Skin Computes the result on the boundary of the region. @item Smoothing Smoothes the solution at the nodes. @item HarmonicToTime @var{expression-cst} Converts a harmonic solution into a time-dependent one (with @var{expression-cst} steps). @item Dimension @var{expression-cst} Forces the dimension of the elements to consider in an element search. Specifies the problem dimension during an adaptation (h- or p-refinement). @item TimeStep @code{@var{expression-cst-list-item} | @{ @var{expression-cst-list} @}} Outputs results for the specified time steps only. @item LastTimeStepOnly Outputs results for the last time step only (useful when calling a @code{PostOperation} directly in a @code{Resolution}, for example). @item AppendTimeStepToFileName < @var{expression-cst} > Appends the time step to the output file; only makes sense with @code{LastTimeStepOnly}. @item OverrideTimeStepValue @var{expression-cst} Overrides the value of the current time step with the given value. @item NoMesh Prevents the mesh from being written in the output file (useful with new mesh-based solution formats). @item SendToServer @var{expression-char} Send the value to the Onelab server, using @var{expression-char} as the paramater name. @item Color @var{expression-char} Used with @code{SendToServer}, sets the color of the parameter in the Onelab server. @item Frequency @code{@var{expression-cst-list-item} | @{ @var{expression-cst-list} @}} Outputs results for the specified frequencies only. @item Format @var{post-operation-fmt} Outputs results in the specified format. @item Adapt @code{P1 | H1 | H2} Performs p- or h-refinement on the post-processing result, considered as an error map. @item Target @var{expression-cst} Specifies the target for the optimizer during adaptation (error for @code{P1|H1}, number of elements for @code{H2}). @item Value @code{@var{expression-cst-list-item} | @{ @var{expression-cst-list} @}} Specifies acceptable output values for discrete optimization (e.g. the available interpolation orders with @code{Adapt P1}). @item Sort @code{Position | Connection} Sorts the output by position (x, y, z) or by connection (for @code{LINE} elements only). @item Iso @var{expression-cst} Outputs directly contour prints (with @var{expression-cst} values) instead of elementary values. @item Iso @code{@{ @var{expression-cst-list} @}} Outputs directly contour prints for the values specified in the @var{expression-cst-list} instead of elementary values. @item NoNewLine Suppresses the new lines in the output when printing global quantities (i.e., with @code{Print OnRegion} or @code{Print OnGlobal}). @item ChangeOfCoordinates @code{@{ @var{expression}, @var{expression}, @var{expression} @}} Changes the coordinates of the results according to the three expressions given in argument. The three @var{expression}s represent the three new cartesian coordinates @var{x}, @var{y} and @var{z}, and can be functions of the current values of the cartesian coordinates @code{$X}, @code{$Y} and @code{$Z}. @item ChangeOfValues @code{@{ @var{expression-list} @}} Changes the values of the results according to the expressions given in argument. The @var{expression}s represent the new values (@var{x}-compoment, @var{y}-component, etc.), and can be functions of the current values of the solution (@var{$Val0}, @var{$Val1}, etc.). @item DecomposeInSimplex Decomposes all output elements in simplices (points, lines, triangles or tetrahedra). @item StoreInRegister @code{@var{expression-cst}} Stores the result of an @code{OnRegion} post-processing operation in the register @var{expression-cst}. @item StoreInField @code{@var{expression-cst}} Stores the result of a post-processing operation in the field (Gmsh view) with tag @var{expression-cst}. @item TimeLegend @code{< @{ @var{expression}, @var{expression}, @var{expression} @} >} Includes a time legend in Gmsh plots. If the three optional expressions giving the position of the legend are not specified, the legend is centered on top of the plot. @item FrequencyLegend @code{< @{ @var{expression}, @var{expression}, @var{expression} @} >} Includes a frequency legend in Gmsh plots. If the three optional expressions giving the position of the legend are not specified, the legend is centered on top of the plot. @item EigenvalueLegend @code{< @{ @var{expression}, @var{expression}, @var{expression} @} >} Includes an eigenvalue legend in Gmsh plots. If the three optional expressions giving the position of the legend are not specified, the legend is centered on top of the plot. @end ftable @vindex @var{post-operation-fmt} @noindent @var{post-operation-fmt}: @ftable @code @item Gmsh @itemx GmshParsed Gmsh output. See @ref{Input file format} and the documentation of Gmsh (@url{http://geuz.org/gmsh}) for a description of the file formats. @item Table Space oriented column output, e.g., suitable for Gnuplot, Excel, Caleida Graph, etc. The columns are: @var{element-type} @var{element-index} @var{x-coord} @var{y-coord} @var{z-coord} <@var{x-coord} @var{y-coord} @var{z-coord}> @dots{} @var{real} @var{real} @var{real} @var{values}. The three @var{real} numbers preceding the @var{values} contain context-dependent information, depending on the type of plot: curvilinear abscissa for @code{OnLine} plots, normal to the plane for @code{OnPlane} plots, parametric coordinates for parametric @code{OnGrid} plots, etc. @item SimpleTable Like @code{Table}, but with only the @var{x-coord} @var{y-coord} @var{z-coord} and @var{values} columns. @item TimeTable Time oriented column output, e.g., suitable for Gnuplot, Excel, Caleida Graph, etc. The columns are: @var{time-step} @var{time} @var{x-coord} @var{y-coord} @var{z-coord} <@var{x-coord} @var{y-coord} @var{z-coord}> @dots{} @var{value}. @item NodeTable Table of node values. The first value corresponds to the number of listed nodes. The columns of the following lines are: @var{node-number} @var{node-value}(s) @item Gnuplot Space oriented column output similar to the @code{Table} format, except that a new line is created for each node of each element, with a repetition of the first node if the number of nodes in the element is greater than 2. This permits to draw unstructured meshes and nice three-dimensional elevation plots in Gnuplot. The columns are: @var{element-type} @var{element-index} @var{x-coord} @var{y-coord} @var{z-coord} @var{real} @var{real} @var{real} @var{values}. The three @var{real} numbers preceding the @var{values} contain context-dependent information, depending on the type of plot: curvilinear abscissa for @code{OnLine} plots, normal to the plane for @code{OnPlane} plots, parametric coordinates for parametric @code{OnGrid} plots, etc. @item Adaptation Adaptation map, suitable for the GetDP @code{-adapt} command line option. @end ftable @c ========================================================================= @c Short Examples @c ========================================================================= @node Short examples, Complete examples, Types for objects, Top @chapter Short examples @cindex Short examples @cindex Examples, short @menu * Constant expression examples:: * Group examples:: * Function examples:: * Constraint examples:: * FunctionSpace examples:: * Jacobian examples:: * Integration examples:: * Formulation examples:: * Resolution examples:: * PostProcessing examples:: * PostOperation examples:: @end menu @c ------------------------------------------------------------------------- @c Constant Expression Examples @c ------------------------------------------------------------------------- @node Constant expression examples, Group examples, Short examples, Short examples @section Constant expression examples The simplest constant expression consists of an @var{integer} or a @var{real} number as in @example 21 -3 @end example @noindent or @example -3.1415 27e3 -290.53e-12 @end example @noindent Using operators and the classic math functions, @var{constant-id}s can be defined: @example c1 = Sin[2/3*3.1415] * 5000^2; c2 = -1/c1; @end example @c todo: ajouter un exemple de liste et de string @c ------------------------------------------------------------------------- @c Group Examples @c ------------------------------------------------------------------------- @node Group examples, Function examples, Constant expression examples, Short examples @section @code{Group} examples @cindex Group, examples Let us assume that some elements in the input mesh have the region numbers 1000, 2000 and 3000. In the definitions @example Group @{ Air = Region[1000]; Core = Region[2000]; Inductor = Region[3000]; NonConductingDomain = Region[@{Air, Core@}]; ConductingDomain = Region[@{Inductor@}]; @} @end example @noindent @code{Air}, @code{Core}, @code{Inductor} are identifiers of elementary region groups while @code{NonConductingDom@-ain} and @code{ConductingDomain} are global region groups. Groups of function type contain lists of entities built on the region groups appearing in their arguments. For example, @example NodesOf[NonConductingDomain] @end example @noindent represents the group of nodes of geometrical elements belonging to the regions in @code{NonConduc@-tingDomain} and @example EdgesOf[DomainC, Not SkinDomainC] @end example @noindent represents the group of edges of geometrical elements belonging to the regions in @code{DomainC} but not to those of @code{SkinDomainC}. @c ------------------------------------------------------------------------- @c Function Examples @c ------------------------------------------------------------------------- @node Function examples, Constraint examples, Group examples, Short examples @section @code{Function} examples @cindex Function, examples A physical characteristic is a piecewise defined function. The magnetic permeability @code{mu[]} can for example be defined in the considered regions by @example Function @{ mu[Air] = 4.e-7*Pi; mu[Core] = 1000.*4.e-7*Pi; @} @end example @noindent A nonlinear characteristic can be defined through an @var{expression} with arguments, e.g., @example Function @{ mu0 = 4.e-7*Pi; a1 = 1000.; b1 = 100.; // Constants mu[NonlinearCore] = mu0 + 1./(a1+b1*Norm[$1]^6); @} @end example @noindent where function @code{mu[]} in region @code{NonLinearCore} has one argument @code{$1} which has to be the magnetic flux density. This function is actually called when writing the equations of a formulation, which permits to directly extend it to a nonlinear form by adding only the necessary arguments. For example, in a magnetic vector potential formulation, one may write @code{mu[@{Curl a@}]} instead of @code{mu[]} in @code{Equation} terms (@pxref{Formulation examples}). Multiple arguments can be specified in a similar way: writing @code{mu[@{Curl a@},@{T@}]} in an @code{Equation} term will provide the function @code{mu[]} with two usable arguments, @code{$1} (the magnetic flux density) and @code{$2} (the temperature). It is also possible to directly interpolate one-dimensional functions from tabulated data. In the following example, the function @var{f}(@var{x}) as well as its derivative @var{f}'(@var{x}) are interpolated from the (@var{x},@var{f}(@var{x})) couples (0,0.65), (1,0.72), (2,0.98) and (3,1.12): @example Function @{ couples = @{0, 0.65 , 1, 0.72 , 2, 0.98 , 3, 1.12@}; f[] = InterpolationLinear[$1]@{List[couples]@}; dfdx[] = dInterpolationLinear[$1]@{List[couples]@}; @} @end example @noindent The function @code{f[]} may then be called in an @code{Equation} term of a @code{Formulation} with one argument, @var{x}. Notice how the list of constants @code{List[couples]} is supplied as a list of parameters to the built-in function @code{InterpolationLinear} (@pxref{Constants}, as well as @ref{Functions}). In order to facilitate the construction of such interpolations, the couples can also be specified in two separate lists, merged with the alternate list @code{ListAlt} command (@pxref{Constants}): @example Function @{ data_x = @{0, 1, 2, 3@}; data_f = @{0.65, 0.72, 0.98, 1.12@}; f[] = InterpolationLinear[$1]@{ListAlt[data_x, data_f]@}; dfdx[] = dInterpolationLinear[$1]@{ListAlt[data_x, data_f]@}; @} @end example @noindent In order to optimize the evaluation time of complex expressions, registers may be used (@pxref{Registers}). For example, the evaluation of @code{g[] = f[$1]*Sin[f[$1]^2]} would require two (costly) linear interpolations. But the result of the evaluation of @code{f[]} may be stored in a register (for example the register 0) with @example g[] = f[$1]#0 * Sin[#0^2]; @end example @noindent thus reducing the number of evaluations of @code{f[]} (and of the argument @code{$1}) to one. A function can also be time dependent, e.g., @example Function @{ Freq = 50.; Phase = 30./180.*Pi; // Constants TimeFct_Sin[] = Sin [ 2.*Pi*Freq * $Time + Phase ]; TimeFct_Exp[] = Exp [ - $Time / 0.0119 ]; TimeFct_ExtSin[] = F_Sin_wt_p [] @{2.*Pi*Freq, Phase@}; @} @end example @noindent Note that @code{TimeFct_ExtSin[]} is identical to @code{TimeFct_Sin[]} in a time domain analysis, but also permits to define phasors implicitely in the case of harmonic analyses. @c ------------------------------------------------------------------------- @c Constraint Examples @c ------------------------------------------------------------------------- @node Constraint examples, FunctionSpace examples, Function examples, Short examples @section @code{Constraint} examples @cindex Constraint, examples Constraints are referred to in @code{FunctionSpace}s and are usually used for boundary conditions (@code{Assign} type). For example, essential conditions on two surface regions, @code{Surf0} and @code{Surf1}, will be first defined by @example Constraint @{ @{ Name DirichletBoundaryCondition1; Type Assign; Case @{ @{ Region Surf0; Value 0.; @} @{ Region Surf1; Value 1.; @} @} @} @} @end example @noindent The way the @code{Value}s are associated with @code{Region}s (with their nodes, their edges, their global regions, @dots{}) is defined in the @code{FunctionSpace}s which use the @code{Constraint}. In other words, a @code{Constraint} defines data but does not define the method to process them. A time dependent essential boundary condition on @code{Surf1} would be introduced as (cf.@: @ref{Function examples} for the definition of @code{TimeFct_Exp[]}): @example @{ Region Surf1; Value 1.; TimeFunction 3*TimeFct_Exp[] @} @end example @noindent It is important to notice that the time dependence cannot be introduced in the @code{Value} field, since the @code{Value} is only evaluated once during the pre-processing. Other constraints can be referred to in @code{Formulation}s. It is the case of those defining electrical circuit connections (@code{Network} type), e.g., @example Constraint @{ @{ Name ElectricalCircuit; Type Network; Case Circuit1 @{ @{ Region VoltageSource; Branch @{1,2@}; @} @{ Region PrimaryCoil; Branch @{1,2@}; @} @} Case Circuit2 @{ @{ Region SecondaryCoil; Branch @{1,2@}; @} @{ Region Charge; Branch @{1,2@}; @} @} @} @} @end example @noindent which defines two non-connected circuits (@code{Circuit1} and @code{Circuit2}), with an independent numbering of nodes: region @code{VoltageSource} is connected in parallel with region @code{PrimaryCoil}, and region @code{SecondaryCoil} is connected in parallel with region @code{Charge}. @c todo: ajouter un vrai exemple de circuit @c ------------------------------------------------------------------------- @c FunctionSpace Examples @c ------------------------------------------------------------------------- @node FunctionSpace examples, Jacobian examples, Constraint examples, Short examples @section @code{FunctionSpace} examples @cindex Function space, examples Various discrete function spaces can be defined in the frame of the finite element method. @menu * Conform space:: * High order space:: * Global values:: * Curl-conform space:: * Gauge condition:: * Coupled spaces:: * Multiply connected domains:: @end menu @c ......................................................................... @c Nodal Finite Element Spaces @c ......................................................................... @node Conform space, High order space, FunctionSpace examples, FunctionSpace examples @subsection Nodal finite element spaces The most elementary function space is the nodal finite element space, defined on a mesh of a domain @var{W} and denoted @i{S0(W)} (associated finite elements can be of various geometries), and associated with essential boundary conditions (Dirichlet conditions). It contains 0-forms, i.e., scalar fields of potential type: @tex $$ v = \sum_{n\in N} v_n s_n \quad v\in S^0(W) $$ @end tex @ifnottex @var{v} = Sum [ @var{vn} * @var{sn}, for all @var{n} in @var{N} ], @var{v} in @i{S0(W)} @end ifnottex @noindent where @var{N} is the set of nodes of @var{W}, @var{sn} is the nodal basis function associated with node @var{n} and @var{vn} is the value of @var{v} at node @var{n}. It is defined by @example FunctionSpace @{ @{ Name Hgrad_v; Type Form0; BasisFunction @{ @{ Name sn; NameOfCoef vn; Function BF_Node; Support Domain; Entity NodesOf[All]; @} @} Constraint @{ @{ NameOfCoef vn; EntityType NodesOf; NameOfConstraint DirichletBoundaryCondition1; @} @} @} @} @end example @noindent Function @code{sn} is the built-in basis function BF_Node associated with all nodes (@code{NodesOf}) in the mesh of @var{W} (@code{Domain}). Previously defined @code{Constraint DirichletBoundaryCondition1} (@pxref{Constraint examples}) is used as boundary condition. In the example above, @code{Entity NodesOf[All]} is preferred to @code{Entity NodesOf[Domain]}. In this way, the list of all the nodes of @code{Domain} will not have to be generated. All the nodes of each geometrical element in @code{Support Domain} will be directly taken into account. @c ......................................................................... @c High Order Nodal Finite Element Space @c ......................................................................... @node High order space, Global values, Conform space, FunctionSpace examples @subsection High order nodal finite element space Higher order finite elements can be directly taken into account by @code{BF_Node}. Hierarchical finite elements for 0-forms can be used by simply adding other basis functions (associated with other geometrical entities, e.g., edges and facets) to @code{BasisFunction}, e.g., @example @dots{} BasisFunction @{ @{ Name sn; NameOfCoef vn; Function BF_Node; Support Domain; Entity NodesOf[All]; @} @{ Name s2; NameOfCoef v2; Function BF_Node_2E; Support Domain; Entity EdgesOf[All]; @} @} @dots{} @end example @c ......................................................................... @c Nodal Finite Element Space with Floating Potentials @c ......................................................................... @node Global values, Curl-conform space, High order space, FunctionSpace examples @subsection Nodal finite element space with floating potentials A scalar potential with floating values @var{vf} on certain boundaries @var{Gf}, @var{f} in @var{Cf}, e.g., for electrostatic problems, can be expressed as @tex $$ v = \sum_{n\in N_v} v_n s_n + \sum_{f\in C_f} v_f s_f \quad v\in S^0(W) $$ @end tex @ifnottex @var{v} = Sum [ @var{vn} * @var{sn}, for all @var{n} in @var{Nv} ] + Sum [ @var{vf} * @var{sf}, for all @var{f} in @var{Cf} ], @var{v} in @i{S0(W)} @end ifnottex @noindent where @var{Nv} is the set of inner nodes of @var{W} and each function @var{sf} is associated with the group of nodes of boundary @var{Gf}, @var{f} in @var{Cf} (@code{SkinDomainC}); @var{sf} is the sum of the nodal basis functions of all the nodes of @var{Cf}. Its function space is defined by @example FunctionSpace @{ @{ Name Hgrad_v_floating; Type Form0; BasisFunction @{ @{ Name sn; NameOfCoef vn; Function BF_Node; Support Domain; Entity NodesOf[All, Not SkinDomainC]; @} @{ Name sf; NameOfCoef vf; Function BF_GroupOfNodes; Support Domain; Entity GroupsOfNodesOf[SkinDomainC]; @} @} GlobalQuantity @{ @{ Name GlobalElectricPotential; Type AliasOf; NameOfCoef vf; @} @{ Name GlobalElectricCharge; Type AssociatedWith; NameOfCoef vf; @} @} Constraint @{ @dots{} @} @} @} @end example @noindent Two global quantities have been associated with this space: the electric potential @code{Global@-ElectricPotential}, being an alias of coefficient @code{vf}, and the electric charge @code{GlobalElec@-tricCharge}, being associated with coefficient @code{vf}. @c ......................................................................... @c Edge Finite Element Space @c ......................................................................... @node Curl-conform space, Gauge condition, Global values, FunctionSpace examples @subsection Edge finite element space Another space is the edge finite element space, denoted @i{S1(W)}, containing 1-forms, i.e., curl-conform fields: @tex $$ {\bf h} = \sum_{e\in E} h_e {\bf s}_e \quad{\bf h}\in S^1(W) $$ @end tex @ifnottex @var{h} = Sum [ @var{he} * @var{se}, for all @var{e} in @var{E} ], @var{h} in @i{S1(W)} @end ifnottex @noindent where @var{E} is the set of edges of @var{W}, @var{se} is the edge basis function for edge @var{e} and @var{he} is the circulation of @var{h} along edge @var{e}. It is defined by @example FunctionSpace @{ @{ Name Hcurl_h; Type Form1; BasisFunction @{ @{ Name se; NameOfCoef he; Function BF_Edge; Support Domain; Entity EdgesOf[All]; @} @} Constraint @{ @dots{} @} @} @} @end example @c ......................................................................... @c Edge Finite Element Space with Gauge Condition @c ......................................................................... @node Gauge condition, Coupled spaces, Curl-conform space, FunctionSpace examples @subsection Edge finite element space with gauge condition A 1-form function space containing vector potentials can be associated with a gauge condition, which can be defined as a constraint, e.g., a zero value is fixed for all circulations along edges of a tree (@code{EdgesOfTreeIn}) built in the mesh (@code{Domain}), having to be complete on certain boundaries (@code{StartingOn Surf}): @example Constraint @{ @{ Name GaugeCondition_a_Mag_3D; Type Assign; Case @{ @{ Region Domain; SubRegion Surf; Value 0.; @} @} @} @} FunctionSpace @{ @{ Name Hcurl_a_Gauge; Type Form1; BasisFunction @{ @{ Name se; NameOfCoef ae; Function BF_Edge; Support Domain; Entity EdgesOf[All]; @} @} Constraint @{ @{ NameOfCoef ae; EntityType EdgesOfTreeIn; EntitySubType StartingOn; NameOfConstraint GaugeCondition_a_Mag_3D; @} @dots{} @} @} @} @end example @c ......................................................................... @c Coupled Edge and Nodal Finite Element Spaces @c ......................................................................... @node Coupled spaces, Multiply connected domains, Gauge condition, FunctionSpace examples @subsection Coupled edge and nodal finite element spaces A 1-form function space, containing curl free fields in certain regions @var{WcC} (@code{DomainCC}) of @var{W}, which are the complementary part of @var{Wc} (@code{DomainC}) in @var{W}, can be explicitly characterized by @tex $$ {\bf h} = \sum_{k\in E_c} h_k {\bf s}_k + \sum_{n\in N_c^C} \phi_n {\bf v}_n \quad{\bf h}\in S^1(W) $$ @end tex @ifnottex @var{h} = Sum [ @var{hk} * @var{sk}, for all @var{e} in @var{Ec} ] + Sum [ @var{phin} * @var{vn}, for all @var{n} in @var{NcC} ], @var{h} in @i{S1(W)} @end ifnottex @noindent where @var{Ec} is the set of inner edges of @var{W}, @var{NcC} is the set of nodes inside @var{WcC} and on its boundary @var{dWcC}, @var{sk} is an edge basis function and @var{vn} is a vector nodal function. Such a space, coupling a vector field with a scalar potential, can be defined by @example FunctionSpace @{ @{ Name Hcurl_hphi; Type Form1; BasisFunction @{ @{ Name sk; NameOfCoef hk; Function BF_Edge; Support DomainC; Entity EdgesOf[All, Not SkinDomainC]; @} @{ Name vn; NameOfCoef phin; Function BF_GradNode; Support DomainCC; Entity NodesOf[All]; @} @{ Name vn; NameOfCoef phic; Function BF_GroupOfEdges; Support DomainC; Entity GroupsOfEdgesOnNodesOf[SkinDomainC];@} @} Constraint @{ @{ NameOfCoef hk; EntityType EdgesOf; NameOfConstraint MagneticField; @} @{ NameOfCoef phin; EntityType NodesOf; NameOfConstraint MagneticScalarPotential; @} @{ NameOfCoef phic; EntityType NodesOf; NameOfConstraint MagneticScalarPotential; @} @} @} @} @end example @noindent This example points out the definition of a piecewise defined basis function, e.g., function @code{vn} being defined with @code{BF_GradNode} in @code{DomainCC} and @code{BF_GroupOfEdges} in @code{DomainC}. This leads to an easy coupling between these regions. @c ......................................................................... @c Coupled Edge and Nodal Finite Element Spaces for Multiply Connected Domains @c ......................................................................... @node Multiply connected domains, , Coupled spaces, FunctionSpace examples @subsection Coupled edge and nodal finite element spaces for multiply connected domains In case a multiply connected domain @var{WcC} is considered, basis functions associated with cuts (@code{SurfaceCut}) have to be added to the previous basis functions, which gives the function space below: @example Group @{ _TransitionLayer_SkinDomainC_ = ElementsOf[SkinDomainC, OnOneSideOf SurfaceCut]; @} FunctionSpace @{ @{ Name Hcurl_hphi; Type Form1; BasisFunction @{ @dots{} @var{same as above} @dots{} @{ Name sc; NameOfCoef Ic; Function BF_GradGroupOfNodes; Support ElementsOf[DomainCC, OnOneSideOf SurfaceCut]; Entity GroupsOfNodesOf[SurfaceCut]; @} @{ Name sc; NameOfCoef Icc; Function BF_GroupOfEdges; Support DomainC; Entity GroupsOfEdgesOf [SurfaceCut, InSupport _TransitionLayer_SkinDomainC_]; @} @} GlobalQuantity @{ @{ Name I; Type AliasOf ; NameOfCoef Ic; @} @{ Name U; Type AssociatedWith; NameOfCoef Ic; @} @} Constraint @{ @dots{} @var{same as above} @dots{} @{ NameOfCoef Ic; EntityType GroupsOfNodesOf; NameOfConstraint Current; @} @{ NameOfCoef Icc; EntityType GroupsOfNodesOf; NameOfConstraint Current; @} @{ NameOfCoef U; EntityType GroupsOfNodesOf; NameOfConstraint Voltage; @} @} @} @} @end example @noindent Global quantities associated with the cuts, i.e., currents and voltages if @var{h} is the magnetic field, have also been defined. @c ------------------------------------------------------------------------- @c Jacobian Examples @c ------------------------------------------------------------------------- @node Jacobian examples, Integration examples, FunctionSpace examples, Short examples @section @code{Jacobian} examples @cindex Jacobian, examples A simple Jacobian method is for volume transformations (of @var{n}-D regions in @var{n}-D geometries; @var{n} = 1, 2 or 3), e.g., in region @code{Domain}, @example Jacobian @{ @{ Name Vol; Case @{ @{ Region Domain; Jacobian Vol; @} @} @} @} @end example @noindent @code{Jacobian VolAxi} would define a volume Jacobian for axisymmetrical problems. A Jacobian method can also be piecewise defined, in @code{DomainInf}, where an infinite geometrical transformation has to be made using two constant parameters (inner and outer radius of a spherical shell), and in all the other regions (@code{All}, being the default); in each case, a volume Jacobian is used. This method is defined by: @example Jacobian @{ @{ Name Vol; Case @{ @{ Region DomainInf; Jacobian VolSphShell @{Val_Rint, Val_Rext@}; @} @{ Region All; Jacobian Vol; @} @} @} @} @end example @c ------------------------------------------------------------------------- @c Integration Examples @c ------------------------------------------------------------------------- @node Integration examples, Formulation examples, Jacobian examples, Short examples @section @code{Integration} examples @cindex Integration, examples A commonly used numerical integration method is the @code{Gauss} integration, with a number of integration points (@code{NumberOfPoints}) depending on geometrical element types (@code{GeoElement}), i.e. @example Integration @{ @{ Name Int_1; Case @{ @{Type Gauss; Case @{ @{ GeoElement Triangle ; NumberOfPoints 4; @} @{ GeoElement Quadrangle ; NumberOfPoints 4; @} @{ GeoElement Tetrahedron; NumberOfPoints 4; @} @{ GeoElement Hexahedron ; NumberOfPoints 6; @} @{ GeoElement Prism ; NumberOfPoints 9; @} @} @} @} @} @} @end example @noindent The method above is valid for both 2D and 3D problems, for different kinds of elements. @c ------------------------------------------------------------------------- @c Formulation Examples @c ------------------------------------------------------------------------- @node Formulation examples, Resolution examples, Integration examples, Short examples @section @code{Formulation} examples @cindex Formulation, examples @menu * Electrostatics:: * Electrostatics 2:: * Magnetostatics:: * Magnetodynamics:: * Other formulations:: @end menu @c todo: ajouter un vrai exemple de circuit (cf. constraint example) @c ......................................................................... @c Electrostatic Scalar Potential Formulation @c ......................................................................... @node Electrostatics, Electrostatics 2, Formulation examples, Formulation examples @subsection Electrostatic scalar potential formulation @cindex Electrostatic formulation @cindex Formulation, electrostatics @cindex Nodal function space, example An electrostatic formulation using an electric scalar potential @var{v}, i.e. @tex $$ (\epsilon\,{\rm grad}\,v, {\rm grad}\,v')_W = 0 \quad\forall v'\in S^0(W) $$ @end tex @ifnottex ( epsr grad @var{v}, grad @var{vp} ) @var{W} = 0, for all @var{vp} in @i{S0(W)}, @end ifnottex @noindent is expressed by @example Formulation @{ @{ Name Electrostatics_v; Type FemEquation; Quantity @{ @{ Name v; Type Local; NameOfSpace Hgrad_v; @} @} Equation @{ Galerkin @{ [ epsr[] * Dof@{Grad v@} , @{Grad v@} ]; In Domain; Jacobian Vol; Integration Int_1; @} @} @} @} @end example @noindent The density of the @code{Galerkin} term is a copy of the symbolic form of the formulation, i.e., the product of a relative permittivity function @code{epsr[]} by a vector of degrees of freedom (@code{Dof@{.@}}); the scalar product of this with the gradient of test function @code{v} results in a symmetrical matrix. @noindent Note that another @code{Quantity} could be defined for test functions, e.g., @code{vp} defined by @code{@{ Name vp; Type Local; NameOfSpace Hgrad_v; @}}. However, its use would result in the computation of a full matrix and consequently in a loss of efficiency. @c ......................................................................... @c Electrostatic Scalar Potential Formulation with Floating Potentials and Electric Charges @c ......................................................................... @node Electrostatics 2, Magnetostatics, Electrostatics, Formulation examples @subsection Electrostatic scalar potential formulation with floating potentials and electric charges @cindex Floating potential, example @cindex Global quantity, example An extension of the formulation above can be made to take floating potentials and electrical charges into account (the latter being defined in @code{FunctionSpace Hgrad_v_floating}), i.e. @example Formulation @{ @{ Name Electrostatics_v_floating; Type FemEquation; Quantity @{ @{ Name v; Type Local; NameOfSpace Hgrad_v_floating; @} @{ Name V; Type Global; NameOfSpace Hgrad_v_floating [GlobalElectricPotential]; @} @{ Name Q; Type Global; NameOfSpace Hgrad_v_floating [GlobalElectricCharge]; @} @} Equation @{ Galerkin @{ [ epsr[] * Dof@{Grad v@} , @{Grad v@} ]; In Domain; Jacobian Vol; Integration Int_1; @} GlobalTerm @{ [ - Dof@{Q@}/eps0 , @{V@} ]; In SkinDomainC; @} @} @} @} @end example @noindent with the predefinition @code{Function @{ eps0 = 8.854187818e-12; @}}. @c ......................................................................... @c Magnetostatic 3D Vector Potential Formulation @c ......................................................................... @node Magnetostatics, Magnetodynamics, Electrostatics 2, Formulation examples @subsection Magnetostatic 3D vector potential formulation @cindex Edge element space, example A magnetostatic 3D vector potential formulation @tex $$ (\nu\,{\rm curl}\,{\bf a}, {\rm curl}\,{\bf a}')_W = ({\bf j}_s , {\bf a}')_{W_s} \quad\forall{\bf a}'\in S^1(W), {\rm\ with\ gauge\ condition} $$ @end tex @ifnottex ( @var{nu} curl @var{a} , curl @var{ap} ) @var{W} - ( @var{js} , @var{ap} ) @var{Ws} = 0, for all @var{ap} in @i{S1(W)} with gauge condition, @end ifnottex @noindent with a source current density @var{js} in inductors @var{Ws}, is expressed by @example Formulation @{ @{ Name Magnetostatics_a_3D; Type FemEquation; Quantity @{ @{ Name a; Type Local; NameOfSpace Hcurl_a_Gauge; @} @} Equation @{ Galerkin @{ [ nu[] * Dof@{Curl a@} , @{Curl a@} ]; In Domain; Jacobian Vol; Integration Int_1; @} Galerkin @{ [ - SourceCurrentDensity[] , @{a@} ]; In DomainWithSourceCurrentDensity; Jacobian Vol; Integration Int_1; @} @} @} @} @end example @noindent Note that @var{js} is here given by a function @code{SourceCurrentDensity[]}, but could also be given by data computed from another problem, e.g., from an electrokinetic problem (coupling of formulations) or from a fully fixed function space (constraints fixing the density, which is usually more efficient in time domain analyses). @c ......................................................................... @c Magnetodynamic 3D or 2D Magnetic Field and Magnetic Scalar Potential Formulation @c ......................................................................... @node Magnetodynamics, Other formulations, Magnetostatics, Formulation examples @subsection Magnetodynamic 3D or 2D magnetic field and magnetic scalar potential formulation A magnetodynamic 3D or 2D @var{h-phi} formulation, i.e., coupling the magnetic field @var{h} with a magnetic scalar potential @var{phi}, @tex $$ \partial_t (\mu\,{\bf h}, {\bf h}')_W + (\rho\,{\rm curl}\,{\bf h}, {\rm curl}\,{\bf h}')_{W_c} = 0 \quad\forall{\bf h}'\in S^1(W) $$ @end tex @ifnottex Dt ( @var{mu} @var{h} , @var{hp} ) @var{W} + ( @var{ro} curl @var{h} , curl @var{hp} ) @var{Wc} = 0, for all @var{hp} in @i{S1(W)}, @end ifnottex @noindent can be expressed by @example Formulation @{ @{ Name Magnetodynamics_hphi; Type FemEquation; Quantity @{ @{ Name h; Type Local; NameOfSpace Hcurl_hphi; @} @} Equation @{ Galerkin @{ Dt [ mu[] * Dof@{h@} , @{h@} ]; In Domain; Jacobian Vol; Integration Int_1; @} Galerkin @{ [ rho[] * Dof@{Curl h@} , @{Curl h@} ]; In DomainC; Jacobian Vol; Integration Int_1; @} @} @} @} @end example @c ......................................................................... @c Nonlinearities, Mixed Formulations, ... @c ......................................................................... @node Other formulations, , Magnetodynamics, Formulation examples @subsection Nonlinearities, Mixed formulations, @dots{} In case nonlinear physical characteristics are considered, arguments are used for associated functions, e.g., @code{mu[@{h@}]}. Several test functions can be considered in an @code{Equation} field. Consequently, mixed formulations can be defined. @c ------------------------------------------------------------------------- @c Resolution Examples @c ------------------------------------------------------------------------- @node Resolution examples, PostProcessing examples, Formulation examples, Short examples @section @code{Resolution} examples @cindex Resolution, examples @menu * Static resolution:: * Frequency domain resolution:: * Time domain resolution:: * Nonlinear resolution:: * Coupled formulations:: @end menu @c ......................................................................... @c Static Resolution (Electrostatic Problem) @c ......................................................................... @node Static resolution, Frequency domain resolution, Resolution examples, Resolution examples @subsection Static resolution (electrostatic problem) A static resolution, e.g., for the electrostatic formulation (@pxref{Formulation examples}), can be defined by @example Resolution @{ @{ Name Electrostatics_v; System @{ @{ Name Sys_Ele; NameOfFormulation Electrostatics_v; @} @} Operation @{ Generate[Sys_Ele]; Solve[Sys_Ele]; SaveSolution[Sys_Ele]; @} @} @} @end example @noindent The generation (@code{Generate}) of the matrix of the system @code{Sys_Ele} will be made with the formulation @code{Electrostatics_v}, followed by its solving (@code{Solve}) and the saving of the solution (@code{SaveSolution}). @c ......................................................................... @c Frequency Domain Resolution (Magnetodynamic Problem) @c ......................................................................... @node Frequency domain resolution, Time domain resolution, Static resolution, Resolution examples @subsection Frequency domain resolution (magnetodynamic problem) A frequency domain resolution, e.g., for the magnetodynamic @var{h-phi} formulation (@pxref{Formulation examples}), is given by @example Resolution @{ @{ Name Magnetodynamics_hphi; System @{ @{ Name Sys_Mag; NameOfFormulation Magnetodynamics_hphi; Frequency Freq; @} @} Operation @{ Generate[Sys_Mag]; Solve[Sys_Mag]; SaveSolution[Sys_Mag]; @} @} @} @end example @noindent preceded by the definition of constant @code{Freq}, e.g., @example Function @{ Freq = 50.; @} @end example @c ......................................................................... @c Time Domain Resolution (Magnetodynamic Problem) @c ......................................................................... @node Time domain resolution, Nonlinear resolution, Frequency domain resolution, Resolution examples @subsection Time domain resolution (magnetodynamic problem) A time domain resolution, e.g., for the same magnetodynamic @var{h-phi} formulation (@pxref{Formulation examples}), is given by @example Resolution @{ @{ Name Magnetodynamics_hphi_Time; System @{ @{ Name Sys_Mag; NameOfFormulation Magnetodynamics_hphi; @} @} Operation @{ InitSolution[Sys_Mag]; SaveSolution[Sys_Mag]; TimeLoopTheta[Mag_Time0, Mag_TimeMax, Mag_DTime[], Mag_Theta[]] @{ Generate[Sys_Mag]; Solve[Sys_Mag]; SaveSolution[Sys_Mag]; @} @} @} @} @end example @noindent If, e.g., the @code{Resolution} above is preceded by the constant and function definitions below @example Function @{ Tc = 10.e-3; Mag_Time0 = 0.; Mag_TimeMax = 2.*Tc; Mag_DTime[] = Tc/20.; Mag_Theta[] = 1./2.; @} @end example @noindent the performed time domain analysis will be a Crank-Nicolson scheme (theta-scheme with @code{Theta = 0.5}) with initial time 0 ms, end time 20 ms and time step 1 ms. @c ......................................................................... @c Nonlinear Time Domain Resolution (Magnetodynamic Problem) @c ......................................................................... @node Nonlinear resolution, Coupled formulations, Time domain resolution, Resolution examples @subsection Nonlinear time domain resolution (magnetodynamic problem) In case a nonlinear problem is solved, an iterative loop has to be defined in an appropriate level of the recursive resolution operations, e.g., for the magnetodynamic problem above, @example @dots{} Operation @{ InitSolution[Sys_Mag]; SaveSolution[Sys_Mag]; TimeLoopTheta[Mag_Time0, Mag_TimeMax, Mag_DTime[], Mag_Theta[]] @{ IterativeLoop[NL_NbrMax, NL_Eps, NL_Relax] @{ GenerateJac[Sys_Mag]; SolveJac[Sys_Mag]; @} SaveSolution[Sys_Mag]; @} @} @dots{} @end example @noindent preceded by constant definitions, e.g., @example Function @{ NL_Eps = 1.e-4; NL_Relax = 1.; NL_NbrMax = 80; @} @end example @c ......................................................................... @c Coupled Formulations @c ......................................................................... @node Coupled formulations, , Nonlinear resolution, Resolution examples @subsection Coupled formulations A coupled problem, e.g., magnetodynamic (in frequency domain; @code{Frequency Freq}) - thermal (in time domain) coupling, with temperature dependent characteristics (e.g., @code{rho[@{T@}]}, @dots{}), can be defined by: @example Resolution @{ @{ Name MagnetoThermalCoupling_hphi_T; System @{ @{ Name Sys_Mag; NameOfFormulation Magnetodynamics_hphi; Frequency Freq; @} @{ Name Sys_The; NameOfFormulation Thermal_T; @} @} Operation @{ InitSolution[Sys_Mag]; InitSolution[Sys_The]; IterativeLoop[NL_NbrMax, NL_Eps, NL_Relax] @{ GenerateJac[Sys_Mag]; SolveJac[Sys_Mag]; GenerateJac[Sys_The]; SolveJac[Sys_The]; @} SaveSolution[Sys_Mag]; SaveSolution[Sys_The]; @} @} @} @end example @noindent Two systems of equations, @code{Sys_Mag} and @code{Sys_The}, will be solved iteratively until convergence (@code{Criterion}), using a relaxation factor (@code{RelaxationFactor}). It can be seen through these examples that many resolutions can be linked or nested directly by the user, which gives a great freedom for coupled problems. @c ------------------------------------------------------------------------- @c PostProcessing Examples @c ------------------------------------------------------------------------- @node PostProcessing examples, PostOperation examples, Resolution examples, Short examples @section @code{PostProcessing} examples @cindex Post-processing, examples The quantities to be post-computed based on a solution of a resolution are defined, e.g., for the electrostatic problem (@pxref{Formulation examples}; @pxref{Resolution examples}), for the solution associated with the formulation @code{Electrostatics_v}, by @example PostProcessing @{ @{ Name EleSta_v; NameOfFormulation Electrostatics_v; Quantity @{ @{ Name v; Value @{ Local @{ [ @{v@} ]; In Domain; @} @} @} @{ Name e; Value @{ Local @{ [ -@{Grad v@} ]; In Domain; @} @} @} @{ Name d; Value @{ Local @{ [ -eps0*epsr[] *@{Grad v@} ]; In Domain; @} @} @} @} @} @} @end example @noindent The electric scalar potential @var{v} (@code{v}), the electric field @var{e} (@code{e}) and the electric flux density @var{d} (@code{d}) can all be computed from the solution. They are all defined in the region @code{Domain}. The quantities for the solution associated with the formulation @code{Electrostatics_v_float@-ing} are defined by @example PostProcessing @{ @{ Name EleSta_vf; NameOfFormulation Electrostatics_v_floating; Quantity @{ @dots{} @var{same as above} @dots{} @{ Name Q; Value @{ Local @{ [ @{Q@} ]; In SkinDomainC; @} @} @} @{ Name V; Value @{ Local @{ [ @{V@} ]; In SkinDomainC; @} @} @} @} @} @} @end example @noindent which points out the way to define post-quantities based on global quantities. @c ------------------------------------------------------------------------- @c PostOperation Examples @c ------------------------------------------------------------------------- @node PostOperation examples, , PostProcessing examples, Short examples @section @code{PostOperation} examples @cindex Post-operation, examples The simplest post-processing operation is the generation of maps of local quantities, i.e., the display of the computed fields on the mesh. For example, using the @code{PostProcessing} defined in @ref{PostProcessing examples}, the maps of the electric scalar potential and of the electric field on the elements of the region @code{Domain} are defined as: @example PostOperation @{ @{ Name Map_v_e; NameOfPostProcessing EleSta_v ; Operation @{ Print [ v, OnElementsOf Domain, File "map_v.pos" ]; Print [ e, OnElementsOf Domain, File "map_e.pos" ]; @} @} @} @end example It is also possible to display local quantities on sections of the mesh, here for example on the plane containing the points (0,0,1), (1,0,1) and (0,1,1): @example Print [ v, OnSection @{ @{0,0,1@} @{1,0,1@} @{0,1,1@} @}, File "sec_v.pos" ]; @end example Finally, local quantities can also be interpolated on another mesh than the one on which they have been computed. Six types of grids can be specified for this interpolation: a single point, a set of points evenly distributed on a line, a set of points evenly distributed on a plane, a set of points evenly distributed in a box, a set of points defined by a parametric equation, and a set of elements belonging to a different mesh than the original one: @example Print [ e, OnPoint @{0,0,1@} ]; Print [ e, OnLine @{ @{0,0,1@} @{1,0,1@} @} @{125@} ]; Print [ e, OnPlane @{ @{0,0,1@} @{1,0,1@} @{0,1,1@} @} @{125, 75@} ]; Print [ e, OnBox @{ @{0,0,1@} @{1,0,1@} @{0,1,1@} @{0,0,2@} @} @{125, 75, 85@} ]; Print [ e, OnGrid @{$A, $B, 1@} @{ 0:1:1/125, 0:1:1/75, 0 @} ]; Print [ e, OnGrid Domain2 ]; @end example Many options can be used to modify the aspect of all these maps, as well as the default behaviour of the @code{Print} commands. See @ref{Types for PostOperation}, to get the list of all these options. For example, to obtain a map of the scalar potential at the barycenters of the elements on the boundary of the region @code{Domain}, in a table oriented format appended to an already existing file @code{out.txt}, the operation would be: @example Print [ v, OnElementsOf Domain, Depth 0, Skin, Format Table, File >> "out.txt" ]; @end example Global quantities, which are associated with regions (and not with the elements of the mesh of these regions), are displayed thanks to the @code{OnRegion} operation. For example, the global potential and charge on the region @code{SkinDomainC} can be displayed with: @example PostOperation @{ @{ Name Val_V_Q; NameOfPostProcessing EleSta_vf ; Operation @{ Print [ V, OnRegion SkinDomainC ]; Print [ Q, OnRegion SkinDomainC ]; @} @} @} @end example @c ========================================================================= @c Complete Examples @c ========================================================================= @node Complete examples, File formats, Short examples, Top @chapter Complete examples @cindex Complete examples @cindex Examples, complete @cindex Wiki This chapter presents complete examples that can be run ``as is'' with GetDP (@pxref{Running GetDP}). Many other ready-to-use examples are available in the GetDP wiki at the following address: @url{https://geuz.org/trac/getdp} (username=getdp; password=getdp). @menu * Electrostatic problem:: * Magnetostatic problem:: * Magnetodynamic problem:: @end menu @c ------------------------------------------------------------------------- @c Electrostatic Problem @c ------------------------------------------------------------------------- @node Electrostatic problem, Magnetostatic problem, Complete examples, Complete examples @section Electrostatic problem Let us first consider a simple electrostatic problem. The formulation used is an electric scalar potential formulation (file @file{EleSta_v.pro}, including files @file{Jacobian_Lib.pro} and @file{Integration_Lib.pro}). It is applied to a microstrip line (file @file{mStrip.pro}), whose geometry is defined in the file @file{mStrip.geo} (@pxref{Gmsh examples}). The geometry is two-dimensional and by symmetry only one half of the structure is modeled. @image{Strip,,} Note that the structure of the following files points out the separation of the data describing the particular problem and the method used to solve it (@pxref{Numerical tools as objects}), and therefore how it is possible to build black boxes adapted to well defined categories of problems. The files are commented (@pxref{Comments}) and can be run without any modification. @sp 1 @verbatiminclude mStrip.pro @sp 1 @verbatiminclude EleSta_v.pro @sp 1 @verbatiminclude Jacobian_Lib.pro @sp 1 @verbatiminclude Integration_Lib.pro @page @c ------------------------------------------------------------------------- @c Magnetostatic Problem @c ------------------------------------------------------------------------- @node Magnetostatic problem, Magnetodynamic problem, Electrostatic problem, Complete examples @section Magnetostatic problem We now consider a magnetostatic problem. The formulation used is a 2D magnetic vector potential formulation (see file @file{MagSta_a_2D.pro}). It is applied to a core-inductor system (file @file{CoreSta.pro}), whose geometry is defined in theh file @file{Core.geo} (@pxref{Gmsh examples}). The geometry is two-dimensional and, by symmetry, one fourth of the structure is modeled. @image{Core,,} The jacobian and integration methods used are the same as for the electrostatic problem presented in @ref{Electrostatic problem}. @sp 1 @verbatiminclude CoreSta.pro @sp 1 @verbatiminclude MagSta_a_2D.pro @page @c ------------------------------------------------------------------------- @c Magnetodynamic Problem @c ------------------------------------------------------------------------- @node Magnetodynamic problem, , Magnetostatic problem, Complete examples @section Magnetodynamic problem As a third example we consider a magnetodynamic problem. The formulation is a two-dimensional a-v formulation (see file @file{MagDyn_av_2D.pro}, which includes the same jacobian and integration library files as in @ref{Electrostatic problem}). It is applied to a core-inductor system (defined in file @file{CoreMassive.pro}), whose geometry has already been defined in file @file{Core.geo}. @sp 1 @verbatiminclude CoreMassive.pro @sp 1 @verbatiminclude MagDyn_av_2D.pro @c ========================================================================= @c File Formats @c ========================================================================= @node File formats, Gmsh examples, Complete examples, Top @appendix File formats This chapter describes the file formats that cannot be modified by the user. The format of the problem definition structure is explained in @ref{Objects}, and @ref{Types for objects}. The format of the post-processing files is explained in @ref{Types for PostOperation}. @menu * Input file format:: * Output file format:: @end menu @c ------------------------------------------------------------------------- @c Input File Format @c ------------------------------------------------------------------------- @node Input file format, Output file format, File formats, File formats @section Input file format @cindex Input file format @cindex Gmsh, file format @cindex Mesh, file format @cindex File, mesh @cindex File, @file{.msh} @cindex @file{.msh} file The native mesh format read by GetDP is the mesh file format produced by Gmsh (@url{http://geuz.org/gmsh}). In its ``version 1'' incarnation, an `msh' file is divided into two sections, defining the nodes and the elements in the mesh. @example $NOD @var{number-of-nodes} @var{node-number} @var{x-coord} @var{y-coord} @var{z-coord} @dots{} $ENDNOD $ELM @var{number-of-elements} @var{elm-number} @var{elm-type} @var{elm-region} @var{unused} @var{number-of-nodes} @var{node-numbers} @dots{} $ENDELM @end example @noindent All the syntactic variables stand for integers except @var{x-coord}, @var{y-coord} and @var{z-coord} which stand for floating point values. The @var{elm-type} value defines the geometrical type for the element: @noindent @var{elm-type}: @table @code @item 1 Line (2 nodes, 1 edge). @item 2 Triangle (3 nodes, 3 edges). @item 3 Quadrangle (4 nodes, 4 edges). @item 4 Tetrahedron (4 nodes, 6 edges, 4 facets). @item 5 Hexahedron (8 nodes, 12 edges, 6 facets). @item 6 Prism (6 nodes, 9 edges, 5 facets). @item 7 Pyramid (5 nodes, 8 edges, 5 facets). @item 15 Point (1 node). @end table GetDP can also read more recent versions of the `msh' format (2.0 and above). See the Gmsh documentation for more information about these formats. @c ------------------------------------------------------------------------- @c Output File Format @c ------------------------------------------------------------------------- @node Output file format, , Input file format, File formats @section Output file format @cindex Output file format @menu * File pre:: * File res:: @end menu @c ......................................................................... @c File .pre @c ......................................................................... @node File pre, File res, Output file format, Output file format @subsection File @file{.pre} @cindex File, pre-processing @cindex @file{.pre} file @cindex File, @file{.pre} The @file{.pre} file is generated by the pre-processing stage. It contains all the information about the degrees of freedom to be considered during the processing stage for a given resolution (i.e., unknowns, fixed values, initial values, etc.). @example $Resolution /* '@var{resolution-id}' */ @var{main-resolution-number} @var{number-of-dofdata} $EndResolution $DofData /* #@var{dofdata-number} */ @var{resolution-number} @var{system-number} @var{number-of-function-spaces} @var{function-space-number} @dots{} @var{number-of-time-functions} @var{time-function-number} @dots{} @var{number-of-partitions} @var{partition-index} @dots{} @var{number-of-any-dof} @var{number-of-dof} @var{dof-basis-function-number} @var{dof-entity} @var{dof-harmonic} @var{dof-type} @var{dof-data} @dots{} $EndDofData @dots{} @end example @noindent with @example @var{dof-data}: @var{equation-number} @var{nnz} (@var{dof-type}: 1; @var{unknown}) | @var{dof-value} @var{dof-time-function-number} (@var{dof-type}: 2; @var{fixed value}) | @var{dof-associate-dof-number} @var{dof-value} @var{dof-time-function-number} (@var{dof-type}: 3; @var{associated degree of freedom}) | @var{equation-number} @var{dof-value} (@var{dof-type}: 5; @var{initial value for an unknown}) @end example @noindent Notes: @enumerate @item There is one @code{$DofData} field for each system of equations considered in the resolution (including those considered in pre-resolutions). @item The @var{dofdata-number} of a @code{$DofData} field is determined by the order of this field in the @file{.pre} file. @item @var{number-of-dof} is the dimension of the considered system of equations, while @var{number-of-any-dof} is the total number of degrees of freedom before the application of constraints. @item Each degree of freedom is coded with three integer values, which are the associated basis function, entity and harmonic numbers, i.e., @var{dof-basis-function-number}, @var{dof-entity} and @var{dof-harmonic}. @item @var{nnz} is not used at the moment. @end enumerate @c ......................................................................... @c File .res @c ......................................................................... @node File res, , File pre, Output file format @subsection File @file{.res} @cindex File, result @cindex @file{.res} file @cindex File, @file{.res} The @file{.res} file is generated by the processing stage. It contains the solution of the problem (or a part of it in case of program interruption). @example $ResFormat /* GetDP v@var{getdp-version-number}, @var{string-for-format} */ 1.1 @var{file-res-format} $EndResFormat $Solution /* DofData #@var{dofdata-number} */ @var{dofdata-number} @var{time-value} @var{time-imag-value} @var{time-step-number} @var{solution-value} @dots{} $EndSolution @dots{} @end example @noindent Notes: @enumerate @item A @code{$Solution} field contains the solution associated with a @code{$DofData} field. @item There is one @code{$Solution} field for each time step, of which the time is @var{time-value} (0 for non time dependent or non modal analyses) and the imaginary time is @var{time-imag-value} (0 for non time dependent or non modal analyses). @item The order of the @var{solution-value}s in a @code{$Solution} field follows the numbering of the equations given in the @file{.pre} file (one floating point value for each degree of freedom). @end enumerate @c ========================================================================= @c Gmsh Examples @c ========================================================================= @node Gmsh examples, Compiling the source code, File formats, Top @appendix Gmsh examples @cindex Gmsh, examples @cindex Mesh, examples Gmsh is a three-dimensional finite element mesh generator with simple CAD and post-processing capabilities that can be used as a graphical front-end for GetDP. Gmsh can be downloaded from @url{http://geuz.org/gmsh}. This appendix reproduces verbatim the input files needed by Gmsh to produce the mesh files @file{mStrip.msh} and @file{Core.msh} used in the examples of @ref{Complete examples}. @sp 1 @verbatiminclude mStrip.geo @sp 1 @verbatiminclude Core.geo @c ========================================================================= @c Compiling the source code @c ========================================================================= @node Compiling the source code, Frequently asked questions, Gmsh examples, Top @appendix Compiling the source code Stable releases and nightly source snapshots are available from @uref{http://geuz.org/getdp/src/}. You can also access the subversion repository directly: @enumerate @item The first time you want to download the latest full source, type: @example svn co https://geuz.org/svn/getdp/trunk getdp @end example You will be asked to accept the security certificate and to provide your username and password. (Use getdp/getdp for read-only access.) @item To update your local version to the latest and greatest, go in the getdp directory and type: @example svn update @end example @item If you have write access, to commit your changes to the central repository, go in the getdp directory and type: @example svn commit @end example @end enumerate Once you have the source code, you need to run CMake to configure your build (see the @file{README.txt} file in the top-level source directory for detailed information on how to run CMake). Each build can be configured using a series of options, to selectively enable optional modules or features. Here is the list of CMake options: @ftable @code @include cmake_options.texi @end ftable @c ========================================================================= @c Frequently asked questions @c ========================================================================= @node Frequently asked questions, Tips and tricks, Compiling the source code, Top @appendix Frequently asked questions @cindex Frequently asked questions @cindex Questions, frequently asked @cindex FAQ @c ------------------------------------------------------------------------- @c The basics @c ------------------------------------------------------------------------- @menu * The basics:: * Installation:: * Usage:: @end menu @node The basics, Installation, Frequently asked questions, Frequently asked questions @section The basics @enumerate @item What is GetDP? GetDP is a scientific software environment for the numerical solution of integro-differential equations, open to the coupling of physical problems (electromagnetic, thermal, mechanical, etc) as well as of numerical methods (finite element method, integral methods, etc). It can deal with such problems of various dimensions (1D, 2D, 2D axisymmetric or 3D) and time states (static, transient or harmonic). The main feature of GetDP is the closeness between the organization of data defining discrete problems (written by the user in ASCII data files) and the symbolic mathematical expressions of these problems. @item What are the terms and conditions of use? GetDP is distributed under the terms of the GNU General Public License. See @ref{License} for more information. @item What does `GetDP' mean? It's an acronym for a ``General environment for the treatment of Discrete Problems''. @item Where can I find more information? @url{http://geuz.org/getdp} is the primary site to obtain information about GetDP. You will find a short presentation, a complete reference guide as well as a searchable archive of the GetDP mailing list (@email{getdp@@geuz.org}) on this site. @end enumerate @c ------------------------------------------------------------------------- @c Installation @c ------------------------------------------------------------------------- @node Installation, Usage, The basics, Frequently asked questions @section Installation @enumerate @item Which OSes does GetDP run on? Gmsh runs on Windows XP/Vista, Mac OS X, Linux and most Unix variants. @item What do I need to compile GetDP from the sources? You need a C++ and a Fortran 77 compiler as well as the GSL (version 1.2 or higher; freely available from @url{http://sources.redhat.com/gsl}). @item How do I compile GetDP? You need cmake (@url{http://www.cmake.org}) and a C++ compiler (and a Fortran compiler depending on the modules/solvers you want to compile). See @ref{Compiling the source code} and the @file{README.txt} file in the top-level source directory for more information. @item GetDP [from a binary distribution] complains about missing libraries. Try @code{ldd getdp} (or @code{otool -L getdp} on Mac OS X) to check if all the required shared libraries are installed on your system. If not, install them. If it still doesn't work, recompile GetDP from the sources. @end enumerate @c ------------------------------------------------------------------------- @c Usage @c ------------------------------------------------------------------------- @node Usage, , Installation, Frequently asked questions @section Usage @enumerate @item How can I provide a mesh to GetDP? The only meshing format accepted by this version of GetDP is the `msh' format created by Gmsh @url{http://geuz.org/gmsh}. This format being very simple (see the Gmsh reference manual for more details), it should be straightforward to write a converter from your mesh format to the `msh' format. @item How can I visualize the results produced by GetDP? You can specify a format in all post-processing operations. Available formats include @code{Table}, @code{SimpleTable}, @code{TimeTable} and @code{Gmsh}. @code{Table}, @code{SimpleTable} and @code{TimeTable} output lists of numbers easily readable by Excel/gnuplot/Caleida Graph/etc. @code{Gmsh} outputs post-processing views directly loadable by Gmsh. @item How do I change the linear solver used by GetDP? It depends on which linear solver toolkit was enabled when GetDP was compiled. With PETSc-based linear solvers you can either specify options on the command line, or in the @file{.petscrc} file located in your home directly. With Sparskit-based linear solvers you should edit the @file{solver.par} file in the current working directory. You can also remove the file: GetDP will give you the opportunity to create it dynamically next time you perform a linear system solution. @end enumerate @c ========================================================================= @c Tips ans Tricks @c ========================================================================= @node Tips and tricks, Version history, Frequently asked questions, Top @appendix Tips and tricks @cindex Tips @cindex Tricks @cindex Efficiency, tips @itemize @bullet @item Install the 'info' version of this user's guide! On your (Unix) system, this can be achieved by 1) copying all getdp.info* files to the place where your info files live (usually /usr/info), and 2) issuing the command 'install-info /usr/info/getdp.info /usr/info/dir'. You will then be able to access the documentation with the command 'info getdp'. Note that particular sections ("nodes") can be accessed directly. For example, 'info getdp functionspace' will take you directly to the definition of the FunctionSpace object. @item Use emacs to edit your files, and load the C++ mode! This permits automatic syntax highlighting and easy indentation. Automatic loading of the C++ mode for @file{.pro} files can be achieved by adding the following command in your @code{.emacs} file: @code{(setq auto-mode-alist (append '(("\\.pro$" . c++-mode)) auto-mode-alist))}. @item Define integration and Jacobian method in separate files, reusable in all your problem definition structures (@pxref{Includes}). Define meshes, groups, functions and constraints in one file dependent of the geometrical model, and function spaces, formulations, resolutions and post-processings in files independent of the geometrical model. @item Use @code{All} as soon as possible in the definition of topological entities used as @code{Entity} of @code{BasisFunction}s. This will prevent GetDP from constructing unnecessary lists of entities. @item Intentionally misspelling an object type in the problem definition structure will produce an error message listing all available types in the particular context. @item If you don't specify the mandatory arguments on the command line, GetDP will give you the available choices. For example, 'getdp test -pos' (the name of the PostOperation is missing) will produce an error message listing all available PostOperations. @end itemize @c ========================================================================= @c Version history @c ========================================================================= @node Version history, Copyright and credits, Tips and tricks, Top @appendix Version history @cindex Versions @cindex History, versions @cindex Changelog @verbatiminclude ../VERSIONS.txt @c ========================================================================= @c Copyright and credits @c ========================================================================= @node Copyright and credits, License, Version history, Top @appendix Copyright and credits @cindex Copyright @cindex Acknowledgments @cindex Contributors, list @cindex Credits @verbatiminclude ../CREDITS.txt @c ========================================================================= @c License @c ========================================================================= @node License, Concept index, Copyright and credits, Top @appendix License @cindex License @verbatiminclude ../LICENSE.txt @c ========================================================================= @c Concept Index (cindex) @c ========================================================================= @node Concept index, Metasyntactic variable index, License, Top @unnumbered Concept index @cindex Index, concepts @cindex Concepts, index @printindex cp @c ========================================================================= @c Variable Index (vindex) @c ========================================================================= @node Metasyntactic variable index, Syntax index, Concept index, Top @unnumbered Metasyntactic variable index @cindex Index, metasyntactic variables @cindex Variables, index @cindex Metasyntactic variables, index @printindex vr @c ========================================================================= @c Syntax Index (tindex+findex) @c ========================================================================= @node Syntax index, , Metasyntactic variable index, Top @unnumbered Syntax index @cindex Index, syntax @cindex Syntax, index @cindex Keywords, index @printindex tp @bye getdp-2.4.2-source/doc/texinfo/Core.jpg000644 001750 001750 00000065045 11266605602 021431 0ustar00geuzainegeuzaine000000 000000 JFIFHHExifMM*JR(iZHH\CC\ }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( ( ( (?k >5-]~(e~)|:7&L/|@"i> ?fiŇ>˩WOm i/_-CO_įE|Gkoß~~ xSK3_%|,W~x>о&xsƋsSKMP@P@P@P@P@P@P@P@P@P@|Y4?cg_4~|M_xk4Ofx¾,>7k'^^iz΍Z]iڦuse}m=êzwoc<[~+~˞d?u74'$牿 W+ğڞ 0/"_@mO2;߲ R]ۏu"?- #>H?@ _¿oj_&ooD"c6%dG_+ZX[_F|y?h__u~Ο~~N 1)/<+Nҵ j!.i6~ uTѮ/#mgJ-If ( ( ( ( ( ( ( ( (?/&o> ( __0~~*7ɡ~~ {?+k꺙oڇoᯇ (u+X!?w>+Hj4-?_߶K/Y'cmkX?|E鿵/ïk~?]<'m-/4( (,R'5Re)|E7f;OԼYwú~ _'NfhZV_f{{,Ҁ|AS 5Ŀj?ط_o/|3t[x~(9j/B7+Bŵ_/x:~7_g񏃼Y/~WxsQC5=_B?jw^/T^_kp\,J>8~ ~>0x?>оduXzg^xOzI?XAq隇n(AesNmO~;.owo kO_AOxw犛_ -Bkߵcͦho8x;ߎ4.#>>EOPx>+Sυ_~G ~2|:?;?_ +GOt?蚟u;-5n4s:x;2oI_xW7-o[QyQ5?Cq$y_t6y="O~xx#i\xE?'8|f6#n៏u^E&<+U%/zxOC<9y.F}O⎅'6Z^1m ¾=𯆼u_xƞ ox;>tWŞmx{sy״MSFt˭;TӮg)X ?V|K o+ *Z_eo+K?2_*?G?gjay~Ҿ$moك%w@ُG1?ÿ>*~ o?'( 5?i|OO7>x2OcSCK@)o;^~4|QO_ E"YKb4B~-;3= f_߀~&H?joڧw_h 3|S~6|^mz0]^K2֛^#<|5e/ |>:'Cஉ?g¿ك~ >0~4>+|^QW;\|OjsI:. FuGU?4o^C +s&.ZO? cN] mcNO?OO#¯/.)|4wϦx?ŏW_4x?gO'?;~|VoW{~ ᧿g >3x+hо#=i?W?A_>'Z˨xa m + ߌ~oc_v׆j%ˣxWk~jτwW?χO|?l:w¸<7??\Yi.|}/|3߳-_^ȿ|u/5>οm>0Y~˾ix'pwoƣ/~QO4 \s' K@%o=}D?wX ?xKU ~o)Zo|??bG( ( ( (?/&o> Ym;~7uo^i>mR~W|UuhZuΩ}mFi eF🃼=z[hѵM^pl_Ξ14<]u>|[9eSƟ|M_^{}/V LJ -FGuV5m;ŚuΩx,Աx~*^ڏU;XchZ5} ~,¾=7 >#u@>@nߏ>|%~>![|RkG~OCwş2 |MχRk67÷~Fӿ ]@'oxow,(<#g~~@-ƅ7/^ާ4|Qu7= şxc g}oϏc;xڎ|V^!7uAexW<{g'aQ׾9@i=΁/t kYޅ#25?8 Ǿ=&ж K7yꚾ[C7#E?}@P@|PKS1xJgۃ'XUm3ǿ׿~j /|8<#^$Yx'△ſ ( ( ( ( (  ;(iـ~οh(e߲^?n_}KN⏊wLG%ڇ%>"/|G/4AˠhZWj?g-G $)Gc:x-i/ ѭ~ ];Ś?nǞM|(-Կ>~̿ xOcq6?g~_>.@wŝw7Z~'\/⿇5Z*tH;@|[)?7O]~+ZW?ي| 1O"iS[ϊ?|c}_$[?g+_/;ǿF| ǟ\g: xW]~ |7ao|>&|q>.qgǭoY_i'~9\zώ~%hP@K?ώ>~ki/fM◃|;"4h۾fWkgq cL;_*x>@c3Sb?0ۯ?A|'ۿ~Z/ۊ K.KcO }ώ>о)|/i5o;"5?^.𞥫WZ5 kf]yWW0FP@?_gO5x/ͩZx;v O'G/_~5]?>/xR>U|3Ş^#RpO|!{k뿴Ǐijx2Qφ͇» KJ.t>Z5/)_~4#x( ( ( ( ( ( C<oI?f? jt{NWK:sum<x,ѥuxB|=[Y]P@P@P@P@ |Rw].ŭc3X 8Zdž4}?_xo^kqxHM?_| 4_S?>bO#%$_ ^o.a㿉 e%"-^x~">0|$@@|X:88 @O'U']m|:ŏxC,g/Xf7|cG|I< o~ ] ( ( ( ( (?Oo K_= |`$//٧]Sw,V _'Ni4}3O-|++h#;i;?fٓ_; ,Nj? E=?F~"|ww@𯆵?]>t{/Q 7$i ~G#hJ~߲AMxWZRt#_7'|; Oe~iw+VW e _b´OH)m?+ 쬿Ey?ggtxk]t ( (<Z^)Y@|,ۺ5DHſ!xI5OYb;{?G|,>|)Z=5]{WxsDc[!~Ox|C?h( Hx~?cπ?_?|_Xѿh>|G @xggď|y?| #|Oτ, ~=o@O@P@P@P@P@P@|Y4?cg_4P@xOWq_ď|?۟ou/udIxgŽ0X|M;kY>"$g |LWI~$6ֵm+^lAgĺK{| >!A ;ϊvh|?"ύ}ÿ~_ٯX <[ oF~.gϊv_ <;Z!( ( ( ( ( (>N,`Ú ( (??K s''W%KW^2+$Yw/F: ZUᯆ?<|;GfP@P@?৅~9xVBuxWĞ~|S5֝L53Kӵ]'EZմ{Ik4?'{/m~!8UxP|+7-u/ KtK}sU׵{?4O5 G w?> ( ( ( ( (  ;(iـ~οh( ( Y? ¾&/5x'ƞ|'xFӼG_xWzuΏ xŵ擯x^o/4gF-.SNyb`?F|vm'x/xDu"1_)j^ZG~a|ҿ.h>5W㗅u wB|I_]x_σ_4;Jյt]'U״?Y:]\޿?xψ ( (< G¿Gb"}'Ouj O2e??߈mw#'E|1.ǚgxt/ >;Og/>( ( ( ( ( ($ f:9 ( (>`/W?>7?"_|;犢𮝨>-xkW0xWkּ_i:>x?>5PV+HW^'o Z:_?ភZǿ櫯j~h k~#?/9E}?@P@ z_Qп>-|;4}OGƱY~0;a*OxPko//]z7Co{KX gO uJ>|`ߊ_MhxtxG]Iٚkh.^=`@P@P@P@P@P@'_M?0Y}@P@P@Pko𭇃5|=t 3u ~*m Kӵ]/>GN5Y|{Ꮘ|'3ǂWjyߊ^;g k5H<[8?g}3GPh~v?G?kxKGռI׆ ( ].٨xd_oо[_wS]ō?RlM߇ X/3OEQ~׿?@ ( ( ( ( ($ f:9 ( ( ()|-'Ək $_xKٓA4cƟo >,֡< Cï O>.<='O h>":ޓ|o'EH?AϟP@PY[O? >%Q|-=cD<;xOχu 'O}BOBtbj5 +ؠ?eߊ^;>%~Hh/!4{[_?\ѿew>O AI|z֗' &[ƿ~~4~~? >`7/Ow9 _p| ࿆ghD oPӼim4-nt/xxdnًSïx^oÞ?u߂ O/9%O=OsZ|dxloE|AO0k& mG^*toǯ B@3ŷ{_·Z6:VُG퓩~`_~Yz~ş3xz+F,7׏<[B|9@|wxC<Ġ~ kb~|A7c/=oĞ~#x7_?M{ǟgOi.ǟ -#$_sOg 㿀:;~ ~i;߂*Z_G|DO?[?~L$ {A_-o  xt{fƞ4_W~ V ,xQ| [᷂OJoɫG~*"_ߵ)/kalT~g"W,OhW?៿?x6iO  K+G4*lv4/JV 3H᡿dP|Y4?cg_4P@P@P@G5߆t/H<%mVcO7]xkP[On_ïþ97?͈~wdS8a}t  jߵ?­/A? >61k? O4|w> (> ' xk/)gF|gUſvn; gR~w`!:|7Oey>x&;{Xm{*Gះl^u_: ~-~)ƿ~ݟO߳Ox߰ G?^,<|'^a 57ō+_,/mu/jZmpu"xw^>?x<{Jm.|S{ٿfM/kzg|WwFOO?a|ymn- Kߊ^'OtMw]G]zfǾ4ooPx> <1;|k~aψ_~|O ^WއZ;6_duůi.~w_' [dm3/T~"|,5HG~|E6~Wŭw}?]u}cþw|t?|OJ>;xe 5| oþ w|ghO~A@??}_Mƫw[g=Zo+/ڷ-_|'i1?=浦xKI)V?5wWŲ~^ix_a|J?1uG7x#5:g-?KkR_<; 1 ,J ( ( ( )⯈O?5?Cj_OOj:wbVX^|%&kzf!{j2>)3O/w>5W㗅u wB|I_]x_σ_4;Jյt]'U״?Y:]\޿?xψ ( (?eO?h\ŕ߶~ګ>)~Z<^-?^;g=+*~86_&L׵  ( ( ^MwQ{O2F/xƟ? xB?dIou?xÞ3YGPſ@e_x+^'_j?ºi>.x}txgXƏx| @m,/ѼwZ/;(  ;(iـ~οh( (?jz8hi_R^ :%< j|M]|YoGi1cƕbOmgM*5_X:|idVY3S37ï y_)AO2' {ISO/6~_5ics]W!||džxG> 'z7g|Lƣ[.Wltw[ƅ9?)xOxw,:B5xSо)C_^ ]}@P@|@'|Sп_K_ؾ <ĺoH|G۟^%'xKK;KPmMGZg-P@?h?[^ WO_x#Fu|jiˣԿ E⟈ +?1~_dOD$׈}?xWǾ׎ o>4xzΝ? ¾#ӭx^!o4{yihΗyujuյ+tP@P@P@y/Mwĝ  x2{h5=cƕxXM?xGŞ4<[~6u:w~| /6b&b^v߉?|v;{Ɠz^Y>}LwJ⟄<koxk/j@wQe~P@PPW0xg/?~%ֿxg`!F1@Ƌm*WK'վ ?4_o|&/'?w/o[?' 9? |t?5~4 '~#?˜WI~6_[|- `fڟnE׋?h߀A?/)Ə'_ۯԿlW~~.Ak|GxSwYkMg!7Ot` gO||77/3퇈&W7CxZ}/ŮiG>V=_S:P@P@~_Z%2D4y@X /OƍIu_ڗuFo7>xF77[> ( ( (>&O[:W4m՗Lu_SG᫟^ k+k+?>):ƹ~5˾:4xzΝ? ¾#ӭx^!o4{yihΗyujuյ+tP@?C?j+$_ *51Ə|,.-?a C7|W>|r7;Ş~_> k>!ź>UҾtK{.X&w3$~Q~~|c!ex Ig|xP/^4Ӵ-F{.Ş#X77ŕ_)?cS`Y_Ҟ77ŕ_)'ƿMh ?gG"gCFN|#n (?jƏV)? > S ~:xGOW>|MſZ_ ;g|Akf?O,^_?x?OJS|vQ'>e<C?i Úrx;e૭GZ择]{P@P@P@P Ÿ|As0x~MKg<+B|[Nl|Yo^:ѮSO~*|[mg? > ۗ_my7j <+r[%~xz_W*> Nu+_ |[_Y_ *P@}4O]3¿QW~'u[I_^񏃿x>}@P@P@P@P@'_M?0Y}@o'bsiP@P@P@Pп<+J|:xP%;:Zo~*x/Z/u _kVIׯ.4kSCt}F;iF%5|C[B?k=o_ǽC\:櫬>TCu|i}—3Ҵ/jP@|S,aiث% cğc''|2;Bu_j^#';-%|[_E|[$~GODmp$3wW1;/Vм#ROⷓ|yմ8Wo׈>%Rw7i)׎>1 @?79Y4( ( ( (?e~W> ~4- ~gګh~aÿ*_~&|N4P@|-wgJhw?s?~ П|Gb×RɒHxKƾB_x֏ƸW> ( ( ( (?/&o=7'_6_C>>oxO4|67t|5=5sK GIӵK/xV-vࣞ3%]n/mv~":Sԟ|%#%࿎Z__M:>@t~)|t?>&KX'A5?%> SD R_/hث~G|USO< C>j~KfKFNk-+QH&g~>|< a +?4/Ŗu T^XxGu&zNioz泧[1e6@P@P@P@PIEO7us@@~>_X +o|d߈Sïw.} +GH#=z%֧km~@4c'K7[KWïhohC~"q#  |P\𗅾5h_u᥿563o'bsißJof֊P [O:'W ?3WM9$wPuφ&xL_|;?'2?Ğ}쭡ᯇ~!~~𧋼O?tx@?cOڏCmcs Ax[+¾|{[ kYS5έ.|Gs|q[[xNhHP@P@PQ?~_4O ?oD~ ?b_*]Wٗ'zv'x[|}@P@|OYmٓ%xX~?.+"e;z]WF;N,`Ú*7?~3RqK3>kh/^ o/@O{о9sSþ'a{i|3۟ \J&RO~^3A$'?AWqƿ~^ _~<Xh?ϏMIjWHniFj~kQ~W @)GOZ+ @ ~? ,|}Sڗ<=qYl%|E |E~4E|YB|(WKe? =< ~2Ѿ-;ᖓ7 |Y'X|EGoĽ+Z 79Y47iEX-ߵn5} d?E|eߴ?xL~ȟ|I|/ៈ}jz| ^|C>Ei?~-x~5ڟZߊ_>82?FOƿ:SKSRB5?&7u_^^jγ^]j:us}}s=o@PW @@P@P@P@C6|_P؃~7_A(xO>g_Þ*🊼9Z?|5ok>/hZ旬ڥ66W\,J= eI,?2?g_xؿ_#u@= eI,?2?g_x6msX дguMg 4s [xN[x7_|six~&+Z/%$6ट?|G>|'yk1֍||N >=.]}GBӼi;Rz<ilu7i&Р~x GMcz WTtF %@>,%&G{Yd~ο,%&G{Yd~ο,%&G< BUN4?~O0~ͿL^= /~(3~#ONM EbӴ~ xZwP@P@P@P@P@P@P@~p~SOj~> ? We[ԯ<N7n49~>;Sh>$h~|># ¾=𯆼u_xƞ ox;>tWŞmx{sy״MSFt˭;TӮg)X ( ( ( ( ( ( ( ( ( (>`e yw]$|Cp|(x/ |zկ'Ǿ]'Ś>'|%.~>|W> K_h07O^G i|y 7_OoJ~ |=o?4ji~o?>"dw/ڈ鿶=~P@P@P@P@P@P@P@P@P@P@P@<'_W׆?Oτchw+ NCx{XuM旬ڥ֝iW6WO,LYG^; xFgDY|Gxzهsy ׵{?Ÿ9BQhO_OP@P@P@P@P@P@P@P@P@P@P? WǾ7|u>4?;Ś6? ¾#Ӯtk-4{yy:6iuju͕xO |eECω.|Agu? m<'o>{9^:mS%sOX'|+? Ko&WcxO|l?kߵDŽe7]_n]kt?NZ?h .W]_]KU 5Om߄A|Ck?)Z5߉|1➣|<8e?Lj62/o㿃Uxn+e3oٻ~5փqo<+.`uï!g~0~V?㷊 g;š7?vW? '|/|u$M ?x?_W?c?~ΞOxE$uS+5x > /O:Mg״?o& 6.idi3QgLy8?bo6߳7>'x 3~X|cSws '}Q/.?6y%?fk @Z|3g y-0~Qvɿ'sR>b~ϟߊ~(|x_tϦ|b+_m_xǾ#⟴~vZg1"S/?hXxJكƿ~l|+Ÿ 65]{W^[ֺ6tvjKy0P@P@P@P@P@P@P@P@!\FW7_,_n55']cc/<# ú?|zawkM@] %MGWíCYS4OP|?ƧƭK<ޱ-3Xi6|e/i?6?nw+8O;1_[΍hZw)Z?&߆>>x~ ~_]o/?hhV~5={ p`x~0xW^ߌ~WKu]cþُ-_gź!x?m.O|1}[_?jڻ[>߉|k?O$֝Շ7<{:x3I>,Vt fcu<|<+ٟG$|/gJ>c@~?w%^#w▝>('ïZ]߲wԿ. #ifndef _MALLOC_UTILS_H_ #define _MALLOC_UTILS_H_ #include void *Malloc(size_t size); void *Calloc(size_t num, size_t size); void *Realloc(void *ptr, size_t size); void Free(void *ptr); #endif getdp-2.4.2-source/Common/GetDPConfig.h.in000644 001750 001750 00000001354 12116424203 021675 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _GETDP_CONFIG_H_ #define _GETDP_CONFIG_H_ #cmakedefine HAVE_ARPACK #cmakedefine HAVE_GMSH #cmakedefine HAVE_GSL #cmakedefine HAVE_LEGACY #cmakedefine HAVE_MPI #cmakedefine HAVE_NO_FORTRAN #cmakedefine HAVE_NO_INTPTR_T #cmakedefine HAVE_NO_SOCKLEN_T #cmakedefine HAVE_NO_STDINT_H #cmakedefine HAVE_NO_VSNPRINTF #cmakedefine HAVE_NR #cmakedefine HAVE_NX #cmakedefine HAVE_PETSC #cmakedefine HAVE_SLEPC #cmakedefine HAVE_SPARSKIT #cmakedefine HAVE_ZITSOL #define GETDP_CONFIG_OPTIONS "${GETDP_CONFIG_OPTIONS}" ${GETDP_CONFIG_PRAGMAS} #endif getdp-2.4.2-source/Common/TreeUtils.cpp000644 001750 001750 00000004712 12166744452 021473 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to . // // Contributor(s): // Marc Ume // #include #include #include "GetDPConfig.h" #include "MallocUtils.h" #include "TreeUtils.h" #if !defined(HAVE_GMSH) Tree_T *Tree_Create(int size, int (*fcmp) (const void *a, const void *b)) { Tree_T *tree = (Tree_T*)Malloc(sizeof(Tree_T)); tree->size = size; tree->root = avl_init_table(fcmp); return tree; } void Tree_Delete(Tree_T * tree) { if(!tree) return; avl_free_table(tree->root, Free, 0); Free(tree); } void *Tree_Add(Tree_T * tree, void *data) { if(!tree) return 0; void *ptr = Malloc(tree->size); memcpy(ptr, data, tree->size); avl_insert(tree->root, ptr, ptr); return ptr; } int Tree_Nbr(Tree_T * tree) { if(!tree) return 0; return avl_count(tree->root); } int Tree_Insert(Tree_T * tree, void *data) { if(!Tree_Search(tree, data)){ Tree_Add(tree, data); return 1; } return 0; } int Tree_Search(Tree_T * tree, void *data) { if(!tree) return 0; void *ptr; return avl_lookup(tree->root, data, &ptr); } int Tree_Query(Tree_T * tree, void *data) { if(!tree) return 0; void *ptr; if(!avl_lookup(tree->root, data, &ptr)) return 0; memcpy(data, ptr, tree->size); return 1; } void *Tree_PQuery(Tree_T * tree, void *data) { if(!tree) return 0; void *ptr; if(!avl_lookup(tree->root, data, &ptr)) return 0; return ptr; } int Tree_Suppress(Tree_T * tree, void *data) { if(!tree) return 0; void *ptr = data; if(!avl_delete(tree->root, &ptr, &ptr)) return 0; Free(ptr); return 1; } int Tree_Size(Tree_T * tree) { if(!tree) return 0; return tree->size; } void Tree_Action(Tree_T *tree, void (*action) (void *data, void *dummy)) { if(!tree) return; avl_foreach(tree->root, action, AVL_FORWARD); } static List_T *pListTransfer; void TransferList(void *a, void *b) { List_Add(pListTransfer, a); } List_T *Tree2List(Tree_T * pTree) { int Nb; Nb = Tree_Nbr(pTree); if(Nb == 0) Nb = 1; pListTransfer = List_Create(Nb, Nb, Tree_Size(pTree)); Tree_Action(pTree, TransferList); return pListTransfer; } #endif int Tree_Replace(Tree_T *tree, void *data) { void *ptr; int state; state = avl_lookup(tree->root, data, &ptr); if (state == 0) { Tree_Add(tree,data); return 0; } else { memcpy(ptr, data, tree->size); return 1; } } getdp-2.4.2-source/Common/avl.h000644 001750 001750 00000007412 12116424203 017762 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _AVL_H_ #define _AVL_H_ /* * avl package * * Copyright (c) 1988-1993, The Regents of the University of California. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies and that both that * copyright notice and this permission notice appear in supporting * documentation, and that the name of the University of California not * be used in advertising or publicity pertaining to distribution of * the software without specific, written prior permission. The University * of California makes no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. * * THE UNIVERSITY OF CALIFORNIA DISCLAIMS ALL WARRANTIES WITH REGARD TO * THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND * FITNESS, IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE FOR * ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER * RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF * CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN * CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. */ // Modified for Gmsh (C++, 64 bits, ...) typedef struct avl_node_struct avl_node; struct avl_node_struct { avl_node *left, *right; void *key; void *value; int height; }; typedef struct avl_tree_struct avl_tree; struct avl_tree_struct { avl_node *root; int (*compar)(const void *key1, const void *key2); int num_entries; int modified; }; typedef struct avl_generator_struct avl_generator; struct avl_generator_struct { avl_tree *tree; avl_node **nodelist; int count; }; #define AVL_FORWARD 0 #define AVL_BACKWARD 1 #define AVL_MOST_LEFT 0 #define AVL_MOST_RIGHT 1 #define avl_is_member(tree, key) avl_lookup(tree, key, (void **) 0) #define NIL(type) (type *) 0 #define avl_foreach_item(table, gen, dir, key_p, value_p) \ for(gen = avl_init_gen(table, dir); \ avl_gen(gen, key_p, value_p) || (avl_free_gen(gen),0);) inline void avl_walk_forward(avl_node *node, void (*func)(void *key, void *value)) { if (node != NIL(avl_node)) { avl_walk_forward(node->left, func); (*func)(node->key, node->value); avl_walk_forward(node->right, func); } } inline void avl_walk_backward(avl_node *node, void (*func)(void *key, void *value)) { if (node != NIL(avl_node)) { avl_walk_backward(node->right, func); (*func)(node->key, node->value); avl_walk_backward(node->left, func); } } inline void avl_foreach(avl_tree *tree, void (*func)(void *key, void *value), int direction) { if (direction == AVL_FORWARD) { avl_walk_forward(tree->root, func); } else { avl_walk_backward(tree->root, func); } } avl_tree *avl_init_table(int (*compar)(const void *key1, const void *key2)); int avl_lookup(avl_tree *tree, void *key, void **value_p); int avl_insert(avl_tree *tree, void *key, void *value); int avl_delete(avl_tree *tree, void **key_p, void **value_p); void avl_free_table(avl_tree *tree, void (*key_free)(void *key), void (*value_free)(void *value)); int avl_count(avl_tree *tree); int avl_check_tree(avl_tree *tree); int avl_extremum(avl_tree *tree, int side, void **value_p); avl_generator *avl_init_gen(avl_tree *tree, int dir); int avl_gen(avl_generator *gen, void **key_p, void **value_p); void avl_free_gen(avl_generator *gen); int avl_numcmp(const void *x, const void*y); #endif getdp-2.4.2-source/Common/Message.h000644 001750 001750 00000011161 12166744452 020600 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _MESSAGE_H_ #define _MESSAGE_H_ #include #include #include #include class GmshClient; namespace onelab{ class client; } struct Constant; struct Expression; struct Group; // a class to manage messages class Message { private: // current cpu number and total number of cpus static int _commRank, _commSize, _isCommWorld; // error count static int _warningCount, _errorCount; // last PETSc error code static int _lastPETScError; // should we exit on error? static bool _exitOnError, _operatingInTimeLoopAdaptive; // verbosity level (0: silent except fatal errors, 1: +errors, 2: +warnings, // 3: +direct+important info, 4: +info+progress, 5: normal, 6: +matinfo, 10: // elementary matrices, 99: debug) static int _verbosity; // step (in %) of the progress meter and current progress % static int _progressMeterStep, _progressMeterCurrent; // timers static std::map _timers; // communication with Gmsh static GmshClient *_client; // communication with onelab server static onelab::client *_onelabClient; public: Message() {} static void Initialize(int argc, char **argv); static void Finalize(); static void Exit(int level); static int GetCommRank(){ return _commRank; } static int GetCommSize(){ return _commSize; } static void SetCommRank(int val){ _commRank = val; } static void SetCommSize(int val){ _commSize = val; } static void Barrier(); static int GetIsCommWorld(){return _isCommWorld; } static void SetIsCommWorld(int val){ _isCommWorld = val; } static int GetNumThreads(); static int GetMaxThreads(); static int GetThreadNum(); static void SetVerbosity(int val){ _verbosity = val; } static int GetVerbosity(){ return _verbosity; } static void Fatal(const char *fmt, ...); static void Error(const char *fmt, ...); static void ResetErrorCounter(){ _errorCount = 0; } static int GetErrorCount(){ return _errorCount; } static void SetExitOnError(bool val){ _exitOnError = val; } static void SetOperatingInTimeLoopAdaptive(bool val){ _operatingInTimeLoopAdaptive = val; } static bool GetOperatingInTimeLoopAdaptive(){ return _operatingInTimeLoopAdaptive; } static void Warning(const char *fmt, ...); static void Info(const char *fmt, ...); static void Info(int level, const char *fmt, ...); static void Direct(const char *fmt, ...); static void Direct(int level, const char *fmt, ...); static void Check(const char *fmt, ...); static void Debug(const char *fmt, ...); static void Cpu(const char *fmt, ...); static void Cpu(int level, const char *fmt, ...); static void ProgressMeter(int n, int N, const char *fmt, ...); static void ProgressMeter(int n, int N){ ProgressMeter(n, N, ""); } static void SetProgressMeterStep(int step){ _progressMeterStep = step; } static int GetProgressMeterStep(){ return _progressMeterStep; } static void ResetProgressMeter(){ if(!_commRank) _progressMeterCurrent = 0; } static void PrintErrorCounter(const char *title); static void SetLastPETScError(int ierr){ _lastPETScError = ierr; } static int GetLastPETScError(){ return _lastPETScError; } static double &Timer(std::string str){ return _timers[str]; } static void PrintTimers(); static void InitializeSocket(std::string sockname); static void FinalizeSocket(); static bool UseSocket(){ return _client ? true : false; } static void SendMergeFileRequest(const std::string &filename); static void SendOptionOnSocket(int num, std::string option); static void TestSocket(); static void InitializeOnelab(std::string name, std::string sockname); static void FinalizeOnelab(); static bool UseOnelab(){ return _onelabClient ? true : false; } static std::string GetOnelabClientName(); static void GetOnelabString(std::string name, char **val); static std::string GetOnelabAction(); static void AddOnelabNumberChoice(std::string name, double val, const char *color=0); static void AddOnelabStringChoice(std::string name, std::string kind, std::string choice); typedef std::map > fmap; typedef std::map > cmap; static void ExchangeOnelabParameter(Constant *c, fmap &fopt, cmap &copt); static void ExchangeOnelabParameter(Group *p, fmap &fopt, cmap &copt); static void ExchangeOnelabParameter(Expression *p, fmap &fopt, cmap &copt); static void UndefineOnelabParameter(const std::string &name); }; #endif getdp-2.4.2-source/Common/MallocUtils.cpp000644 001750 001750 00000001657 12116424203 021770 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include "MallocUtils.h" #include "Message.h" void *Malloc(size_t size) { void *ptr; if(!size) return (NULL); ptr = malloc(size); if(ptr == NULL) Message::Fatal("Out of memory (buy some more RAM!)"); return (ptr); } void *Calloc(size_t num, size_t size) { void *ptr; if(!size) return (NULL); ptr = calloc(num, size); if(ptr == NULL) Message::Fatal("Out of memory (buy some more RAM!)"); return (ptr); } void *Realloc(void *ptr, size_t size) { if(!size) return (NULL); ptr = realloc(ptr, size); if(ptr == NULL) Message::Fatal("Out of memory (buy some more RAM!)"); return (ptr); } void Free(void *ptr) { if(ptr == NULL) return; free(ptr); } getdp-2.4.2-source/Common/GmshSocket.h000644 001750 001750 00000033243 12210577674 021270 0ustar00geuzainegeuzaine000000 000000 // Gmsh - Copyright (C) 1997-2013 C. Geuzaine, J.-F. Remacle // // Permission is hereby granted, free of charge, to any person // obtaining a copy of this software and associated documentation // files (the "Software"), to deal in the Software without // restriction, including without limitation the rights to use, copy, // modify, merge, publish, distribute, and/or sell copies of the // Software, and to permit persons to whom the Software is furnished // to do so, provided that the above copyright notice(s) and this // permission notice appear in all copies of the Software and that // both the above copyright notice(s) and this permission notice // appear in supporting documentation. // // THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, // EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF // MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND // NONINFRINGEMENT OF THIRD PARTY RIGHTS. IN NO EVENT SHALL THE // COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS NOTICE BE LIABLE FOR // ANY CLAIM, OR ANY SPECIAL INDIRECT OR CONSEQUENTIAL DAMAGES, OR ANY // DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, // WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS // ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE // OF THIS SOFTWARE. // // Please report all bugs and problems to the public mailing list // . #ifndef _GMSH_SOCKET_H_ #define _GMSH_SOCKET_H_ #include "GetDPConfig.h" #include #include #include #include #if defined(_AIX) #include #endif #if !defined(WIN32) || defined(__CYGWIN__) #include #include #include #include #include #include #include #include #if defined(HAVE_NO_SOCKLEN_T) typedef int socklen_t; #endif #else #include #include typedef int socklen_t; #endif class GmshSocket{ public: // types of messages that can be exchanged (never use values greater // that 65535: if we receive a type > 65535 we assume that we // receive data from a machine with a different byte ordering, and // we swap the bytes in the payload) enum MessageType{ GMSH_START = 1, GMSH_STOP = 2, GMSH_INFO = 10, GMSH_WARNING = 11, GMSH_ERROR = 12, GMSH_PROGRESS = 13, GMSH_MERGE_FILE = 20, GMSH_PARSE_STRING = 21, GMSH_VERTEX_ARRAY = 22, GMSH_PARAMETER = 23, GMSH_PARAMETER_QUERY = 24, GMSH_PARAMETER_QUERY_ALL = 25, GMSH_PARAMETER_QUERY_END = 26, GMSH_CONNECT = 27, GMSH_OLPARSE = 28, GMSH_PARAMETER_NOT_FOUND = 29, GMSH_SPEED_TEST = 30, GMSH_PARAMETER_CLEAR = 31, GMSH_PARAMETER_UPDATE = 32, GMSH_OPTION_1 = 100, GMSH_OPTION_2 = 101, GMSH_OPTION_3 = 102, GMSH_OPTION_4 = 103, GMSH_OPTION_5 = 104}; protected: // the socket descriptor int _sock; // the socket name std::string _sockname; // send some data over the socket int _SendData(const void *buffer, int bytes) { const char *buf = (const char *)buffer; int sofar = 0; int remaining = bytes; do { int len = send(_sock, buf + sofar, remaining, 0); if(len < 0) return -1; // error sofar += len; remaining -= len; } while(remaining > 0); return bytes; } // receive some data over the socket int _ReceiveData(void *buffer, int bytes) { char *buf = (char *)buffer; int sofar = 0; int remaining = bytes; do { int len = recv(_sock, buf + sofar, remaining, 0); if(len == 0) break; // we're done! if(len < 0) return -1; // error sofar += len; remaining -= len; } while(remaining > 0); return bytes; } // utility function to swap bytes in an array void _SwapBytes(char *array, int size, int n) { char *x = new char[size]; for(int i = 0; i < n; i++) { char *a = &array[i * size]; memcpy(x, a, size); for(int c = 0; c < size; c++) a[size - 1 - c] = x[c]; } delete [] x; } // sleep for some milliseconds void _Sleep(int ms) { #if !defined(WIN32) || defined(__CYGWIN__) usleep(1000 * ms); #else Sleep(ms); #endif } public: GmshSocket() : _sock(0) { #if defined(WIN32) && !defined(__CYGWIN__) WSADATA wsaData; WSAStartup(MAKEWORD(2, 2), &wsaData); #endif } ~GmshSocket() { #if defined(WIN32) && !defined(__CYGWIN__) WSACleanup(); #endif } // Wait for some data to read on the socket (if seconds and microseconds == 0 // we check for available data and return immediately, i.e., we do // polling). Returns 1 when data is available, 0 when nothing happened before // the time delay, -1 on error. int Select(int seconds, int microseconds, int socket=-1) { int s = (socket < 0) ? _sock : socket; struct timeval tv; tv.tv_sec = seconds; tv.tv_usec = microseconds; fd_set rfds; FD_ZERO(&rfds); FD_SET(s, &rfds); // select checks all IO descriptors between 0 and its first arg, minus 1; // hence the +1 below return select(s + 1, &rfds, NULL, NULL, &tv); } void SendMessage(int type, int length, const void *msg) { // send header (type + length) _SendData(&type, sizeof(int)); _SendData(&length, sizeof(int)); // send body _SendData(msg, length); } void SendString(int type, const char *str) { SendMessage(type, strlen(str), str); } void Info(const char *str){ SendString(GMSH_INFO, str); } void Warning(const char *str){ SendString(GMSH_WARNING, str); } void Error(const char *str){ SendString(GMSH_ERROR, str); } void Progress(const char *str){ SendString(GMSH_PROGRESS, str); } void MergeFile(const char *str){ SendString(GMSH_MERGE_FILE, str); } void ParseString(const char *str){ SendString(GMSH_PARSE_STRING, str); } void SpeedTest(const char *str){ SendString(GMSH_SPEED_TEST, str); } void Option(int num, const char *str) { if(num < 1) num = 1; if(num > 5) num = 5; SendString(GMSH_OPTION_1 + num - 1, str); } int ReceiveHeader(int *type, int *len, int *swap) { *swap = 0; if(_ReceiveData(type, sizeof(int)) > 0){ if(*type > 65535){ // the data comes from a machine with different endianness and // we must swap the bytes *swap = 1; _SwapBytes((char*)type, sizeof(int), 1); } if(_ReceiveData(len, sizeof(int)) > 0){ if(*swap) _SwapBytes((char*)len, sizeof(int), 1); return 1; } } return 0; } int ReceiveMessage(int len, void *buffer) { if(_ReceiveData(buffer, len) == len) return 1; return 0; } // str should be allocated with size (len+1) int ReceiveString(int len, char *str) { if(_ReceiveData(str, len) == len) { str[len] = '\0'; return 1; } return 0; } void CloseSocket(int s) { #if !defined(WIN32) || defined(__CYGWIN__) close(s); #else closesocket(s); #endif } void ShutdownSocket(int s) { #if !defined(WIN32) || defined(__CYGWIN__) shutdown(s, SHUT_RDWR); #endif } }; class GmshClient : public GmshSocket { public: GmshClient() : GmshSocket() {} ~GmshClient(){} int Connect(const char *sockname) { if(strstr(sockname, "/") || strstr(sockname, "\\") || !strstr(sockname, ":")){ #if !defined(WIN32) || defined(__CYGWIN__) // UNIX socket (testing ":" is not enough with Windows paths) _sock = socket(PF_UNIX, SOCK_STREAM, 0); if(_sock < 0) return -1; // try to connect socket to given name struct sockaddr_un addr_un; memset((char *) &addr_un, 0, sizeof(addr_un)); addr_un.sun_family = AF_UNIX; strcpy(addr_un.sun_path, sockname); for(int tries = 0; tries < 5; tries++) { if(connect(_sock, (struct sockaddr *)&addr_un, sizeof(addr_un)) >= 0) return _sock; _Sleep(100); } #else return -1; // Unix sockets are not available on Windows #endif } else{ // TCP/IP socket _sock = socket(AF_INET, SOCK_STREAM, 0); if(_sock < 0) return -1; // try to connect socket to host:port const char *port = strstr(sockname, ":"); int portno = atoi(port + 1); int remotelen = strlen(sockname) - strlen(port); char remote[256]; if(remotelen > 0) strncpy(remote, sockname, remotelen); remote[remotelen] = '\0'; struct hostent *server; if(!(server = gethostbyname(remote))){ CloseSocket(_sock); return -3; // no such host } struct sockaddr_in addr_in; memset((char *) &addr_in, 0, sizeof(addr_in)); addr_in.sin_family = AF_INET; memcpy((char *)&addr_in.sin_addr.s_addr, (char *)server->h_addr, server->h_length); addr_in.sin_port = htons(portno); for(int tries = 0; tries < 5; tries++) { if(connect(_sock, (struct sockaddr *)&addr_in, sizeof(addr_in)) >= 0){ return _sock; } _Sleep(100); } } CloseSocket(_sock); return -2; // couldn't connect } void Start() { char tmp[256]; #if !defined(WIN32) || defined(__CYGWIN__) sprintf(tmp, "%d", getpid()); #else sprintf(tmp, "%d", _getpid()); #endif SendString(GMSH_START, tmp); } void Stop(){ SendString(GMSH_STOP, "Goodbye!"); } void Disconnect(){ CloseSocket(_sock); } }; class GmshServer : public GmshSocket{ private: int _portno; public: GmshServer() : GmshSocket(), _portno(-1) {} virtual ~GmshServer(){} virtual int NonBlockingSystemCall(const char *str) = 0; virtual int NonBlockingWait(double waitint, double timeout, int socket=-1) = 0; // start the client by launching "command" (command is supposed to contain // '%s' where the socket name should appear) int Start(const char *command, const char *sockname, double timeout) { if(!sockname) throw "Invalid (null) socket name"; _sockname = sockname; int tmpsock; if(strstr(_sockname.c_str(), "/") || strstr(_sockname.c_str(), "\\") || !strstr(_sockname.c_str(), ":")){ // UNIX socket (testing ":" is not enough with Windows paths) _portno = -1; #if !defined(WIN32) || defined(__CYGWIN__) // delete the file if it already exists unlink(_sockname.c_str()); // create a socket tmpsock = socket(PF_UNIX, SOCK_STREAM, 0); if(tmpsock < 0) throw "Couldn't create socket"; // bind the socket to its name struct sockaddr_un addr_un; memset((char *) &addr_un, 0, sizeof(addr_un)); strcpy(addr_un.sun_path, _sockname.c_str()); addr_un.sun_family = AF_UNIX; if(bind(tmpsock, (struct sockaddr *)&addr_un, sizeof(addr_un)) < 0){ CloseSocket(tmpsock); throw "Couldn't bind socket to name"; } // change permissions on the socket name in case it has to be rm'd later chmod(_sockname.c_str(), 0666); #else throw "Unix sockets not available on Windows"; #endif } else{ // TCP/IP socket: valid names are either explicit ("hostname:12345") // or implicit ("hostname:", "hostname: ", "hostname:0") in which case // the system attributes at random an available port const char *port = strstr(_sockname.c_str(), ":"); _portno = atoi(port + 1); // create a socket tmpsock = socket(AF_INET, SOCK_STREAM, 0); #if !defined(WIN32) || defined(__CYGWIN__) if(tmpsock < 0) #else if(tmpsock == (int)INVALID_SOCKET) #endif throw "Couldn't create socket"; // bind the socket to its name struct sockaddr_in addr_in; memset((char *) &addr_in, 0, sizeof(addr_in)); addr_in.sin_family = AF_INET; addr_in.sin_addr.s_addr = INADDR_ANY; addr_in.sin_port = htons(_portno); // random assign if _portno == 0 if(bind(tmpsock, (struct sockaddr *)&addr_in, sizeof(addr_in)) < 0){ CloseSocket(tmpsock); throw "Couldn't bind socket to name"; } if(!_portno){ // retrieve name if randomly assigned port socklen_t addrlen = sizeof(addr_in); getsockname(tmpsock, (struct sockaddr *)&addr_in, &addrlen); _portno = ntohs(addr_in.sin_port); int pos = _sockname.find(':'); // remove trailing ' ' or '0' char tmp[256]; sprintf(tmp, "%s:%d", _sockname.substr(0, pos).c_str(), _portno); _sockname.assign(tmp); } } if(command && strlen(command)){ char cmd[1024]; sprintf(cmd, command, _sockname.c_str()); NonBlockingSystemCall(cmd); // starts the solver } else{ timeout = 0.; // no command launched: don't set a timeout } // listen on socket (queue up to 20 connections before having // them automatically rejected) if(listen(tmpsock, 20)){ CloseSocket(tmpsock); throw "Socket listen failed"; } // wait until we get data int ret = NonBlockingWait(0.001, timeout, tmpsock); if(ret){ CloseSocket(tmpsock); if(ret == 2){ throw "Socket listening timeout"; } else{ return -1; // stopped listening } } // accept connection request if(_portno < 0){ #if !defined(WIN32) || defined(__CYGWIN__) struct sockaddr_un from_un; socklen_t len = sizeof(from_un); _sock = accept(tmpsock, (struct sockaddr *)&from_un, &len); #endif } else{ struct sockaddr_in from_in; socklen_t len = sizeof(from_in); _sock = accept(tmpsock, (struct sockaddr *)&from_in, &len); } CloseSocket(tmpsock); if(_sock < 0) throw "Socket accept failed"; return _sock; } int Shutdown() { #if !defined(WIN32) || defined(__CYGWIN__) if(_portno < 0) unlink(_sockname.c_str()); #endif ShutdownSocket(_sock); CloseSocket(_sock); return 0; } }; #endif getdp-2.4.2-source/Common/avl.cpp000644 001750 001750 00000030721 12116424203 020314 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // $Id: avl.cpp,v 1.2 2009-09-26 06:44:38 geuzaine Exp $ /* * avl package * * Copyright (c) 1988-1993, The Regents of the University of California. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies and that both that * copyright notice and this permission notice appear in supporting * documentation, and that the name of the University of California not * be used in advertising or publicity pertaining to distribution of * the software without specific, written prior permission. The University * of California makes no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. * * THE UNIVERSITY OF CALIFORNIA DISCLAIMS ALL WARRANTIES WITH REGARD TO * THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND * FITNESS, IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE FOR * ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER * RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF * CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN * CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. */ // Modified for Gmsh (C++, 64 bits, ...) #include "GetDPConfig.h" #if !defined(HAVE_NO_STDINT_H) #include #elif defined(HAVE_NO_INTPTR_T) typedef unsigned long intptr_t; #endif #include #include "avl.h" #include "MallocUtils.h" #define ALLOC(type, number) (type *) Malloc((unsigned) sizeof(type) * number) #define FREE(item) (void) Free(item) #define XRNMAX(a,b) ((a) > (b) ? (a) : (b)) #define HEIGHT(node) (node == NIL(avl_node) ? -1 : (node)->height) #define BALANCE(node) (HEIGHT((node)->right) - HEIGHT((node)->left)) #define compute_height(node) { \ int x=HEIGHT(node->left), y=HEIGHT(node->right); \ (node)->height = XRNMAX(x,y) + 1; \ } #define COMPARE(key, nodekey, compare) \ ((compare == avl_numcmp) ? \ (intptr_t) key - (intptr_t) nodekey : \ (*compare)(key, nodekey)) static void avl_record_gen_forward(avl_node *node, avl_generator *gen); static void avl_record_gen_backward(avl_node *node, avl_generator *gen); static avl_node *find_rightmost(avl_node **node_p); static void do_rebalance(avl_node ***stack_nodep, int stack_n); static void rotate_left(avl_node **node_p); static void rotate_right(avl_node **node_p); static void free_entry(avl_node *node, void (*key_free)(void *key), void (*value_free)(void *value)); static avl_node *new_node(void *key, void *value); static int do_check_tree(avl_node *node, int (*compar)(const void *key1, const void *key2), int *error); avl_tree *avl_init_table(int (*compar)(const void *key1, const void *key2)) { avl_tree *tree; tree = ALLOC(avl_tree, 1); tree->root = NIL(avl_node); tree->compar = compar; tree->num_entries = 0; return tree; } int avl_lookup(avl_tree *tree, void *key, void **value_p) { register avl_node *node; register int (*compare)(const void*, const void *) = tree->compar, diff; node = tree->root; while (node != NIL(avl_node)) { diff = COMPARE(key, node->key, compare); if (diff == 0) { /* got a match, give the user a 'value' only if non-null */ if (value_p != NIL(void *)) *value_p = node->value; return 1; } node = (diff < 0) ? node->left : node->right; } return 0; } int avl_insert(avl_tree *tree, void *key, void *value) { register avl_node **node_p, *node; register int stack_n = 0; register int (*compare)(const void*, const void *) = tree->compar; avl_node **stack_nodep[32]; int diff, status; node_p = &tree->root; /* walk down the tree (saving the path); stop at insertion point */ status = 0; while ((node = *node_p) != NIL(avl_node)) { stack_nodep[stack_n++] = node_p; diff = COMPARE(key, node->key, compare); if (diff == 0) status = 1; node_p = (diff < 0) ? &node->left : &node->right; } /* insert the item and re-balance the tree */ *node_p = new_node(key, value); do_rebalance(stack_nodep, stack_n); tree->num_entries++; tree->modified = 1; return status; } int avl_delete(avl_tree *tree, void **key_p, void **value_p) { register avl_node **node_p, *node, *rightmost; register int stack_n = 0; void *key = *key_p; int (*compare)(const void*, const void*) = tree->compar, diff; avl_node **stack_nodep[32]; node_p = &tree->root; /* Walk down the tree saving the path; return if not found */ while ((node = *node_p) != NIL(avl_node)) { diff = COMPARE(key, node->key, compare); if (diff == 0) goto delete_item; stack_nodep[stack_n++] = node_p; node_p = (diff < 0) ? &node->left : &node->right; } return 0; /* not found */ /* prepare to delete node and replace it with rightmost of left tree */ delete_item: *key_p = node->key; if (value_p != 0) *value_p = node->value; if (node->left == NIL(avl_node)) { *node_p = node->right; } else { rightmost = find_rightmost(&node->left); rightmost->left = node->left; rightmost->right = node->right; rightmost->height = -2; /* mark bogus height for do_rebal */ *node_p = rightmost; stack_nodep[stack_n++] = node_p; } FREE(node); /* work our way back up, re-balancing the tree */ do_rebalance(stack_nodep, stack_n); tree->num_entries--; tree->modified = 1; return 1; } static void avl_record_gen_forward(avl_node *node, avl_generator *gen) { if (node != NIL(avl_node)) { avl_record_gen_forward(node->left, gen); gen->nodelist[gen->count++] = node; avl_record_gen_forward(node->right, gen); } } static void avl_record_gen_backward(avl_node *node, avl_generator *gen) { if (node != NIL(avl_node)) { avl_record_gen_backward(node->right, gen); gen->nodelist[gen->count++] = node; avl_record_gen_backward(node->left, gen); } } avl_generator *avl_init_gen(avl_tree *tree, int dir) { avl_generator *gen; /* what a hack */ gen = ALLOC(avl_generator, 1); gen->tree = tree; gen->nodelist = ALLOC(avl_node *, avl_count(tree)); gen->count = 0; if (dir == AVL_FORWARD) { avl_record_gen_forward(tree->root, gen); } else { avl_record_gen_backward(tree->root, gen); } gen->count = 0; /* catch any attempt to modify the tree while we generate */ tree->modified = 0; return gen; } int avl_gen(avl_generator *gen, void **key_p, void **value_p) { avl_node *node; if (gen->count == gen->tree->num_entries) { return 0; } else { node = gen->nodelist[gen->count++]; if (key_p != NIL(void *)) *key_p = node->key; if (value_p != NIL(void *)) *value_p = node->value; return 1; } } void avl_free_gen(avl_generator *gen) { FREE(gen->nodelist); FREE(gen); } static avl_node *find_rightmost(avl_node **node_p) { register avl_node *node; register int stack_n = 0; avl_node **stack_nodep[32]; node = *node_p; while (node->right != NIL(avl_node)) { stack_nodep[stack_n++] = node_p; node_p = &node->right; node = *node_p; } *node_p = node->left; do_rebalance(stack_nodep, stack_n); return node; } static void do_rebalance(avl_node ***stack_nodep, int stack_n) { register avl_node **node_p, *node; register int hl, hr; int height; /* work our way back up, re-balancing the tree */ while (--stack_n >= 0) { node_p = stack_nodep[stack_n]; node = *node_p; hl = HEIGHT(node->left); /* watch for NIL */ hr = HEIGHT(node->right); /* watch for NIL */ if ((hr - hl) < -1) { rotate_right(node_p); } else if ((hr - hl) > 1) { rotate_left(node_p); } else { height = XRNMAX(hl, hr) + 1; if (height == node->height) break; node->height = height; } } } static void rotate_left(avl_node **node_p) { register avl_node *old_root = *node_p, *new_root, *new_right; if (BALANCE(old_root->right) >= 0) { *node_p = new_root = old_root->right; old_root->right = new_root->left; new_root->left = old_root; } else { new_right = old_root->right; *node_p = new_root = new_right->left; old_root->right = new_root->left; new_right->left = new_root->right; new_root->right = new_right; new_root->left = old_root; compute_height(new_right); } compute_height(old_root); compute_height(new_root); } static void rotate_right(avl_node **node_p) { register avl_node *old_root = *node_p, *new_root, *new_left; if (BALANCE(old_root->left) <= 0) { *node_p = new_root = old_root->left; old_root->left = new_root->right; new_root->right = old_root; } else { new_left = old_root->left; *node_p = new_root = new_left->right; old_root->left = new_root->right; new_left->right = new_root->left; new_root->left = new_left; new_root->right = old_root; compute_height(new_left); } compute_height(old_root); compute_height(new_root); } int avl_extremum(avl_tree *tree, int side, void **value_p) { register avl_node *node; node = tree->root; if (node == NIL(avl_node)) return 0; if (side == AVL_MOST_LEFT) while (node->left != NIL(avl_node)) node = node->left; else while (node->right != NIL(avl_node)) node = node->right; if (value_p != NIL(void *)) { *value_p = node->value; return 1; } return 0; } static void free_entry(avl_node *node, void (*key_free)(void *key), void (*value_free)(void *value)) { if (node != NIL(avl_node)) { free_entry(node->left, key_free, value_free); free_entry(node->right, key_free, value_free); if (key_free != 0) (*key_free)(node->key); if (value_free != 0) (*value_free)(node->value); FREE(node); } } void avl_free_table(avl_tree *tree, void (*key_free)(void *key), void (*value_free)(void *value)) { free_entry(tree->root, key_free, value_free); FREE(tree); } int avl_count(avl_tree *tree) { return tree->num_entries; } static avl_node *new_node(void *key, void *value) { register avl_node *newn; newn = ALLOC(avl_node, 1); newn->key = key; newn->value = value; newn->height = 0; newn->left = newn->right = NIL(avl_node); return newn; } int avl_numcmp(const void *x, const void*y) { return (intptr_t) x - (intptr_t) y; } int avl_check_tree(avl_tree *tree) { int error = 0; (void) do_check_tree(tree->root, tree->compar, &error); return error; } static int do_check_tree(avl_node *node, int (*compar)(const void *key1, const void *key2), int *error) { int l_height, r_height, comp_height, bal; if (node == NIL(avl_node)) { return -1; } r_height = do_check_tree(node->right, compar, error); l_height = do_check_tree(node->left, compar, error); comp_height = XRNMAX(l_height, r_height) + 1; bal = r_height - l_height; if (comp_height != node->height) { (void) printf("Bad height for %p: computed=%d stored=%d\n", (void*)node, comp_height, node->height); ++*error; } if (bal > 1 || bal < -1) { (void) printf("Out of balance at node %p, balance = %d\n", (void*)node, bal); ++*error; } if (node->left != NIL(avl_node) && (*compar)(node->left->key, node->key) > 0) { (void) printf("Bad ordering between %p and %p", (void*)node, (void*)node->left); ++*error; } if (node->right != NIL(avl_node) && (*compar)(node->key, node->right->key) > 0) { (void) printf("Bad ordering between %p and %p", (void*)node, (void*)node->right); ++*error; } return comp_height; } getdp-2.4.2-source/Common/OS.cpp000644 001750 001750 00000014532 12166744452 020075 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // This file contains a bunch of functions that depend on OS-dependent // features and/or system calls // these are available on all OSes #include #include #include #include #include #include #if !defined(WIN32) || defined(__CYGWIN__) #include #include #include #endif #if defined(WIN32) #include #include #include #include #include #endif #include "Message.h" #if defined(WIN32) && !defined(__CYGWIN__) // Unicode utility routines borrowed from FLTK static unsigned utf8decode(const char* p, const char* end, int* len) { static unsigned short cp1252[32] = { 0x20ac, 0x0081, 0x201a, 0x0192, 0x201e, 0x2026, 0x2020, 0x2021, 0x02c6, 0x2030, 0x0160, 0x2039, 0x0152, 0x008d, 0x017d, 0x008f, 0x0090, 0x2018, 0x2019, 0x201c, 0x201d, 0x2022, 0x2013, 0x2014, 0x02dc, 0x2122, 0x0161, 0x203a, 0x0153, 0x009d, 0x017e, 0x0178 }; unsigned char c = *(unsigned char*)p; if (c < 0x80) { if (len) *len = 1; return c; } else if (c < 0xa0) { if (len) *len = 1; return cp1252[c-0x80]; } else if (c < 0xc2) { goto FAIL; } if ( (end && p+1 >= end) || (p[1]&0xc0) != 0x80) goto FAIL; if (c < 0xe0) { if (len) *len = 2; return ((p[0] & 0x1f) << 6) + ((p[1] & 0x3f)); } else if (c == 0xe0) { if (((unsigned char*)p)[1] < 0xa0) goto FAIL; goto UTF8_3; } else if (c < 0xf0) { UTF8_3: if ( (end && p+2 >= end) || (p[2]&0xc0) != 0x80) goto FAIL; if (len) *len = 3; return ((p[0] & 0x0f) << 12) + ((p[1] & 0x3f) << 6) + ((p[2] & 0x3f)); } else if (c == 0xf0) { if (((unsigned char*)p)[1] < 0x90) goto FAIL; goto UTF8_4; } else if (c < 0xf4) { UTF8_4: if ( (end && p+3 >= end) || (p[2]&0xc0) != 0x80 || (p[3]&0xc0) != 0x80) goto FAIL; if (len) *len = 4; return ((p[0] & 0x07) << 18) + ((p[1] & 0x3f) << 12) + ((p[2] & 0x3f) << 6) + ((p[3] & 0x3f)); } else if (c == 0xf4) { if (((unsigned char*)p)[1] > 0x8f) goto FAIL; // after 0x10ffff goto UTF8_4; } else { FAIL: if (len) *len = 1; return c; } } static unsigned utf8toUtf16(const char* src, unsigned srclen, unsigned short* dst, unsigned dstlen) { const char* p = src; const char* e = src+srclen; unsigned count = 0; if (dstlen) for (;;) { if (p >= e) {dst[count] = 0; return count;} if (!(*p & 0x80)) { // ascii dst[count] = *p++; } else { int len; unsigned ucs = utf8decode(p,e,&len); p += len; if (ucs < 0x10000) { dst[count] = ucs; } else { // make a surrogate pair: if (count+2 >= dstlen) {dst[count] = 0; count += 2; break;} dst[count] = (((ucs-0x10000u)>>10)&0x3ff) | 0xd800; dst[++count] = (ucs&0x3ff) | 0xdc00; } } if (++count == dstlen) {dst[count-1] = 0; break;} } // we filled dst, measure the rest: while (p < e) { if (!(*p & 0x80)) p++; else { int len; unsigned ucs = utf8decode(p,e,&len); p += len; if (ucs >= 0x10000) ++count; } ++count; } return count; } static wchar_t *wbuf[2] = {NULL, NULL}; static void setwbuf(int i, const char *f) { // all strings in GetDP are supposed to be UTF8-encoded, which is natively // supported by Mac and Linux. Windows does not support UTF-8, but UTF-16 // (through wchar_t), so we need to convert. if(i != 0 && i != 1) return; size_t l = strlen(f); unsigned wn = utf8toUtf16(f, (unsigned) l, NULL, 0) + 1; wbuf[i] = (wchar_t*)realloc(wbuf[i], sizeof(wchar_t)*wn); wn = utf8toUtf16(f, (unsigned) l, (unsigned short *)wbuf[i], wn); wbuf[i][wn] = 0; } #endif FILE *FOpen(const char *f, const char *mode) { #if defined (WIN32) && !defined(__CYGWIN__) setwbuf(0, f); setwbuf(1, mode); return _wfopen(wbuf[0], wbuf[1]); #else return fopen(f, mode); #endif } void GetResources(double *s, long *mem) { #if !defined(WIN32) || defined(__CYGWIN__) static struct rusage r; getrusage(RUSAGE_SELF, &r); *s = (double)r.ru_utime.tv_sec + 1.e-6 * (double)r.ru_utime.tv_usec; #if defined(__APPLE__) *mem = (long)r.ru_maxrss; #else *mem = (long)(r.ru_maxrss * 1024L); #endif #else FILETIME creation, exit, kernel, user; if(GetProcessTimes(GetCurrentProcess(), &creation, &exit, &kernel, &user)){ *s = 1.e-7 * 4294967296. * (double)user.dwHighDateTime + 1.e-7 * (double)user.dwLowDateTime; } PROCESS_MEMORY_COUNTERS info; GetProcessMemoryInfo(GetCurrentProcess(), &info, sizeof(info)); *mem = (long)info.PeakWorkingSetSize; #endif } void IncreaseStackSize() { #if !defined (WIN32) || defined(__CYGWIN__) static struct rlimit r; getrlimit(RLIMIT_STACK, &r); // Try to get at least 16 MB of stack. Running with too small a stack // can cause crashes in the recursive calls (cf. Cal_Quantity) if(r.rlim_cur < 16 * 1024 * 1024){ Message::Info("Increasing process stack size (%d kB < 16 MB)", r.rlim_cur / 1024); r.rlim_cur = r.rlim_max; setrlimit(RLIMIT_STACK, &r); } #endif } int BlockingSystemCall(const char *command) { #if defined(WIN32) STARTUPINFO suInfo; PROCESS_INFORMATION prInfo; memset(&suInfo, 0, sizeof(suInfo)); suInfo.cb = sizeof(suInfo); Message::Info("Calling '%s'", command); CreateProcess(NULL, (char*)command, NULL, NULL, FALSE, NORMAL_PRIORITY_CLASS, NULL, NULL, &suInfo, &prInfo); // wait until child process exits. WaitForSingleObject(prInfo.hProcess, INFINITE); // close process and thread handles. CloseHandle(prInfo.hProcess); CloseHandle(prInfo.hThread); return 0; #else if(!system(NULL)) { Message::Error("Could not find /bin/sh: aborting system call"); return 1; } Message::Info("Calling '%s'", command); return system(command); #endif } int RemoveFile(const std::string &fileName) { #if defined(WIN32) && !defined(__CYGWIN__) setwbuf(0, fileName.c_str()); return _wunlink(wbuf[0]); #else return unlink(fileName.c_str()); #endif } int CreateDir(const std::string &dirName) { #if defined(WIN32) && !defined(__CYGWIN__) setwbuf(0, dirName.c_str()); if(_wmkdir(wbuf[0])) return 0; #else if(mkdir(dirName.c_str(), 0777)) return 0; #endif return 1; } getdp-2.4.2-source/Common/TreeUtils.h000644 001750 001750 00000001706 12166744452 021140 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _TREE_UTILS_H_ #define _TREE_UTILS_H_ #include "avl.h" #include "ListUtils.h" typedef struct { int size; avl_tree *root; } Tree_T; Tree_T *Tree_Create(int size, int (*fcmp)(const void *a, const void *b)); void Tree_Delete(Tree_T *Tree); void *Tree_Add(Tree_T *tree, void *data); int Tree_Nbr(Tree_T *Tree); int Tree_Insert(Tree_T *Tree, void *data); int Tree_Replace(Tree_T *Tree, void *data); int Tree_Search(Tree_T *Tree, void *data); int Tree_Query(Tree_T *Tree, void *data); void *Tree_PQuery(Tree_T *Tree, void *data); int Tree_Suppress(Tree_T *Tree, void *data); int Tree_Size(Tree_T *tree); void Tree_Action(Tree_T *tree, void (*action) (void *data, void *dummy)); List_T *Tree2List(Tree_T *pTree); #endif getdp-2.4.2-source/Common/GetDPVersion.h.in000644 001750 001750 00000001347 12116424203 022117 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _GETDP_VERSION_H_ #define _GETDP_VERSION_H_ #define GETDP_MAJOR_VERSION ${GETDP_MAJOR_VERSION} #define GETDP_MINOR_VERSION ${GETDP_MINOR_VERSION} #define GETDP_PATCH_VERSION ${GETDP_PATCH_VERSION} #define GETDP_EXTRA_VERSION "${GETDP_EXTRA_VERSION}" #define GETDP_VERSION "${GETDP_VERSION}" #define GETDP_DATE "${GETDP_DATE}" #define GETDP_HOST "${GETDP_HOST}" #define GETDP_PACKAGER "${GETDP_PACKAGER}" #define GETDP_OS "${GETDP_OS}" #define GETDP_SHORT_LICENSE "${GETDP_SHORT_LICENSE}" #endif getdp-2.4.2-source/Common/ListUtils.cpp000644 001750 001750 00000024640 12116424203 021471 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Marc Ume // #include "GetDPConfig.h" #if !defined(HAVE_NO_STDINT_H) #include #elif defined(HAVE_NO_INTPTR_T) typedef unsigned long intptr_t; #endif #include #include #include #include #include #include "MallocUtils.h" #include "ListUtils.h" #include "TreeUtils.h" #include "Message.h" #if !defined(HAVE_GMSH) int fcmp_int(const void *a, const void *b) { return (*(int *)a - *(int *)b); } int fcmp_absint(const void *a, const void *b) { return (abs(*(int *)a) - abs(*(int *)b)); } int fcmp_double(const void *a, const void *b) { double cmp; cmp = *(double *)a - *(double *)b; if(cmp > 1.e-16) return 1; else if(cmp < -1.e-16) return -1; else return 0; } List_T *List_Create(int n, int incr, int size) { List_T *liste; if(n <= 0) n = 1; if(incr <= 0) incr = 1; liste = (List_T *) Malloc(sizeof(List_T)); liste->nmax = 0; liste->incr = incr; liste->size = size; liste->n = 0; liste->isorder = 0; liste->array = NULL; List_Realloc(liste, n); return (liste); } void List_Delete(List_T * liste) { if(!liste) return; Free(liste->array); Free(liste); } void List_Realloc(List_T * liste, int n) { if(n <= 0) return; if(liste->array == NULL) { // This does not permit to allocate lists smaller that liste->incr: //liste->nmax = ((n - 1) / liste->incr + 1) * liste->incr; // So this is much better liste->nmax = n; liste->array = (char *)Malloc(liste->nmax * liste->size); } else if(n > liste->nmax) { liste->nmax = ((n - 1) / liste->incr + 1) * liste->incr; liste->array = (char *)Realloc(liste->array, liste->nmax * liste->size); } } void List_Add(List_T * liste, void *data) { liste->n++; List_Realloc(liste, liste->n); liste->isorder = 0; memcpy(&liste->array[(liste->n - 1) * liste->size], data, liste->size); } int List_Nbr(List_T * liste) { return (liste) ? liste->n : 0; } void List_Read(List_T * liste, int index, void *data) { if((index < 0) || (index >= liste->n)) Message::Fatal("Wrong list index (read)"); memcpy(data, &liste->array[index * liste->size], liste->size); } void List_Write(List_T * liste, int index, void *data) { if((index < 0) || (index >= liste->n)) Message::Error("Wrong list index (write)"); else { liste->isorder = 0; memcpy(&liste->array[index * liste->size], data, liste->size); } } void List_Pop(List_T * liste) { if(liste->n > 0) liste->n--; } void *List_Pointer(List_T * liste, int index) { if((index < 0) || (index >= liste->n)) Message::Fatal("Wrong list index (pointer)"); liste->isorder = 0; return (&liste->array[index * liste->size]); } void *List_Pointer_NoChange(List_T * liste, int index) { if((index < 0) || (index >= liste->n)) Message::Fatal("Wrong list index (pointer)"); return (&liste->array[index * liste->size]); } void *List_Pointer_Fast(List_T * liste, int index) { return (&liste->array[index * liste->size]); } void *List_Pointer_Test(List_T * liste, int index) { if(!liste || (index < 0) || (index >= liste->n)) return NULL; liste->isorder = 0; return (&liste->array[index * liste->size]); } void List_Sort(List_T * liste, int (*fcmp) (const void *a, const void *b)) { qsort(liste->array, liste->n, liste->size, fcmp); } int List_Search(List_T * liste, void *data, int (*fcmp) (const void *a, const void *b)) { void *ptr; if(liste->isorder != 1) { List_Sort(liste, fcmp); liste->isorder = 1; } ptr = (void *)bsearch(data, liste->array, liste->n, liste->size, fcmp); if(ptr == NULL) return (0); return (1); } int List_ISearchSeq(List_T * liste, void *data, int (*fcmp) (const void *a, const void *b)) { int i; if(!liste) return -1; i = 0; while((i < List_Nbr(liste)) && fcmp(data, (void *)List_Pointer(liste, i))) i++; if(i == List_Nbr(liste)) i = -1; return i; } void *List_PQuery(List_T * liste, void *data, int (*fcmp) (const void *a, const void *b)) { void *ptr; if(liste->isorder != 1) List_Sort(liste, fcmp); liste->isorder = 1; ptr = (void *)bsearch(data, liste->array, liste->n, liste->size, fcmp); return (ptr); } int List_PSuppress(List_T * liste, int index) { char *ptr; int len; ptr = (char *)List_Pointer_NoChange(liste, index); if(ptr == NULL) return (0); liste->n--; len = liste->n - (((intptr_t)ptr - (intptr_t)liste->array) / liste->size); if(len > 0) memmove(ptr, ptr + liste->size, len * liste->size); return (1); } void List_Invert(List_T * a, List_T * b) { int i, N; N = List_Nbr(a); for(i = 0; i < N; i++) { List_Add(b, List_Pointer(a, N - i - 1)); } } void List_Reset(List_T * liste) { if(!liste) return; liste->n = 0; } void List_Action(List_T * liste, void (*action) (void *data, void *dummy)) { int i, dummy; for(i = 0; i < List_Nbr(liste); i++) (*action) (List_Pointer_NoChange(liste, i), &dummy); } void List_Copy(List_T * a, List_T * b) { int i, N; N = List_Nbr(a); for(i = 0; i < N; i++) { List_Add(b, List_Pointer(a, i)); } } List_T *ListOfDouble2ListOfInt(List_T *dList) { int n = List_Nbr(dList); List_T *iList = List_Create(n, n, sizeof(int)); for(int i = 0; i < n; i++){ double d; List_Read(dList, i, &d); int j = (int)d; List_Add(iList, &j); } return iList; } #endif // These are not defined in Gmsh: static int safe_fwrite(const void *ptr, size_t size, size_t nmemb, FILE * stream) { size_t result = fwrite(ptr, size, nmemb, stream); if(result < nmemb) { Message::Error(strerror(errno)); if(fflush(stream) < 0) Message::Error("EOF reached"); if(fclose(stream) < 0) Message::Error(strerror(errno)); return 1; } return 0; } void List_WriteToFile(List_T * liste, FILE * file, int format) { int i, n; if(!(n = List_Nbr(liste))) return; switch (format) { case LIST_FORMAT_ASCII: if(liste->size == sizeof(double)) for(i = 0; i < n; i++) fprintf(file, " %.16g", *((double *)&liste->array[i * liste->size])); else if(liste->size == sizeof(float)) for(i = 0; i < n; i++) fprintf(file, " %.16g", *((float *)&liste->array[i * liste->size])); else if(liste->size == sizeof(int)) for(i = 0; i < n; i++) fprintf(file, " %d", *((int *)&liste->array[i * liste->size])); else if(liste->size == sizeof(char)) for(i = 0; i < n; i++) fputc(*((char *)&liste->array[i * liste->size]), file); else Message::Error("Bad type of data to write list to file (size = %d)", liste->size); break; case LIST_FORMAT_BINARY: safe_fwrite(liste->array, liste->size, n, file); break; default: Message::Error("Unknown list format"); break; } } int List_Query(List_T *liste, void *data, int (*fcmp)(const void *a, const void *b)) { void *ptr; if (liste->isorder != 1) List_Sort(liste,fcmp); liste->isorder = 1; ptr = (void *) bsearch(data,liste->array,liste->n,liste->size,fcmp); if (ptr == NULL) return(0); memcpy(data,ptr,liste->size); return (1); } int List_Suppress(List_T *liste, void *data, int (*fcmp)(const void *a, const void *b)) { char *ptr; int len; ptr = (char*)List_PQuery(liste,data,fcmp) ; if (ptr == NULL) return(0); liste->n--; len = liste->n - (((intptr_t)ptr - (intptr_t)liste->array) / liste->size); if (len > 0) memmove(ptr, ptr + liste->size, len * liste->size); return(1); } void List_Insert(List_T *liste, void *data, int (*fcmp)(const void *a, const void *b)) { if (List_Search(liste,data,fcmp) == 0) List_Add(liste,data); } List_T *List_Copy(List_T *src) { List_T *dest = (List_T *)Malloc(sizeof(List_T)); dest->nmax = src->nmax; dest->incr = src->incr; dest->size = src->size; dest->n = src->n; dest->isorder = src->isorder; dest->array = (char *)Malloc(src->nmax * src->size); memcpy(dest->array, src->array, src->nmax * src->size); return dest; } int List_ISearch(List_T * liste, void *data, int (*fcmp) (const void *a, const void *b)) { void *ptr; if(liste->isorder != 1) List_Sort(liste, fcmp); liste->isorder = 1; ptr = (void *)bsearch(data, liste->array, liste->n, liste->size, fcmp); if(ptr == NULL) return (-1); return (((intptr_t)ptr - (intptr_t)liste->array) / liste->size); } int List_ISearchSeqPartial(List_T *liste, void * data, int i_Start, int (*fcmp)(const void *a, const void *b)) { int i ; if (!liste) return -1 ; i = i_Start ; while ((i < List_Nbr(liste)) && fcmp(data, (void *)List_Pointer(liste, i)) ) i++ ; if (i == List_Nbr(liste)) i = -1 ; return i ; } int List_Replace(List_T *liste, void *data, int (*fcmp)(const void *a, const void *b)) { void *ptr; if (liste->isorder != 1) List_Sort(liste,fcmp); liste->isorder = 1; ptr = (void *) bsearch(data,liste->array,liste->n,liste->size,fcmp); if (ptr == NULL) { List_Add(liste,data); return(0); } else { memcpy(ptr,data,liste->size); return (1); } } static void *lolofind(void *data, void *array, int n, int size, int (*fcmp)(const void *a, const void *b) ) { char *ptr; int i; ptr = (char*)array; for (i = 0; i < n; i++) { if (fcmp(ptr,data) == 0) break; ptr += size; } if (i < n) return(ptr); return(NULL); } static char *startptr = NULL; int List_LQuery(List_T *liste, void *data, int (*fcmp)(const void *a, const void *b), int first) { char *ptr; if (first == 1) { ptr = (char *) lolofind(data,liste->array,liste->n,liste->size,fcmp); } else { if (startptr != NULL) ptr = (char *) lolofind(data,startptr, liste->n - (startptr-liste->array)/liste->size, liste->size,fcmp); else return(0); } if (ptr == NULL) return(0); startptr = ptr + liste->size; if ( startptr >= ( liste->array + liste->n * liste->size)) startptr = NULL; memcpy(data,ptr,liste->size); return (1); } void List_Put(List_T * liste, int index, void *data) { if(index < 0) Message::Error("Wrong list index (put)"); else { if(index >= liste->n) { liste->n = index + 1; List_Realloc(liste, liste->n); List_Write(liste, index, data); } else { List_Write(liste, index, data); } } } getdp-2.4.2-source/Common/ListUtils.h000644 001750 001750 00000005556 12116424203 021143 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _LIST_UTILS_H_ #define _LIST_UTILS_H_ #include #define LIST_FORMAT_ASCII 0 #define LIST_FORMAT_BINARY 1 class List_T { public: int nmax; int size; int incr; int n; int isorder; char *array; }; List_T *List_Create(int n, int incr, int size); void List_Delete(List_T *liste); void List_Realloc(List_T *liste,int n); void List_Add(List_T *liste, void *data); int List_Nbr(List_T *liste); void List_Insert(List_T *liste, void *data, int (*fcmp)(const void *a, const void *b)); int List_Replace(List_T *liste, void *data, int (*fcmp)(const void *a, const void *b)); void List_Read(List_T *liste, int index, void *data); void List_Write(List_T *liste, int index, void *data); void List_Put(List_T *liste, int index, void *data); void List_Pop(List_T *liste); void *List_Pointer(List_T *liste, int index); void *List_Pointer_NoChange(List_T *liste, int index); void *List_Pointer_Fast(List_T *liste, int index); void *List_Pointer_Test(List_T *liste, int index); void List_Sort(List_T *liste, int (*fcmp)(const void *a, const void *b)); int List_Search(List_T *liste, void *data, int (*fcmp)(const void *a, const void *b)); int List_ISearch(List_T *liste, void *data, int (*fcmp)(const void *a, const void *b)); int List_ISearchSeq(List_T *liste, void * data, int (*fcmp)(const void *a, const void *b)); int List_ISearchSeqPartial(List_T *liste, void * data, int i_Start, int (*fcmp)(const void *a, const void *b)); int List_LQuery(List_T *liste, void *data, int (*fcmp)(const void *a, const void *b), int first); int List_Query(List_T *liste, void *data, int (*fcmp)(const void *a, const void *b)); void *List_PQuery(List_T *liste, void *data, int (*fcmp)(const void *a, const void *b)); int List_Suppress(List_T *liste, void *data, int (*fcmp)(const void *a, const void *b)); int List_PSuppress(List_T *liste, int index); void List_Invert(List_T *a, List_T *b); void List_Reset(List_T *liste); void List_Action(List_T *liste, void (*action)(void *data, void *dummy)); void List_Copy(List_T *a , List_T *b); List_T *List_Copy(List_T *src); void List_Merge(List_T *a , List_T *b); List_T *List_CreateFromFile(int n, int incr, int size, FILE *file, int format, int swap); void List_WriteToFile(List_T *liste, FILE *file, int format); // for backward compatibility List_T *List_CreateFromFileOld(int n, int incr, int size, FILE *file, int format, int swap); int fcmp_int(const void *a, const void *b); int fcmp_absint(const void *a, const void *b); int fcmp_double(const void *a, const void *b); List_T *ListOfDouble2ListOfInt(List_T *dList); #endif getdp-2.4.2-source/Common/onelab.h000644 001750 001750 00000132056 12166744452 020463 0ustar00geuzainegeuzaine000000 000000 // OneLab - Copyright (C) 2011-2013 ULg-UCL // // Permission is hereby granted, free of charge, to any person // obtaining a copy of this software and associated documentation // files (the "Software"), to deal in the Software without // restriction, including without limitation the rights to use, copy, // modify, merge, publish, distribute, and/or sell copies of the // Software, and to permit persons to whom the Software is furnished // to do so, provided that the above copyright notice(s) and this // permission notice appear in all copies of the Software and that // both the above copyright notice(s) and this permission notice // appear in supporting documentation. // // THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, // EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF // MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND // NONINFRINGEMENT OF THIRD PARTY RIGHTS. IN NO EVENT SHALL THE // COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS NOTICE BE LIABLE FOR // ANY CLAIM, OR ANY SPECIAL INDIRECT OR CONSEQUENTIAL DAMAGES, OR ANY // DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, // WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS // ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE // OF THIS SOFTWARE. // // Please report all bugs and problems to the public mailing list // . #ifndef _ONELAB_H_ #define _ONELAB_H_ #include #include #include #include #include #include #include #include #include "GmshSocket.h" namespace onelab{ // The base parameter class. class parameter{ private: // the name of the parameter, including its '/'-separated path in the // parameter hierarchy. Parameters or subpaths can start with numbers to // force their relative ordering (such numbers are automatically hidden in // the interface). All strings in onelab are supposed to be UTF8-encoded. std::string _name; // the parameter label: if provided it serves as a better way to display the // parameter in the interface std::string _label; // a help string std::string _help; // clients that use this parameter std::set _clients; // flag to check if the value of the parameter has been changed since the // last computation (normally this is reset after all the clients have been // run) bool _changed; // flag indicating that the _changed flag of this parameter will always be // reset to false when the parameter is updated bool _neverChanged; // should the parameter be visible in the interface? bool _visible; // sould the paramete be "read-only" (not settable by the user) bool _readOnly; protected: // optional additional attributes std::map _attributes; public: parameter(const std::string &name="", const std::string &label="", const std::string &help="") : _name(name), _label(label), _help(help), _changed(true), _neverChanged(false), _visible(true), _readOnly(false) {} virtual ~parameter(){} void setName(const std::string &name){ _name = name; } void setLabel(const std::string &label){ _label = label; } void setHelp(const std::string &help){ _help = help; } void setChanged(bool changed){ _changed = changed; } void setNeverChanged(bool never){ _neverChanged = never; } void setVisible(bool visible){ _visible = visible; } void setReadOnly(bool readOnly){ _readOnly = readOnly; } void setAttribute(const std::string &key, const std::string &value) { _attributes[key] = value; } void setAttributes(const std::map &attributes) { _attributes = attributes; } void setClients(const std::set &clients){ _clients = clients; } void addClient(const std::string &client){ _clients.insert(client); } void addClients(const std::set &clients) { _clients.insert(clients.begin(), clients.end()); } bool hasClient(const std::string &client) { return (_clients.find(client) != _clients.end()); } virtual std::string getType() const = 0; const std::string &getName() const { return _name; } const std::string &getLabel() const { return _label; } const std::string &getHelp() const { return _help; } std::string getPath() const { std::string::size_type last = _name.find_last_of('/'); return _name.substr(0, last); } std::string getShortName() const { if(_label.size()) return _label; std::string s = _name; // remove path std::string::size_type last = _name.find_last_of('/'); if(last != std::string::npos) s = _name.substr(last + 1); // remove starting numbers while(s.size() && s[0] >= '0' && s[0] <= '9') s = s.substr(1); return s; } bool getChanged() const { return _changed; } bool getNeverChanged() const { return _neverChanged; } bool getVisible() const { return _visible; } bool getReadOnly() const { return _readOnly; } std::string getAttribute(const std::string &key) const { std::map::const_iterator it = _attributes.find(key); if(it != _attributes.end()) return it->second; return ""; } const std::map &getAttributes() const { return _attributes; } const std::set &getClients() const { return _clients; } static char charSep() { return '\0'; } static double maxNumber() { return 1e200; } static std::string version() { return "1.05"; } static std::string getNextToken(const std::string &msg, std::string::size_type &first, char separator=charSep()) { if(first == std::string::npos) return ""; std::string::size_type last = msg.find_first_of(separator, first); std::string next(""); if(last == std::string::npos){ next = msg.substr(first); first = last; } else if(first == last){ next = ""; first = last + 1; } else{ next = msg.substr(first, last - first); first = last + 1; } return next; } static std::vector split(const std::string &msg, char separator=charSep()) { std::vector out; std::string::size_type first = 0; while(first != std::string::npos) out.push_back(getNextToken(msg, first, separator)); return out; } std::string sanitize(const std::string &in) const { std::string out(in); for(unsigned int i = 0; i < in.size(); i++) if(out[i] == charSep()) out[i] = ' '; return out; } virtual std::string toChar() const { std::ostringstream sstream; sstream << version() << charSep() << getType() << charSep() << sanitize(getName()) << charSep() << sanitize(getLabel()) << charSep() << sanitize(getHelp()) << charSep() << (getNeverChanged() ? 1 : 0) << charSep() << (getChanged() ? 1 : 0) << charSep() << (getVisible() ? 1 : 0) << charSep() << (getReadOnly() ? 1 : 0) << charSep() << _attributes.size() << charSep(); for(std::map::const_iterator it = _attributes.begin(); it != _attributes.end(); it++) sstream << sanitize(it->first) << charSep() << sanitize(it->second) << charSep(); sstream << getClients().size() << charSep(); for(std::set::const_iterator it = getClients().begin(); it != getClients().end(); it++) sstream << sanitize(*it) << charSep(); return sstream.str(); } virtual std::string::size_type fromChar(const std::string &msg) { std::string::size_type pos = 0; if(getNextToken(msg, pos) != version()) return 0; if(getNextToken(msg, pos) != getType()) return 0; setName(getNextToken(msg, pos)); setLabel(getNextToken(msg, pos)); setHelp(getNextToken(msg, pos)); setNeverChanged(atoi(getNextToken(msg, pos).c_str())); setChanged(atoi(getNextToken(msg, pos).c_str())); setVisible(atoi(getNextToken(msg, pos).c_str())); setReadOnly(atoi(getNextToken(msg, pos).c_str())); int numAttributes = atoi(getNextToken(msg, pos).c_str()); for(int i = 0; i < numAttributes; i++){ std::string key(getNextToken(msg, pos)); setAttribute(key, getNextToken(msg, pos)); } int numClients = atoi(getNextToken(msg, pos).c_str()); for(int i = 0; i < numClients; i++){ std::string client(getNextToken(msg, pos)); addClient(client); } return pos; } static void getInfoFromChar(const std::string &msg, std::string &version, std::string &type, std::string &name) { std::string::size_type first = 0; version = getNextToken(msg, first); type = getNextToken(msg, first); name = getNextToken(msg, first); } static bool fromFile(std::vector &msg, FILE *fp) { msg.clear(); char tmp[1000]; if(!fgets(tmp, sizeof(tmp), fp)) return false; // first line is comment while(!feof(fp)){ int numc = 0; if(!fscanf(fp, "%d ", &numc)) break; // space is important if(!numc) break; msg.push_back(""); for(int i = 0; i < numc; i++) msg.back() += fgetc(fp); if(!fgets(tmp, sizeof(tmp), fp)) break; // end of line } return true; } static bool toFile(const std::vector &msg, FILE *fp, const std::string &creator) { time_t now; time(&now); fprintf(fp, "OneLab database created by %s on %s", creator.c_str(), ctime(&now)); for(unsigned int i = 0; i < msg.size(); i++){ fprintf(fp, "%d ", (int)msg[i].size()); for(unsigned int j = 0; j < msg[i].size(); j++) fputc(msg[i][j], fp); fputc('\n', fp); } return true; } }; class parameterLessThan{ public: bool operator()(const parameter *p1, const parameter *p2) const { return p1->getName() < p2->getName(); } }; // The number class. Numbers are stored internally as double precision real // numbers. All more complicated types (complex numbers, vectors, etc.) are // supposed to be either exchanged as strings or encapsulated in functions. class number : public parameter{ private: double _value, _min, _max, _step; // when in a loop, indicates current index in the vector _choices; // is -1 when not in a loop int _index; std::vector _choices; std::map _valueLabels; public: number(const std::string &name="", double value=0., const std::string &label="", const std::string &help="") : parameter(name, label, help), _value(value), _min(-maxNumber()), _max(maxNumber()), _step(0.), _index(-1) {} void setValue(double value){ _value = value; } void setMin(double min){ _min = min; } void setMax(double max){ _max = max; } void setStep(double step){ _step = step; } void setIndex(int index){ _index = index; } void setChoices(const std::vector &choices){ _choices = choices; } void setChoiceLabels(const std::vector &labels) { if(labels.size() != _choices.size()) return; for(unsigned int i = 0; i < _choices.size(); i++) _valueLabels[_choices[i]] = labels[i]; } void setValueLabels(const std::map &valueLabels) { _valueLabels = valueLabels; } void setValueLabel(double value, const std::string &label) { _valueLabels[value] = label; } std::string getType() const { return "number"; } double getValue() const { return _value; } double getMin() const { return _min; } double getMax() const { return _max; } double getStep() const { return _step; } int getIndex() const { return _index; } const std::vector &getChoices() const { return _choices; } const std::map &getValueLabels() const { return _valueLabels; } std::string getValueLabel(double value) const { std::map::const_iterator it = _valueLabels.find(value); if(it != _valueLabels.end()) return it->second; return ""; } void update(const number &p) { addClients(p.getClients()); // complete the list of clients setLabel(p.getLabel()); setHelp(p.getHelp()); setVisible(p.getVisible()); setReadOnly(p.getReadOnly()); setAttributes(p.getAttributes()); if(p.getValue() != getValue()){ setValue(p.getValue()); setChanged(true); } setMin(p.getMin()); setMax(p.getMax()); setStep(p.getStep()); setIndex(p.getIndex()); setChoices(p.getChoices()); setValueLabels(p.getValueLabels()); if(getNeverChanged()) setChanged(false); } std::string toChar() const { std::ostringstream sstream; sstream.precision(16); sstream << parameter::toChar() << _value << charSep() << _min << charSep() << _max << charSep() << _step << charSep() << _index << charSep() << _choices.size() << charSep(); for(unsigned int i = 0; i < _choices.size(); i++) sstream << _choices[i] << charSep(); sstream << _valueLabels.size() << charSep(); for(std::map::const_iterator it = _valueLabels.begin(); it != _valueLabels.end(); it++){ sstream << it->first << charSep(); sstream << sanitize(it->second) << charSep(); } return sstream.str(); } std::string::size_type fromChar(const std::string &msg) { std::string::size_type pos = parameter::fromChar(msg); if(!pos) return 0; setValue(atof(getNextToken(msg, pos).c_str())); setMin(atof(getNextToken(msg, pos).c_str())); setMax(atof(getNextToken(msg, pos).c_str())); setStep(atof(getNextToken(msg, pos).c_str())); setIndex(atoi(getNextToken(msg, pos).c_str())); _choices.resize(atoi(getNextToken(msg, pos).c_str())); for(unsigned int i = 0; i < _choices.size(); i++) _choices[i] = atof(getNextToken(msg, pos).c_str()); int numValueLabels = atoi(getNextToken(msg, pos).c_str()); for(int i = 0; i < numValueLabels; i++){ double value = atof(getNextToken(msg, pos).c_str()); _valueLabels[value] = getNextToken(msg, pos); } return pos; } }; // The string class. A string has a mutable "kind": we do not derive // specialized classes, because the kind should be changeable at runtime // (e.g. from a client-dependent mathematical expression to a table of // values). Kinds currently recognized by Gmsh are: "file". Possible // kinds could be "complex", "matrix m n", "hostname", client-dependent // mathematical expression, onelab mathematical expression (through mathex?), // ... class string : public parameter{ private: std::string _value, _kind; std::vector _choices; public: string(const std::string &name="", const std::string &value="", const std::string &label="", const std::string &help="") : parameter(name, label, help), _value(value), _kind("generic") {} void setValue(const std::string &value){ _value = value; } void setKind(const std::string &kind){ _kind = kind; } void setChoices(const std::vector &choices){ _choices = choices; } std::string getType() const { return "string"; } const std::string &getValue() const { return _value; } const std::string &getKind() const { return _kind; } const std::vector &getChoices() const { return _choices; } void update(const string &p) { addClients(p.getClients()); setLabel(p.getLabel()); setHelp(p.getHelp()); setVisible(p.getVisible()); setReadOnly(p.getReadOnly()); setAttributes(p.getAttributes()); if(p.getValue() != getValue()){ setValue(p.getValue()); setChanged(true); } if(p.getKind() != getKind()){ setKind(p.getKind()); setChanged(true); } setChoices(p.getChoices()); if(getNeverChanged()) setChanged(false); } std::string toChar() const { std::ostringstream sstream; sstream << parameter::toChar() << sanitize(_value) << charSep() << sanitize(_kind) << charSep() << _choices.size() << charSep(); for(unsigned int i = 0; i < _choices.size(); i++) sstream << sanitize(_choices[i]) << charSep(); return sstream.str(); } std::string::size_type fromChar(const std::string &msg) { std::string::size_type pos = parameter::fromChar(msg); if(!pos) return 0; setValue(getNextToken(msg, pos)); setKind(getNextToken(msg, pos)); _choices.resize(atoi(getNextToken(msg, pos).c_str())); for(unsigned int i = 0; i < _choices.size(); i++) _choices[i] = getNextToken(msg, pos); return pos; } }; // The region class. A region can be any kind of geometrical entity, // represented as identifiers of physical regions. Operations on regions will // include union, intersection, etc. class region : public parameter{ private: std::set _value; // optional geometrical dimension int _dimension; std::vector > _choices; public: region(const std::string &name="", const std::set &value = std::set(), const std::string &label="", const std::string &help="") : parameter(name, label, help), _value(value), _dimension(-1) {} region(const std::string &name, const std::string &value, const std::string &label="", const std::string &help="") : parameter(name, label, help), _dimension(-1) { if(value.size()) _value.insert(value); } void setValue(const std::set &value){ _value = value; } void setDimension(int dim){ _dimension = dim; } void setChoices(const std::vector > &choices) { _choices = choices; } std::string getType() const { return "region"; } const std::set &getValue() const { return _value; } int getDimension() const { return _dimension; } const std::vector > &getChoices() const { return _choices; } void update(const region &p) { addClients(p.getClients()); setLabel(p.getLabel()); setHelp(p.getHelp()); setAttributes(p.getAttributes()); if(p.getValue() != getValue()){ setValue(p.getValue()); setChanged(true); } setDimension(p.getDimension()); setChoices(p.getChoices()); if(getNeverChanged()) setChanged(false); } std::string toChar() const { std::ostringstream sstream; sstream << parameter::toChar() << _value.size() << charSep(); for(std::set::const_iterator it = _value.begin(); it != _value.end(); it++) sstream << sanitize(*it) << charSep(); sstream << _dimension << charSep(); sstream << _choices.size() << charSep(); for(unsigned int i = 0; i < _choices.size(); i++){ sstream << _choices[i].size() << charSep(); for(std::set::const_iterator it = _choices[i].begin(); it != _choices[i].end(); it++) sstream << sanitize(*it) << charSep(); } return sstream.str(); } std::string::size_type fromChar(const std::string &msg) { std::string::size_type pos = parameter::fromChar(msg); if(!pos) return 0; int n = atoi(getNextToken(msg, pos).c_str()); for(int i = 0; i < n; i++) _value.insert(getNextToken(msg, pos)); setDimension(atoi(getNextToken(msg, pos).c_str())); _choices.resize(atoi(getNextToken(msg, pos).c_str())); for(unsigned int i = 0; i < _choices.size(); i++){ n = atoi(getNextToken(msg, pos).c_str()); for(int i = 0; i < n; i++) _choices[i].insert(getNextToken(msg, pos)); } return pos; } }; // The (possibly piece-wise defined on regions) function class. Functions are // entirely client-dependent: they are just represented internally as onelab // strings, defined on onelab regions. class function : public parameter{ private: std::map _value; std::vector > _choices; public: function(const std::string &name="") : parameter(name, "", "") {} function(const std::string &name, const std::map &value, const std::string &label="", const std::string &help="") : parameter(name, label, help), _value(value) {} void setValue(const std::map &value) { _value = value; } void setChoices(const std::vector > &choices) { _choices = choices; } std::string getType() const { return "function"; } const std::map &getValue() const { return _value; } const std::string getValue(const std::string ®ion) const { std::map::const_iterator it = _value.find(region); if(it != _value.end()) return it->second; return ""; } const std::vector > &getChoices() const { return _choices; } void update(const function &p) { addClients(p.getClients()); setLabel(p.getLabel()); setHelp(p.getHelp()); setAttributes(p.getAttributes()); if(p.getValue() != getValue()){ setValue(p.getValue()); setChanged(true); } setChoices(p.getChoices()); if(getNeverChanged()) setChanged(false); } std::string toChar() const { std::ostringstream sstream; sstream << parameter::toChar() << _value.size() << charSep(); for(std::map::const_iterator it = _value.begin(); it != _value.end(); it++) sstream << sanitize(it->first) << charSep() << sanitize(it->second) << charSep(); sstream << _choices.size() << charSep(); for(unsigned int i = 0; i < _choices.size(); i++){ sstream << _choices[i].size() << charSep(); for(std::map::const_iterator it = _choices[i].begin(); it != _choices[i].end(); it++) sstream << sanitize(it->first) << charSep() << sanitize(it->second) << charSep(); } return sstream.str(); } std::string::size_type fromChar(const std::string &msg) { std::string::size_type pos = parameter::fromChar(msg); if(!pos) return 0; int n = atoi(getNextToken(msg, pos).c_str()); for(int i = 0; i < n; i++){ std::string key = getNextToken(msg, pos); _value[key] = getNextToken(msg, pos); } _choices.resize(atoi(getNextToken(msg, pos).c_str())); for(unsigned int i = 0; i < _choices.size(); i++){ n = atoi(getNextToken(msg, pos).c_str()); for(int i = 0; i < n; i++){ std::string key = getNextToken(msg, pos); _choices[i][key] = getNextToken(msg, pos); } } return pos; } }; // The parameter space, i.e., the set of parameters stored and handled by the // onelab server. class parameterSpace{ private: std::set _numbers; std::set _strings; std::set _regions; std::set _functions; // delete a parameter from the parameter space template bool _clear(const std::string &name, const std::string &client, std::set &ps) { if(name.empty() && client.size()){ for(typename std::set::iterator it = ps.begin(); it != ps.end(); it++){ T *p = *it; if(p->hasClient(client)){ ps.erase(it); delete p; } } } else{ T tmp(name); typename std::set::iterator it = ps.find(&tmp); if(it != ps.end()){ T *p = *it; if(client.empty() || p->hasClient(client)){ ps.erase(it); delete p; return true; } } } return false; } // set a parameter in the parameter space; if it already exists, update it // (adding new clients if necessary). This needs to be locked to avoid race // conditions when several clients try to set a parameter at the same time. template bool _set(const T &p, const std::string &client, std::set &ps) { typename std::set::iterator it = ps.find((T*)&p); if(it != ps.end()){ (*it)->update(p); if(client.size()) (*it)->addClient(client); } else{ T* newp = new T(p); if(client.size()) newp->addClient(client); ps.insert(newp); } return true; } // get the parameter matching the given name, or all the parameters in the // category if no name is given. If we find a given parameter by name, we // add the client requesting the parameter to the list of clients for this // parameter. This also needs to be locked. template bool _get(std::vector &p, const std::string &name, const std::string &client, std::set &ps) { p.clear(); if(name.empty()){ for(typename std::set::iterator it = ps.begin(); it != ps.end(); it++) p.push_back(**it); } else{ T tmp(name); typename std::set::iterator it = ps.find(&tmp); if(it != ps.end()){ if(client.size()) (*it)->addClient(client); p.push_back(**it); } } return true; } void _getAllParameters(std::set &ps) const { ps.insert(_numbers.begin(), _numbers.end()); ps.insert(_strings.begin(), _strings.end()); ps.insert(_regions.begin(), _regions.end()); ps.insert(_functions.begin(), _functions.end()); } public: parameterSpace(){} ~parameterSpace(){ clear(); } void clear(const std::string &name="", const std::string &client="") { if(name.empty() && client.empty()){ std::set ps; _getAllParameters(ps); for(std::set::iterator it = ps.begin(); it != ps.end(); it++) delete *it; _numbers.clear(); _strings.clear(); _regions.clear(); _functions.clear(); } else{ bool done = _clear(name, client, _numbers); if(!done) done = _clear(name, client, _strings); if(!done) done = _clear(name, client, _regions); if(!done) done = _clear(name, client, _functions); } } bool set(const number &p, const std::string &client=""){ return _set(p, client, _numbers); } bool set(const string &p, const std::string &client=""){ return _set(p, client, _strings); } bool set(const region &p, const std::string &client=""){ return _set(p, client, _regions); } bool set(const function &p, const std::string &client=""){ return _set(p, client, _functions); } bool get(std::vector &ps, const std::string &name="", const std::string &client=""){ return _get(ps, name, client, _numbers); } bool get(std::vector &ps, const std::string &name="", const std::string &client=""){ return _get(ps, name, client, _strings); } bool get(std::vector &ps, const std::string &name="", const std::string &client=""){ return _get(ps, name, client, _regions); } bool get(std::vector &ps, const std::string &name="", const std::string &client=""){ return _get(ps, name, client, _functions); } unsigned int getNumParameters() { return (int)(_numbers.size() + _strings.size() + _regions.size() + _functions.size()); } // check if at least one parameter depends on the given client bool hasClient(const std::string &client) const { std::set ps; _getAllParameters(ps); for(std::set::iterator it = ps.begin(); it != ps.end(); it++) if((*it)->hasClient(client)) return true; return false; } // check if some parameters have changed (optionnally only check the // parameters that depend on a given client) bool getChanged(const std::string &client="") const { std::set ps; _getAllParameters(ps); for(std::set::iterator it = ps.begin(); it != ps.end(); it++){ if((client.empty() || (*it)->hasClient(client)) && (*it)->getChanged()){ return true; } } return false; } // set the changed flag for all parameters (optionnally only affect those // parameters that depend on a given client) bool setChanged(bool changed, const std::string &client="") { std::set ps; _getAllParameters(ps); for(std::set::iterator it = ps.begin(); it != ps.end(); it++) if(client.empty() || (*it)->hasClient(client)) (*it)->setChanged(changed); return true; } // serialize the parameter space (optionally only serialize those parameters // that depend on the given client) std::vector toChar(const std::string &client="") const { std::vector s; std::set ps; _getAllParameters(ps); for(std::set::const_iterator it = ps.begin(); it != ps.end(); it++) if(client.empty() || (*it)->hasClient(client)){ if((*it)->getAttribute("NotInDb") != "True") s.push_back((*it)->toChar()); } return s; } // unserialize the parameter space bool fromChar(const std::vector &msg, const std::string &client="") { for(unsigned int i = 0; i < msg.size(); i++){ std::string version, type, name; onelab::parameter::getInfoFromChar(msg[i], version, type, name); if(onelab::parameter::version() != version) return false; if(type == "number"){ onelab::number p; p.fromChar(msg[i]); set(p, client); } else if(type == "string"){ onelab::string p; p.fromChar(msg[i]); set(p, client); } else if(type == "region"){ onelab::region p; p.fromChar(msg[i]); set(p, client); } else if(type == "function"){ onelab::function p; p.fromChar(msg[i]); set(p, client); } else return false; } return true; } }; // The onelab client: a class that communicates with the onelab server. Each // client should be derived from this one. A client can be understood as "one // simulation step in a complex computation". class client{ protected: // the name of the client std::string _name; // the id of the client, used to create a unique socket for this client int _id; // the index of the client in an external client list (if any) int _index; public: client(const std::string &name) : _name(name), _id(0), _index(-1){} virtual ~client(){} std::string getName(){ return _name; } void setId(int id){ _id = id; } int getId(){ return _id; } void setIndex(int index){ _index = index; } int getIndex(){ return _index; } virtual bool run(){ return false; } virtual bool isNetworkClient(){ return false; } virtual bool kill(){ return false; } virtual void sendInfo(const std::string &msg){ std::cout << msg << std::endl; } virtual void sendWarning(const std::string &msg){ std::cerr << msg << std::endl; } virtual void sendError(const std::string &msg){ std::cerr << msg << std::endl; } virtual void sendProgress(const std::string &msg){ std::cout << msg << std::endl; } virtual void sendMergeFileRequest(const std::string &msg){} virtual void sendParseStringRequest(const std::string &msg){} virtual void sendVertexArray(const std::string &msg){} virtual bool clear(const std::string &name) = 0; virtual bool set(const number &p) = 0; virtual bool set(const string &p) = 0; virtual bool set(const region &p) = 0; virtual bool set(const function &p) = 0; virtual bool get(std::vector &ps, const std::string &name="") = 0; virtual bool get(std::vector &ps, const std::string &name="") = 0; virtual bool get(std::vector &ps, const std::string &name="") = 0; virtual bool get(std::vector &ps, const std::string &name="") = 0; std::vector toChar() { std::vector out; std::vector n; get(n); for(unsigned int i = 0; i < n.size(); i++) out.push_back(n[i].toChar()); std::vector s; get(s); for(unsigned int i = 0; i < s.size(); i++) out.push_back(s[i].toChar()); std::vector r; get(r); for(unsigned int i = 0; i < r.size(); i++) out.push_back(r[i].toChar()); std::vector f; get(f); for(unsigned int i = 0; i < f.size(); i++) out.push_back(f[i].toChar()); return out; } bool fromChar(const std::vector &msg) { for(unsigned int i = 0; i < msg.size(); i++){ std::string version, type, name; onelab::parameter::getInfoFromChar(msg[i], version, type, name); if(onelab::parameter::version() != version) return false; if(type == "number"){ onelab::number p; p.fromChar(msg[i]); set(p); } else if(type == "string"){ onelab::string p; p.fromChar(msg[i]); set(p); } else if(type == "region"){ onelab::region p; p.fromChar(msg[i]); set(p); } else if(type == "function"){ onelab::function p; p.fromChar(msg[i]); set(p); } else return false; } return true; } bool toFile(FILE *fp) { return parameter::toFile(toChar(), fp, getName()); } bool fromFile(FILE *fp) { std::vector msg; if(parameter::fromFile(msg, fp)) return fromChar(msg); return false; } }; // The onelab server: a singleton that stores the parameter space and // interacts with onelab clients. class server{ private: // the unique server (singleton behaviour due to the "static" specifier) static server *_server; // the address of the server std::string _address; // the connected clients, indexed by name std::map _clients; // the parameter space parameterSpace _parameterSpace; public: server(const std::string &address="") : _address(address) {} ~server(){} static server *instance(const std::string &address="") { if(!_server) _server = new server(address); return _server; } static void setInstance(server *s) { _server = s; } void clear(const std::string &name="", const std::string &client="") { _parameterSpace.clear(name, client); } template bool set(const T &p, const std::string &client="") { return _parameterSpace.set(p, client); } template bool get(std::vector &ps, const std::string &name="", const std::string &client="") { return _parameterSpace.get(ps, name, client); } typedef std::map::iterator citer; citer firstClient(){ return _clients.begin(); } citer lastClient(){ return _clients.end(); } int getNumClients() { return (int)_clients.size(); }; citer findClient(const std::string &name){ return _clients.find(name); } void registerClient(client *c) { _clients[c->getName()] = c; c->setId(_clients.size()); } void unregisterClient(client *c){ _clients.erase(c->getName()); } void setChanged(bool changed, const std::string &client="") { _parameterSpace.setChanged(changed, client); } bool getChanged(const std::string &client="") { return _parameterSpace.getChanged(client); } unsigned int getNumParameters(){ return _parameterSpace.getNumParameters(); } std::vector toChar(const std::string &client="") { return _parameterSpace.toChar(client); } bool fromChar(const std::vector &msg, const std::string &client="") { return _parameterSpace.fromChar(msg, client); } bool toFile(FILE *fp, const std::string &client="") { return parameter::toFile(toChar(client), fp, "onelab server"); } bool fromFile(FILE *fp, const std::string &client="") { std::vector msg; if(parameter::fromFile(msg, fp)) return fromChar(msg, client); return false; } }; // A local client, which lives in the same memory space as the server. class localClient : public client{ private: template bool _set(const T &p) { server::instance()->set(p, _name); return true; } template bool _get(std::vector &ps, const std::string &name="") { server::instance()->get(ps, name, _name); return true; } public: localClient(const std::string &name) : client(name) { server::instance()->registerClient(this); } virtual ~localClient() { server::instance()->unregisterClient(this); } virtual bool clear(const std::string &name="") { server::instance()->clear(name); return true; } virtual bool set(const number &p){ return _set(p); } virtual bool set(const string &p){ return _set(p); } virtual bool set(const function &p){ return _set(p); } virtual bool set(const region &p){ return _set(p); } virtual bool get(std::vector &ps, const std::string &name=""){ return _get(ps, name); } virtual bool get(std::vector &ps, const std::string &name=""){ return _get(ps, name); } virtual bool get(std::vector &ps, const std::string &name=""){ return _get(ps, name); } virtual bool get(std::vector &ps, const std::string &name=""){ return _get(ps, name); } }; // The local part of a network client. class localNetworkClient : public localClient{ private: // executable of the client (including filesystem path, if necessary) std::string _executable; // command to login to a remote host (if necessary) std::string _remoteLogin; // command line option to specify socket std::string _socketSwitch; // pid of the remote network client while it is running (-1 otherwise) int _pid; // underlying GmshServer GmshServer *_gmshServer; public: localNetworkClient(const std::string &name, const std::string &executable, const std::string &remoteLogin="") : localClient(name), _executable(executable), _remoteLogin(remoteLogin), _socketSwitch("-onelab"), _pid(-1), _gmshServer(0) {} virtual ~localNetworkClient(){} virtual bool isNetworkClient(){ return true; } const std::string &getExecutable(){ return _executable; } void setExecutable(const std::string &s){ _executable = s; } const std::string &getRemoteLogin(){ return _remoteLogin; } void setRemoteLogin(const std::string &s){ _remoteLogin = s; } const std::string &getSocketSwitch(){ return _socketSwitch; } void setSocketSwitch(const std::string &s){ _socketSwitch = s; } int getPid(){ return _pid; } void setPid(int pid){ _pid = pid; } GmshServer *getGmshServer(){ return _gmshServer; } void setGmshServer(GmshServer *server){ _gmshServer = server; } virtual bool run() = 0; virtual bool kill() = 0; }; // The remote part of a network client. class remoteNetworkClient : public client{ private: // address (inet:port or unix socket) of the server std::string _serverAddress; // underlying GmshClient GmshClient *_gmshClient; template bool _set(const T &p) { if(!_gmshClient) return false; std::string msg = p.toChar(); _gmshClient->SendMessage(GmshSocket::GMSH_PARAMETER, msg.size(), &msg[0]); return true; } template bool _get(std::vector &ps, const std::string &name="") { ps.clear(); if(!_gmshClient) return false; T p(name); std::string msg = p.toChar(); if (name.size()) _gmshClient->SendMessage(GmshSocket::GMSH_PARAMETER_QUERY, msg.size(), &msg[0]); else // get all parameters _gmshClient->SendMessage(GmshSocket::GMSH_PARAMETER_QUERY_ALL, msg.size(), &msg[0]); while(1){ // stop if we have no communications for 5 minutes int ret = _gmshClient->Select(500, 0); if(!ret){ _gmshClient->Info("Timout: aborting remote get"); return false; } else if(ret < 0){ _gmshClient->Error("Error on select: aborting remote get"); return false; } int type, length, swap; if(!_gmshClient->ReceiveHeader(&type, &length, &swap)){ _gmshClient->Error("Did not receive message header: aborting remote get"); return false; } std::string msg(length, ' '); if(!_gmshClient->ReceiveMessage(length, &msg[0])){ _gmshClient->Error("Did not receive message body: aborting remote get"); return false; } if(type == GmshSocket::GMSH_PARAMETER){ T p; p.fromChar(msg); ps.push_back(p); return true; } if(type == GmshSocket::GMSH_PARAMETER_QUERY_ALL){ T p; p.fromChar(msg); ps.push_back(p); // do NOT return until all parameters have been downloaded } else if(type == GmshSocket::GMSH_PARAMETER_QUERY_END){ // all parameters have been sent return true; } else if(type == GmshSocket::GMSH_PARAMETER_NOT_FOUND){ // parameter not found return true; } else if(type == GmshSocket::GMSH_INFO){ return true; } else{ _gmshClient->Error("Unknown message type: aborting remote get"); return false; } } return true; } public: remoteNetworkClient(const std::string &name, const std::string &serverAddress) : client(name), _serverAddress(serverAddress) { _gmshClient = new GmshClient(); if(_gmshClient->Connect(_serverAddress.c_str()) < 0){ delete _gmshClient; _gmshClient = 0; } else{ _gmshClient->Start(); } } virtual ~remoteNetworkClient() { if(_gmshClient){ _gmshClient->Stop(); _gmshClient->Disconnect(); delete _gmshClient; _gmshClient = 0; } } GmshClient *getGmshClient(){ return _gmshClient; } virtual bool isNetworkClient(){ return true; } virtual bool clear(const std::string &name="") { if(!_gmshClient) return false; std::string msg = name; if(msg.empty()) msg = "*"; _gmshClient->SendMessage(GmshSocket::GMSH_PARAMETER_CLEAR, msg.size(), &msg[0]); return true; } virtual bool set(const number &p){ return _set(p); } virtual bool set(const string &p){ return _set(p); } virtual bool set(const function &p){ return _set(p); } virtual bool set(const region &p){ return _set(p); } virtual bool get(std::vector &ps, const std::string &name=""){ return _get(ps, name); } virtual bool get(std::vector &ps, const std::string &name=""){ return _get(ps, name); } virtual bool get(std::vector &ps, const std::string &name=""){ return _get(ps, name); } virtual bool get(std::vector &ps, const std::string &name=""){ return _get(ps, name); } void sendInfo(const std::string &msg) { if(_gmshClient) _gmshClient->Info(msg.c_str()); } void sendWarning(const std::string &msg) { if(_gmshClient) _gmshClient->Warning(msg.c_str()); } void sendError(const std::string &msg) { if(_gmshClient) _gmshClient->Error(msg.c_str()); } void sendProgress(const std::string &msg) { if(_gmshClient) _gmshClient->Progress(msg.c_str()); } void sendMergeFileRequest(const std::string &msg) { if(_gmshClient) _gmshClient->MergeFile(msg.c_str()); } void sendParseStringRequest(const std::string &msg) { if(_gmshClient) _gmshClient->ParseString(msg.c_str()); } }; } #endif getdp-2.4.2-source/Common/Message.cpp000644 001750 001750 00000071246 12210577674 021145 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include #include #include #include #include "GetDPConfig.h" #include "Message.h" #include "GmshSocket.h" #include "onelab.h" #include "OS.h" #include "ProData.h" // for onelab #include "ProParser.h" // for onelab #if !defined(WIN32) || defined(__CYGWIN__) #include #include #endif #if defined(WIN32) #include #include #endif #if defined(HAVE_PETSC) #include "petsc.h" #endif #if defined(HAVE_GSL) #include #endif #if defined(HAVE_GMSH) #include #include #include #endif int Message::_commRank = 0; int Message::_commSize = 1; int Message::_isCommWorld = 1; // is the communicator set to WORLD (==1) or SELF (!=1) int Message::_errorCount = 0; int Message::_lastPETScError = 0; bool Message::_exitOnError = false; bool Message::_operatingInTimeLoopAdaptive = false; int Message::_verbosity = 5; int Message::_progressMeterStep = 10; int Message::_progressMeterCurrent = 0; std::map Message::_timers; GmshClient* Message::_client = 0; onelab::client* Message::_onelabClient = 0; #if !defined(HAVE_ONELAB) // if Gmsh is compiled without onelab onelab::server *onelab::server::_server = 0; #endif #if defined(HAVE_NO_VSNPRINTF) static int vsnprintf(char *str, size_t size, const char *fmt, va_list ap) { if(strlen(fmt) > size - 1){ // just copy the format strncpy(str, fmt, size - 1); str[size - 1] = '\0'; return size; } return vsprintf(str, fmt, ap); } #endif #if defined(_MSC_VER) && (_MSC_VER == 1310) //NET 2003 #define vsnprintf _vsnprintf #endif #if defined(HAVE_GSL) static void gslErrorHandler(const char *reason, const char *file, int line, int gsl_errno) { Message::Error("GSL: %s (%s, line %d)", reason, file, line); } #endif void Message::Initialize(int argc, char **argv) { _errorCount = 0; #if defined(HAVE_PETSC) MPI_Init(&argc, &argv); MPI_Comm_rank(MPI_COMM_WORLD, &_commRank); MPI_Comm_size(MPI_COMM_WORLD, &_commSize); MPI_Errhandler_set(MPI_COMM_WORLD, MPI_ERRORS_RETURN); #endif #if defined(HAVE_GSL) gsl_set_error_handler(&gslErrorHandler); #endif } void Message::Finalize() { #if defined(HAVE_PETSC) int flag; MPI_Initialized(&flag); if(flag) MPI_Finalize(); #endif FinalizeSocket(); FinalizeOnelab(); } void Message::Exit(int level) { Finalize(); exit(level); } static int streamIsFile(FILE* stream) { // the given stream is definitely not interactive if it is a regular file struct stat stream_stat; if(fstat(fileno(stream), &stream_stat) == 0){ if(stream_stat.st_mode & S_IFREG) return 1; } return 0; } static int streamIsVT100(FILE* stream) { // if running inside emacs the terminal is not VT100 const char* emacs = getenv("EMACS"); if(emacs && *emacs == 't') return 0; // list of known terminal names (from cmake) static const char* names[] = {"Eterm", "ansi", "color-xterm", "con132x25", "con132x30", "con132x43", "con132x60", "con80x25", "con80x28", "con80x30", "con80x43", "con80x50", "con80x60", "cons25", "console", "cygwin", "dtterm", "eterm-color", "gnome", "gnome-256color", "konsole", "konsole-256color", "kterm", "linux", "msys", "linux-c", "mach-color", "mlterm", "putty", "rxvt", "rxvt-256color", "rxvt-cygwin", "rxvt-cygwin-native", "rxvt-unicode", "rxvt-unicode-256color", "screen", "screen-256color", "screen-256color-bce", "screen-bce", "screen-w", "screen.linux", "vt100", "xterm", "xterm-16color", "xterm-256color", "xterm-88color", "xterm-color", "xterm-debian", 0}; const char** t = 0; const char* term = getenv("TERM"); if(term){ for(t = names; *t && strcmp(term, *t) != 0; ++t) {} } if(!(t && *t)) return 0; return 1; } void Message::Fatal(const char *fmt, ...) { _errorCount++; char str[1024]; va_list args; va_start(args, fmt); vsnprintf(str, sizeof(str), fmt, args); va_end(args); if(_client){ _client->Error(str); } else if(_onelabClient && _onelabClient->getName() != "GetDPServer"){ _onelabClient->sendError(str); } else{ const char *c0 = "", *c1 = ""; if(!streamIsFile(stderr) && streamIsVT100(stderr)){ c0 = "\33[1m\33[31m"; c1 = "\33[0m"; // bold red } if(_commSize > 1) fprintf(stderr, "%sFatal : [rank %3d] %s%s\n", c0, _commRank, str, c1); else fprintf(stderr, "%sFatal : %s%s\n", c0, str, c1); fflush(stderr); } Exit(1); } void Message::Error(const char *fmt, ...) { _errorCount++; if(!_exitOnError && _verbosity < 1) return; char str[1024]; va_list args; va_start(args, fmt); vsnprintf(str, sizeof(str), fmt, args); va_end(args); if(_client){ _client->Error(str); } else if(_onelabClient && _onelabClient->getName() != "GetDPServer"){ _onelabClient->sendError(str); } else{ const char *c0 = "", *c1 = ""; if(!streamIsFile(stderr) && streamIsVT100(stderr)){ c0 = "\33[1m\33[31m"; c1 = "\33[0m"; // bold red } if(_commSize > 1) fprintf(stderr, "%sError : [rank %3d] %s%s\n", c0, _commRank, str, c1); else fprintf(stderr, "%sError : %s%s\n", c0, str, c1); fflush(stderr); } if(_exitOnError){ // Error() should normally not exit; use Fatal() for that Exit(1); } } void Message::Warning(const char *fmt, ...) { if((_commRank && _isCommWorld) || _verbosity < 2) return; char str[1024]; va_list args; va_start(args, fmt); vsnprintf(str, sizeof(str), fmt, args); va_end(args); if(_client){ _client->Warning(str); } else if(_onelabClient && _onelabClient->getName() != "GetDPServer"){ _onelabClient->sendWarning(str); } else{ const char *c0 = "", *c1 = ""; if(!streamIsFile(stdout) && streamIsVT100(stdout)){ c0 = "\33[35m"; c1 = "\33[0m"; // magenta } if(_isCommWorld) fprintf(stdout, "%sWarning : %s%s\n", c0, str, c1); else fprintf(stdout, "%sWarning : [rank %3d] %s%s\n", c0, _commRank, str, c1); fflush(stdout); } } void Message::Info(const char *fmt, ...) { if((_commRank && _isCommWorld) || _verbosity < 4) return; char str[1024]; va_list args; va_start(args, fmt); vsnprintf(str, sizeof(str), fmt, args); va_end(args); Info(4, str); } void Message::Info(int level, const char *fmt, ...) { if((_commRank && _isCommWorld) || _verbosity < level) return; char str[1024]; va_list args; va_start(args, fmt); vsnprintf(str, sizeof(str), fmt, args); va_end(args); if(_client){ _client->Info(str); } else if(_onelabClient && _onelabClient->getName() != "GetDPServer"){ _onelabClient->sendInfo(str); } else{ if(_isCommWorld) fprintf(stdout, "Info : %s\n", str); else fprintf(stdout, "Info : [rank %3d] %s\n", _commRank, str); fflush(stdout); } } void Message::Direct(const char *fmt, ...) { if((_commRank && _isCommWorld) || _verbosity < 3) return; va_list args; va_start(args, fmt); char str[1024]; vsnprintf(str, sizeof(str), fmt, args); va_end(args); Direct(3, str); } void Message::Direct(int level, const char *fmt, ...) { if((_commRank && _isCommWorld) || _verbosity < level) return; va_list args; va_start(args, fmt); char str[1024]; vsnprintf(str, sizeof(str), fmt, args); va_end(args); if(_client){ _client->Info(str); } else if(_onelabClient && _onelabClient->getName() != "GetDPServer"){ _onelabClient->sendInfo(str); } else{ const char *c0 = "", *c1 = ""; if(level == 3 && !streamIsFile(stdout) && streamIsVT100(stdout)){ c0 = "\33[34m"; c1 = "\33[0m"; // blue } if(_isCommWorld) fprintf(stdout, "%s%s%s\n", c0, str, c1); else fprintf(stdout, "%s [rank %3d] %s%s\n", c0, _commRank, str, c1); fflush(stdout); } } void Message::Check(const char *fmt, ...) { if(_commRank && _isCommWorld) return; char str[5000]; va_list args; va_start(args, fmt); vsnprintf(str, sizeof(str), fmt, args); va_end(args); if(_client){ _client->Info(str); } else if(_onelabClient && _onelabClient->getName() != "GetDPServer"){ _onelabClient->sendInfo(str); } else{ fprintf(stdout, "%s", str); fflush(stdout); } } void Message::Debug(const char *fmt, ...) { if(_verbosity < 99) return; va_list args; va_start(args, fmt); char str[1024]; vsnprintf(str, sizeof(str), fmt, args); va_end(args); if(_client){ _client->Info(str); } else if(_onelabClient && _onelabClient->getName() != "GetDPServer"){ _onelabClient->sendInfo(str); } else{ if(_commSize > 1) fprintf(stdout, "Debug : [rank %3d] %s\n", _commRank, str); else fprintf(stdout, "Debug : %s\n", str); fflush(stdout); } } void Message::Cpu(const char *fmt, ...) { if((_commRank && _isCommWorld) || _verbosity < 5) return; va_list args; va_start(args, fmt); char str[1024]; vsnprintf(str, sizeof(str), fmt, args); va_end(args); Cpu(5, str); } void Message::Cpu(int level, const char *fmt, ...) { if((_commRank && _isCommWorld) || _verbosity < level) return; double s = 0.; long mem = 0; GetResources(&s, &mem); char str[1024], str2[256]; va_list args; va_start(args, fmt); vsnprintf(str, sizeof(str), fmt, args); va_end(args); if(strlen(fmt)) strcat(str, " "); time_t now; time(&now); std::string currtime(ctime(&now)); currtime.resize(currtime.size() - 1); if(mem) sprintf(str2, "(%s, CPU = %gs, Mem = %ldMb)", currtime.c_str(), s, mem / 1024 / 1024); else sprintf(str2, "(%s, CPU = %gs)", currtime.c_str(), s); strcat(str, str2); if(_client){ _client->Info(str); } else if(_onelabClient && _onelabClient->getName() != "GetDPServer"){ _onelabClient->sendInfo(str); } else{ if(_isCommWorld) fprintf(stdout, "Info : %s\n", str); else fprintf(stdout, "Info : [rank %3d] %s\n", _commRank, str); fflush(stdout); } } void Message::ProgressMeter(int n, int N, const char *fmt, ...) { if((_commRank && _isCommWorld) || _verbosity < 4 || _progressMeterStep <= 0 || _progressMeterStep >= 100) return; double percent = 100. * (double)n/(double)N; if(N <= 0 || percent >= _progressMeterCurrent || n > N - 1){ char str[1024], str2[1024]; va_list args; va_start(args, fmt); vsnprintf(str, sizeof(str), fmt, args); va_end(args); sprintf(str2, "%3d%% : %s", _progressMeterCurrent, str); if(_onelabClient && _onelabClient->getName() == "GetDP"){ _onelabClient->sendProgress(str); } if(N <= 0){ if(_onelabClient && _onelabClient->getName() != "GetDPServer"){ onelab::number o(_onelabClient->getName() + "/Progress", n); o.setLabel(std::string("GetDP ") + str); o.setMin(0); o.setMax(N); o.setVisible(false); o.setReadOnly(true); _onelabClient->set(o); } return; } if(_client){ _client->Progress(str2); } else if(_onelabClient && _onelabClient->getName() != "GetDPServer"){ onelab::number o(_onelabClient->getName() + "/Progress", (n > N - 1) ? 0 : n); o.setLabel(std::string("GetDP ") + str); o.setMin(0); o.setMax(N); o.setVisible(false); o.setReadOnly(true); _onelabClient->set(o); } else if(!streamIsFile(stdout)){ fprintf(stdout, "%s \r", (n > N - 1) ? "" : str2); fflush(stdout); } while(_progressMeterCurrent < percent) _progressMeterCurrent += _progressMeterStep; } } void Message::PrintTimers() { // do a single stdio call! std::string str; for(std::map::iterator it = _timers.begin(); it != _timers.end(); it++){ if(it != _timers.begin()) str += ", "; char tmp[256]; sprintf(tmp, "%s = %gs ", it->first.c_str(), it->second); str += std::string(tmp); } if(!str.size()) return; if(_client){ _client->Info((char*)str.c_str()); } else if(_onelabClient && _onelabClient->getName() != "GetDPServer"){ _onelabClient->sendInfo(str); } else{ if(_commSize > 1) fprintf(stdout, "Timers : [rank %3d] %s\n", _commRank, str.c_str()); else fprintf(stdout, "Timers : %s\n", str.c_str()); fflush(stdout); } } void Message::PrintErrorCounter(const char *title) { if(!_errorCount || _commRank || _verbosity < 1) return; Error("%s encountered %d error%s - check the log for details", title, _errorCount, (_errorCount > 1) ? "s" : ""); } void Message::InitializeSocket(std::string sockname) { if(sockname.size()){ _client = new GmshClient(); if(_client->Connect(sockname.c_str()) < 0){ Message::Error("Could not connect to socket `%s'", sockname.c_str()); delete _client; _client = 0; } else{ _client->Start(); } } } void Message::SendMergeFileRequest(const std::string &filename) { if(_client){ _client->MergeFile((char*)filename.c_str()); } else if(_onelabClient && _onelabClient->getName() != "GetDPServer"){ _onelabClient->sendMergeFileRequest(filename); } } void Message::TestSocket() { if(_client){ std::string tmp("View \"test\" {\n"); for(int i= 0; i < 1000000; i++) tmp += "ST(0,0,0, 1,0,0, 0,1,0){1,2,3};\n"; tmp += "};\n"; _client->SpeedTest(tmp.c_str()); } } void Message::SendOptionOnSocket(int num, std::string option) { if(_client){ _client->Option(num, option.c_str()); } } void Message::FinalizeSocket() { if(_client){ _client->Stop(); _client->Disconnect(); delete _client; _client = 0; } } class localGetDP : public onelab::localClient { public: localGetDP() : onelab::localClient("GetDP") {} #if defined(HAVE_GMSH) void sendMergeFileRequest(const std::string &name) { GmshMergePostProcessingFile(name); Msg::RequestRender(); } void sendInfo(const std::string &msg){ Msg::Info("%s", msg.c_str()); } void sendWarning(const std::string &msg){ Msg::Warning("%s", msg.c_str()); } void sendError(const std::string &msg){ Msg::Error("%s", msg.c_str()); } void sendProgress(const std::string &msg){ Msg::ProgressMeter(0, 0, true, msg.c_str()); } #endif }; void Message::InitializeOnelab(std::string name, std::string sockname) { if(sockname.size()){ // getdp is called by a distant onelab server onelab::remoteNetworkClient *c = new onelab::remoteNetworkClient(name, sockname); if(!c->getGmshClient()){ Error("Could not connect to OneLab server"); delete c; } else{ _onelabClient = c; // send configuration options (we send them even if Action != initialize), // so that they are also sent e.g. when the database is reset onelab::string o(name + "/FileExtension", ".pro"); o.setVisible(false); _onelabClient->set(o); onelab::number o2(name + "/UseCommandLine", 1.); o2.setVisible(false); _onelabClient->set(o2); onelab::number o3(name + "/GuessModelName", 1.); o3.setVisible(false); _onelabClient->set(o3); std::vector ps; _onelabClient->get(ps, name + "/Action"); if(ps.size()){ Info("Performing OneLab '%s'", ps[0].getValue().c_str()); if(ps[0].getValue() == "initialize") Exit(0); } } } else{ if(name == "GetDP"){ // getdp is called within the same memory space as the server _onelabClient = new localGetDP(); } else{ // getdp is called without a connection to a onelab server, but with the // name of a onelab database file; GetDP in this case becomes the onelab // server _onelabClient = new onelab::localClient("GetDPServer"); FILE *fp = FOpen(name.c_str(), "rb"); if(fp){ Message::Info("Reading OneLab database '%s'", name.c_str()); _onelabClient->fromFile(fp); fclose(fp); } else Message::Error("Could not open file '%s'", name.c_str()); } } } void Message::AddOnelabNumberChoice(std::string name, double val, const char *color) { if(_onelabClient){ std::vector choices; std::vector ps; _onelabClient->get(ps, name); if(ps.size()){ choices = ps[0].getChoices(); } else{ ps.resize(1); ps[0].setName(name); ps[0].setReadOnly(true); } if(color) ps[0].setAttribute("Highlight", color); ps[0].setValue(val); choices.push_back(val); ps[0].setChoices(choices); _onelabClient->set(ps[0]); // ask Gmsh to refresh onelab::string o("Gmsh/Action", "refresh"); o.setVisible(false); _onelabClient->set(o); } } void Message::AddOnelabStringChoice(std::string name, std::string kind, std::string value) { if(_onelabClient){ std::vector choices; std::vector ps; _onelabClient->get(ps, name); if(ps.size()){ choices = ps[0].getChoices(); if(std::find(choices.begin(), choices.end(), value) == choices.end()) choices.push_back(value); } else{ ps.resize(1); ps[0].setName(name); ps[0].setKind(kind); choices.push_back(value); } ps[0].setValue(value); ps[0].setChoices(choices); _onelabClient->set(ps[0]); } } void Message::GetOnelabString(std::string name, char **val) { if(_onelabClient){ std::vector ps; _onelabClient->get(ps, name); if(ps.size() && ps[0].getValue().size()){ *val = strSave(ps[0].getValue().c_str()); return; } } *val = 0; } std::string Message::GetOnelabAction() { if(_onelabClient){ std::vector ps; _onelabClient->get(ps, _onelabClient->getName() + "/Action"); if(ps.size()) return ps[0].getValue(); } return ""; } std::string Message::GetOnelabClientName() { if(_onelabClient) return _onelabClient->getName(); return ""; } static std::string _getParameterName(char *Name, Message::cmap &copt) { std::string name(Name); if(copt.count("Path")){ std::string path = copt["Path"][0]; // if path ends with a number, assume it's for ordering purposes if(path.size() && path[path.size() - 1] >= '0' && path[path.size() - 1] <= '9') name = path + name; else if(path.size() && path[path.size() - 1] == '/') name = path + name; else name = path + "/" + name; } return name; } static void _setStandardOptions(onelab::parameter *p, Message::fmap &fopt, Message::cmap &copt) { // strings if(copt.count("Label")) p->setLabel(copt["Label"][0]); if(copt.count("ShortHelp")) // for backward compatibility p->setLabel(copt["ShortHelp"][0]); if(copt.count("Help")) p->setHelp(copt["Help"][0]); if(copt.count("Highlight")) p->setAttribute("Highlight", copt["Highlight"][0]); if(copt.count("Macro")) p->setAttribute("Macro", copt["Macro"][0]); if(copt.count("GmshOption")) p->setAttribute("GmshOption", copt["GmshOption"][0]); if(copt.count("AutoCheck")) // for backward compatibility p->setAttribute("AutoCheck", copt["AutoCheck"][0]); // numbers if(fopt.count("Visible")) p->setVisible(fopt["Visible"][0] ? true : false); if(fopt.count("ReadOnly")) p->setReadOnly(fopt["ReadOnly"][0] ? true : false); if(fopt.count("ReadOnlyRange")) p->setAttribute("ReadOnlyRange", fopt["ReadOnlyRange"][0] ? "1" : "0"); if(fopt.count("AutoCheck")) p->setAttribute("AutoCheck", fopt["AutoCheck"][0] ? "1" : "0"); } void Message::ExchangeOnelabParameter(Constant *c, fmap &fopt, cmap &copt) { if(!_onelabClient) return; std::string name = _getParameterName(c->Name, copt); if(c->Type == VAR_FLOAT){ std::vector ps; _onelabClient->get(ps, name); bool noRange = true, noChoices = true, noLoop = true; bool noGraph = true, noClosed = true; if(ps.size()){ if(fopt.count("ReadOnly") && fopt["ReadOnly"][0]) ps[0].setValue(c->Value.Float); // use local value else c->Value.Float = ps[0].getValue(); // use value from server // keep track of these attributes, which can be changed server-side // (unless they are not visible, or, for the range/choices, when // explicitely setting these attributes as ReadOnly) if(ps[0].getVisible()){ if(!(fopt.count("ReadOnlyRange") && fopt["ReadOnlyRange"][0])){ if(ps[0].getMin() != -onelab::parameter::maxNumber() || ps[0].getMax() != onelab::parameter::maxNumber() || ps[0].getStep() != 0.) noRange = false; if(ps[0].getChoices().size()) noChoices = false; } if(ps[0].getAttribute("Loop").size()) noLoop = false; if(ps[0].getAttribute("Graph").size()) noGraph = false; if(ps[0].getAttribute("Closed").size()) noClosed = false; } } else{ ps.resize(1); ps[0].setName(name); ps[0].setValue(c->Value.Float); } // send updated parameter to server if(noRange && fopt.count("Range") && fopt["Range"].size() == 2){ ps[0].setMin(fopt["Range"][0]); ps[0].setMax(fopt["Range"][1]); } else if(noRange && fopt.count("Min") && fopt.count("Max")){ ps[0].setMin(fopt["Min"][0]); ps[0].setMax(fopt["Max"][0]); } else if(noRange && fopt.count("Min")){ ps[0].setMin(fopt["Min"][0]); ps[0].setMax(onelab::parameter::maxNumber()); } else if(noRange && fopt.count("Max")){ ps[0].setMax(fopt["Max"][0]); ps[0].setMin(-onelab::parameter::maxNumber()); } if(noRange && fopt.count("Step")) ps[0].setStep(fopt["Step"][0]); // if no range/min/max/step info is provided, try to compute a reasonnable // range and step (this makes the gui much nicer to use) if(noRange && !fopt.count("Range") && !fopt.count("Step") && !fopt.count("Min") && !fopt.count("Max")){ bool isInteger = (floor(c->Value.Float) == c->Value.Float); double fact = isInteger ? 10. : 100.; if(c->Value.Float > 0){ ps[0].setMin(c->Value.Float / fact); ps[0].setMax(c->Value.Float * fact); ps[0].setStep((ps[0].getMax() - ps[0].getMin()) / 100.); } else if(c->Value.Float < 0){ ps[0].setMin(c->Value.Float * fact); ps[0].setMax(c->Value.Float / fact); ps[0].setStep((ps[0].getMax() - ps[0].getMin()) / 100.); } if(c->Value.Float && isInteger){ ps[0].setMin((int)ps[0].getMin()); ps[0].setMax((int)ps[0].getMax()); ps[0].setStep((int)ps[0].getStep()); } } if(noChoices && fopt.count("Choices")){ ps[0].setChoices(fopt["Choices"]); if(copt.count("Choices")) ps[0].setChoiceLabels(copt["Choices"]); } if(noLoop && copt.count("Loop")) // for backward compatibility ps[0].setAttribute("Loop", copt["Loop"][0]); if(noLoop && fopt.count("Loop")) ps[0].setAttribute("Loop", (fopt["Loop"][0] == 3.) ? "3" : (fopt["Loop"][0] == 2.) ? "2" : (fopt["Loop"][0] == 1.) ? "1" : ""); if(noGraph && copt.count("Graph")) ps[0].setAttribute("Graph", copt["Graph"][0]); if(noClosed && copt.count("Closed")) // for backward compatibility ps[0].setAttribute("Closed", copt["Closed"][0]); if(noClosed && fopt.count("Closed")) ps[0].setAttribute("Closed", fopt["Closed"][0] ? "1" : "0"); _setStandardOptions(&ps[0], fopt, copt); _onelabClient->set(ps[0]); } else if(c->Type == VAR_CHAR){ std::vector ps; _onelabClient->get(ps, name); bool noClosed = true, noMultipleSelection = true; if(ps.size()){ if(fopt.count("ReadOnly") && fopt["ReadOnly"][0]) ps[0].setValue(c->Value.Char); // use local value else c->Value.Char = strSave(ps[0].getValue().c_str()); // use value from server // keep track of these attributes, which can be changed server-side // (unless they are not visible) if(ps[0].getVisible()){ if(ps[0].getAttribute("Closed").size()) noClosed = false; if(ps[0].getAttribute("MultipleSelection").size()) noMultipleSelection = false; } } else{ ps.resize(1); ps[0].setName(name); ps[0].setValue(c->Value.Char); } // send updated parameter to server if(copt.count("Kind")) ps[0].setKind(copt["Kind"][0]); if(copt.count("Choices")) ps[0].setChoices(copt["Choices"]); if(noClosed && copt.count("Closed")) // for backward compatibility ps[0].setAttribute("Closed", copt["Closed"][0]); if(noClosed && fopt.count("Closed")) // for backward compatibility ps[0].setAttribute("Closed", fopt["Closed"][0] ? "1" : "0"); if(noMultipleSelection && copt.count("MultipleSelection")) ps[0].setAttribute("MultipleSelection", copt["MultipleSelection"][0]); _setStandardOptions(&ps[0], fopt, copt); _onelabClient->set(ps[0]); } } extern void Fill_GroupInitialListFromString(List_T *list, const char *str); void Message::ExchangeOnelabParameter(Group *g, fmap &fopt, cmap &copt) { if(!_onelabClient) return; std::string name = _getParameterName(g->Name, copt); std::vector ps; _onelabClient->get(ps, name); bool noClosed = true; if(ps.size()){ if(fopt.count("ReadOnly") && fopt["ReadOnly"][0]){ // use local value std::vector vec(copt["Strings"]); std::set val; for(unsigned int i = 0; i < vec.size(); i++) val.insert(vec[i]); ps[0].setValue(val); } else{ // use value from server List_Reset(g->InitialList); std::set val(ps[0].getValue()); for(std::set::iterator it = val.begin(); it != val.end(); it++) Fill_GroupInitialListFromString(g->InitialList, it->c_str()); } // keep track of these attributes, which can be changed server-side (unless // they are not visible) if(ps[0].getVisible()){ if(ps[0].getAttribute("Closed").size()) noClosed = false; } } else{ ps.resize(1); ps[0].setName(name); std::vector vec(copt["Strings"]); std::set val; for(unsigned int i = 0; i < vec.size(); i++) val.insert(vec[i]); ps[0].setValue(val); } // send updated parameter to server if(noClosed && copt.count("Closed")) // for backward compatibility ps[0].setAttribute("Closed", copt["Closed"][0]); if(noClosed && fopt.count("Closed")) // for backward compatibility ps[0].setAttribute("Closed", fopt["Closed"][0] ? "1" : "0"); _setStandardOptions(&ps[0], fopt, copt); _onelabClient->set(ps[0]); } void Message::ExchangeOnelabParameter(Expression *e, fmap &fopt, cmap &copt) { if(!_onelabClient) return; std::string name = _getParameterName(e->Name, copt); printf("exchanging function %s with OneLab!\n", name.c_str()); } void Message::UndefineOnelabParameter(const std::string &name) { if(!_onelabClient) return; bool found = false; { // try to clear number with short name == name std::vector ps; _onelabClient->get(ps); for(unsigned int i = 0; i < ps.size(); i++){ if(ps[i].getShortName() == name){ found = true; _onelabClient->clear(ps[i].getName()); } } } if(!found){ // try to clear string with short name == name std::vector ps; _onelabClient->get(ps); for(unsigned int i = 0; i < ps.size(); i++){ if(ps[i].getShortName() == name){ found = true; _onelabClient->clear(ps[i].getName()); } } } if(!found) _onelabClient->clear(name); } void Message::FinalizeOnelab() { if(_onelabClient){ // add default computation modes std::string name = _onelabClient->getName(); std::vector ps; _onelabClient->get(ps, name + "/Action"); if(ps.size()){ if(ps[0].getValue() != "initialize"){ _onelabClient->get(ps, name + "/9ComputeCommand"); if(ps.empty()){ // only change value if none exists ps.resize(1); ps[0].setName(name + "/9ComputeCommand"); ps[0].setValue("-solve -pos"); } ps[0].setLabel("Compute command"); std::vector choices; choices.push_back("-pre"); choices.push_back("-cal"); choices.push_back("-pos"); choices.push_back("-solve"); choices.push_back("-solve -pos"); ps[0].setChoices(choices); _onelabClient->set(ps[0]); } } delete _onelabClient; _onelabClient = 0; } } void Message::Barrier() { #if defined(HAVE_PETSC) if(_isCommWorld) { MPI_Barrier(PETSC_COMM_WORLD); } #endif } #if defined(_OPENMP) #include int Message::GetNumThreads(){ return omp_get_num_threads(); } int Message::GetMaxThreads(){ return omp_get_max_threads(); } int Message::GetThreadNum(){ return omp_get_thread_num(); } #else int Message::GetNumThreads(){ return 1; } int Message::GetMaxThreads(){ return 1; } int Message::GetThreadNum(){ return 0; } #endif getdp-2.4.2-source/Common/CMakeLists.txt000644 001750 001750 00000000610 12116424203 021560 0ustar00geuzainegeuzaine000000 000000 # GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine # # See the LICENSE.txt file for license information. Please report all # bugs and problems to the public mailing list . set(SRC ListUtils.cpp TreeUtils.cpp avl.cpp MallocUtils.cpp Message.cpp OS.cpp ) file(GLOB HDR RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} *.h) append_getdp_src(Common "${SRC};${HDR}") getdp-2.4.2-source/Common/OS.h000644 001750 001750 00000001011 12166744452 017526 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _OS_H_ #define _OS_H_ #include #include FILE *FOpen(const char *f, const char *mode); void GetResources(double *s, long *mem); void IncreaseStackSize(); int BlockingSystemCall(const char *command); int RemoveFile(const std::string &fileName); int CreateDir(const std::string &dirName); #endif getdp-2.4.2-source/Interface/ProData.h000644 001750 001750 00000127161 12166744441 021224 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _PRO_DATA_H_ #define _PRO_DATA_H_ #include #include #include "GetDPConfig.h" #include "ListUtils.h" #define _0D 0 #define _1D 1 #define _2D 2 #define _3D 3 #define _ALL 4 #define _AXI 5 #define NBR_MAX_RES 2500 #define NBR_MAX_POS 10 #define _PRE 1 // pre-processing #define _CAL 2 // processing #define _POS 3 // post-processing #define _CST 5 // update constraint #define TIME_STATIC 1 #define TIME_THETA 2 #define TIME_NEWMARK 3 #define TIME_GEAR 4 #define ASSEMBLY_AGGREGATE 1 #define ASSEMBLY_SEPARATE 2 /* ------------------------------------------------------------------------ */ /* V a l u e */ /* ------------------------------------------------------------------------ */ #define MAX_DIM 9 /* second-rank tensor of order 3 : 3^2 = 9 */ /* Please set NBR_MAX_HARMONIC to the lowest possible value for common getdp versions, until we do dynamic allocation. Otherwise, some postprocessing operations become almost impossible to perform in 3D. */ #if defined(HAVE_MULTIHARMONIC) #define NBR_MAX_HARMONIC 40 #else #define NBR_MAX_HARMONIC 2 #endif #define MAX_STACK_SIZE 40 struct Value { int Type; double Val [NBR_MAX_HARMONIC * MAX_DIM]; }; struct TwoInt { int Int1, Int2; }; /* ------------------------------------------------------------------------ */ /* P r o b l e m */ /* ------------------------------------------------------------------------ */ struct Problem { List_T *Group , *Expression; List_T *FunctionSpace , *Constraint , *Formulation; List_T *JacobianMethod, *IntegrationMethod; List_T *Resolution , *PostProcessing , *PostOperation; }; /* ------------------------------------------------------------------------ */ /* G r o u p */ /* ------------------------------------------------------------------------ */ struct Group { char *Name; int Num, Type, FunctionType, SuppListType; List_T *InitialList, *InitialSuppList; List_T *ExtendedList, *ExtendedSuppList; std::multimap ExtendedListForSearch; struct MovingBand2D *MovingBand2D; }; struct MovingBand2D { List_T *InitialList1, *InitialList2; List_T *ExtendedList1, *ExtendedList2; int NbrNodes1, *NumNodes1, NbrNodes2, *NumNodes2; double *x1, *y1, *z1, *x2, *y2, *z2, Area; int Period2, ntr1, ntr2, Closed1, Closed2; int PhysNum, StartNumTr, StartIndexTr; int *b1_p1, *b1_p2, *b1_p3, *b2_p1, *b2_p2, *b2_p3; }; /* Group.Type */ #define REGIONLIST 1 #define ELEMENTLIST 2 #define MOVINGBAND2D 3 /* Group.FunctionType */ #define REGION 1 #define NODESOF 2 #define EDGESOF 3 #define FACETSOF 4 #define VOLUMESOF 5 #define ELEMENTSOF 6 #define GLOBAL 7 #define GROUPSOFNODESOF 11 #define GROUPSOFEDGESOF 12 #define GROUPSOFFACETSOF 13 #define GROUPSOFEDGESONNODESOF 14 #define EDGESOFTREEIN 21 #define FACETSOFTREEIN 22 #define DUALNODESOF 30 #define DUALEDGESOF 31 #define DUALFACETSOF 32 #define DUALVOLUMESOF 33 #define BOUNDARYOFDUALNODESOF 40 #define BOUNDARYOFDUALEDGESOF 41 #define BOUNDARYOFDUALFACETSOF 42 /* Group.SuppListType */ #define SUPPLIST_NONE 0 #define SUPPLIST_NOT 1 #define SUPPLIST_STARTINGON 2 #define SUPPLIST_ONONESIDEOF 3 #define SUPPLIST_INSUPPORT 4 #define SUPPLIST_CONNECTEDTO 5 /* ------------------------------------------------------------------------ */ /* E x p r e s s i o n */ /* ------------------------------------------------------------------------ */ struct Expression { char *Name; int Type; union { double Constant; List_T *WholeQuantity; struct { List_T *ExpressionPerRegion; int NumLastRegion; struct Expression *ExpressionForLastRegion; } PieceWiseFunction; } Case; }; struct ExpressionPerRegion { int RegionIndex, ExpressionIndex; }; /* Expression.Type */ #define UNDEFINED_EXP 0 #define CONSTANT 1 #define WHOLEQUANTITY 2 #define PIECEWISEFUNCTION 3 /* ------------------------------------------------------------------------ */ /* C o n s t r a i n t */ /* ------------------------------------------------------------------------ */ struct Constraint { char *Name; int Type; List_T *ConstraintPerRegion; List_T *MultiConstraintPerRegion; }; struct ConstraintPerRegion { int Type, RegionIndex, SubRegionIndex, TimeFunctionIndex; union { struct { int ExpressionIndex, ExpressionIndex2; } Fixed; struct { char *ResolutionName; } Solve; struct { int Node1, Node2; } Network; struct { int RegionRefIndex, SubRegionRefIndex; int FilterIndex, CoefIndex, FunctionIndex; int FilterIndex2, CoefIndex2, FunctionIndex2; } Link; } Case; }; struct MultiConstraintPerRegion { char *Name; List_T *ConstraintPerRegion; struct ConstraintActive *Active; }; struct ConstraintActive { int TimeStep, SubTimeStep; union { struct { int NbrNode, NbrBranch, NbrLoop; int **MatNode, **MatLoop; } Network; struct { List_T *Couples; } Link; } Case; }; /* Constraint.Type & ConstraintPerRegion.Type */ #define NONE 0 #define ASSIGN 1 #define INIT 2 #define ASSIGNFROMRESOLUTION 3 #define INITFROMRESOLUTION 4 #define NETWORK 5 #define CST_LINK 6 #define CST_LINKCPLX 7 #define ASSIGN_LOCALPROJ 8 #define INIT_LOCALPROJ 9 /* ------------------------------------------------------------------------ */ /* J a c o b i a n M e t h o d */ /* ------------------------------------------------------------------------ */ struct JacobianMethod { char *Name; List_T *JacobianCase; }; struct JacobianCase { int RegionIndex, TypeJacobian; int NbrParameters; double *Para; }; /* JacobianCase.TypeJacobian */ /* WARNING! The numbering is important (boundary operator -> -1) */ #define JACOBIAN_PNT 0 #define JACOBIAN_LIN 1 #define JACOBIAN_SUR 2 #define JACOBIAN_VOL 3 #define JACOBIAN_SUR_AXI 10 #define JACOBIAN_VOL_AXI 11 #define JACOBIAN_SUR_AXI_SQU 20 #define JACOBIAN_VOL_AXI_SQU 21 #define JACOBIAN_SUR_SPH_SHELL 30 #define JACOBIAN_VOL_SPH_SHELL 31 #define JACOBIAN_SUR_AXI_SPH_SHELL 40 #define JACOBIAN_VOL_AXI_SPH_SHELL 41 #define JACOBIAN_SUR_AXI_SQU_SPH_SHELL 50 #define JACOBIAN_VOL_AXI_SQU_SPH_SHELL 51 #define JACOBIAN_SUR_RECT_SHELL 60 #define JACOBIAN_VOL_RECT_SHELL 61 #define JACOBIAN_SUR_AXI_RECT_SHELL 70 #define JACOBIAN_VOL_AXI_RECT_SHELL 71 #define JACOBIAN_SUR_AXI_SQU_RECT_SHELL 80 #define JACOBIAN_VOL_AXI_SQU_RECT_SHELL 81 #define JACOBIAN_VOL_PLPD_X 90 #define JACOBIAN_VOL_AXI_PLPD_X 100 /* type of transformation */ #define JACOBIAN_SPH 0 #define JACOBIAN_RECT 1 /* ------------------------------------------------------------------------ */ /* I n t e g r a t i o n M e t h o d */ /* ------------------------------------------------------------------------ */ struct IntegrationMethod { char *Name; List_T *IntegrationCase; int CriterionIndex; }; struct IntegrationCase { int Type, SubType; List_T *Case; }; /* IntegrationCase.Type */ #define ANALYTIC 1 #define GAUSS 2 #define GAUSSLEGENDRE 3 /* IntegrationCase.SubType */ #define STANDARD 1 #define SINGULAR 2 #define ADAPTATIVE 3 struct Quadrature { int ElementType; int NumberOfPoints, MaxNumberOfPoints; int NumberOfDivisions, MaxNumberOfDivisions; double StoppingCriterion; void (*Function)(); }; /* ------------------------------------------------------------------------ */ /* F u n c t i o n S p a c e */ /* ------------------------------------------------------------------------ */ struct FunctionSpace { char *Name; int Type; List_T *BasisFunction, *SubSpace, *GlobalQuantity, *Constraint; struct DofData *DofData, *MainDofData; }; struct BasisFunction { char *Name, *NameOfCoef; List_T *GlobalBasisFunction; int Dimension, Num; void (*Function)(); void (*dFunction)(); void (*dInvFunction)(); List_T *SubFunction, *SubdFunction; int SupportIndex, EntityIndex; double Order; int ElementType; int Orient; }; struct GlobalBasisFunction { int EntityIndex; /* Must be the first element of the structure */ int FormulationIndex, DefineQuantityIndex, ResolutionIndex; struct QuantityStorage *QuantityStorage; }; /* BasisFunction.Type */ /* WARNING! The numbering is important (exterior derivative -> +1) */ #define FORM0 0 #define FORM1 1 #define FORM2 2 #define FORM3 3 #define FORM0S 4 #define FORM1S 5 #define FORM2S 6 #define FORM3S 7 #define FORM0P 10 #define FORM1P 11 #define FORM2P 12 #define FORM3P 13 #define SCALAR 20 #define VECTOR 21 #define TENSOR 22 /* second-rank tensor of order 3 */ #define TENSOR_SYM 23 #define TENSOR_DIAG 24 #define TENSOR_MH 25 /* VECTOR TENSOR_DIAG TENSOR_SYM TENSOR |0| |0 | |0 1 2| |0 1 2| |1| | 1 | |s 3 4| |3 4 5| |2| | 2| |s s 5| |6 7 8| */ #define VECTORP 31 struct SubSpace { char *Name; List_T *BasisFunction; }; struct GlobalQuantity { char *Name; int Num, Type, ReferenceIndex; }; /* GlobalQuantity.Type */ #define ALIASOF 1 #define ASSOCIATEDWITH 2 struct ConstraintInFS { int QuantityType, ReferenceIndex, EntityIndex; struct ConstraintPerRegion *ConstraintPerRegion; struct { int ResolutionIndex; struct ConstraintActive *Active; } Active; /* a deplacer lorsque sera necessaire */ }; /* ConstraintInFS.QuantityType */ #define LOCALQUANTITY 1 #define GLOBALQUANTITY 2 #define INTEGRALQUANTITY 3 #define NODOF 4 /* ------------------------------------------------------------------------ */ /* F u n c t i o n */ /* ------------------------------------------------------------------------ */ struct Function { void (*Fct)(); /* ANSI C++ forbids data member `Function' with same name as enclosing class */ int TypeOfValue, NbrArguments, NbrParameters; double *Para; struct FunctionActive *Active; }; struct FunctionActive { union { struct { int NbrPoint; double *x, *y, *xc, *yc; double *mi, *bi, *ci, *di; /* Akima */ } Interpolation; struct { double Value; } SurfaceArea; struct { double Value; } GetVolume; struct { List_T *Table; } ValueFromIndex; struct { int NbrLines, NbrColumns; double *x, *y ; double *data ; } ListMatrix; } Case; }; /* ------------------------------------------------------------------------ */ /* F o r m u l a t i o n */ /* ------------------------------------------------------------------------ */ struct Formulation { char *Name; int Type; List_T *DefineQuantity, *Equation; }; /* Formulation.Type */ #define FEMEQUATION 1 #define BEMEQUATION 2 #define GLOBALEQUATION 3 struct IntegralQuantity { List_T *WholeQuantity; int DofIndexInWholeQuantity; int TypeOperatorDof, DefineQuantityIndexDof; int DefineQuantityIndexNoDof; int NbrQuantityIndex, *QuantityIndexTable; int *QuantityTraceGroupIndexTable ; int InIndex; int IntegrationMethodIndex, JacobianMethodIndex; int Symmetry; int CanonicalWholeQuantity, ExpressionIndexForCanonical; struct Function FunctionForCanonical, AnyFunction; }; struct IntegralQuantityActive { int Type_FormDof, Type_ValueDof; List_T *IntegrationCase_L; struct IntegrationCase *IntegrationCase_P; int CriterionIndex; void (*Get_IntPoint)(); int Nbr_IntPoints; List_T *JacobianCase_L; double (*Get_Jacobian)(); int Type_Dimension; void (*xChangeOfCoordinates)(); }; struct FirstElement { struct Dof *Equ; struct Dof *Dof; double Value; }; struct DefineQuantity { char *Name; int Type; int FunctionSpaceIndex; /* for subspaces */ List_T *IndexInFunctionSpace; /* for MH calculation */ List_T *DummyFrequency; /* for multiple DofData vs. one FunctionSpace */ int DofDataIndex; struct DofData *DofData; /* for integral quantities */ struct IntegralQuantity IntegralQuantity; }; // second order hex with 3 BFs per node for elasticity #define NBR_MAX_BASISFUNCTIONS 81 struct QuantityStorage { struct DefineQuantity *DefineQuantity; int NumLastElementForFunctionSpace; int NumLastElementForDofDefinition; int NumLastElementForEquDefinition; struct FunctionSpace *FunctionSpace; int NbrElementaryBasisFunction; int TypeQuantity; struct { struct Dof *Dof; int NumEntityInElement; int CodeBasisFunction, CodeEntity; int CodeAssociateBasisFunction; int Constraint; int Constraint_Index; double Value[NBR_MAX_HARMONIC]; double Value2[NBR_MAX_HARMONIC]; // for two-step INIT int TimeFunctionIndex; int CodeEntity_Link; struct BasisFunction *BasisFunction; } BasisFunction [NBR_MAX_BASISFUNCTIONS]; }; /* DefineQuantity.Type */ /* LOCALQUANTITY GLOBALQUANTITY INTEGRALQUANTITY */ struct EquationTerm { int Type; union { struct FemLocalTerm { struct { int TypeTimeDerivative; List_T *WholeQuantity; int DofIndexInWholeQuantity; int CanonicalWholeQuantity, ExpressionIndexForCanonical; struct Function FunctionForCanonical; int CanonicalWholeQuantity_Equ, ExpressionIndexForCanonical_Equ, OperatorTypeForCanonical_Equ; void (*BuiltInFunction_Equ)(); int NbrQuantityIndex, *QuantityIndexTable, QuantityIndexPost; int *QuantityTraceGroupIndexTable; int TypeOperatorEqu, DefineQuantityIndexEqu; int TypeOperatorDof, DefineQuantityIndexDof; int DefineQuantityIndexNoDof, DofInTrace; } Term; int InIndex; int Full_Matrix; int IntegrationMethodIndex, JacobianMethodIndex; int ExpressionIndexForMetricTensor; int MatrixIndex; struct FemLocalTermActive *Active; } LocalTerm; struct FemGlobalTerm { int TypeTimeDerivative; int DefineQuantityIndex; struct { int TypeTimeDerivative; List_T *WholeQuantity; int DofIndexInWholeQuantity; int CanonicalWholeQuantity, ExpressionIndexForCanonical; int NbrQuantityIndex, *QuantityIndexTable; int *QuantityTraceGroupIndexTable ; int TypeOperatorEqu, DefineQuantityIndexEqu; int TypeOperatorDof, DefineQuantityIndexDof; int DefineQuantityIndexNoDof; } Term; int InIndex; } GlobalTerm; struct GlobalEquation { int Type, ConstraintIndex; List_T *GlobalEquationTerm; } GlobalEquation; } Case; }; struct FemLocalTermActive { struct QuantityStorage *QuantityStorageEqu_P; struct QuantityStorage *QuantityStorageDof_P; struct Dof *DofForNoDof_P; int Type_FormEqu, Type_FormDof, Type_ValueDof; int Type_DefineQuantityDof; int SymmetricalMatrix; List_T *IntegrationCase_L, *JacobianCase_L; int CriterionIndex; struct JacobianCase *JacobianCase_P0; int NbrJacobianCase, Flag_ChangeCoord, Flag_InvJac; void (*xChangeOfCoordinatesEqu)(); void (*xChangeOfCoordinatesDof)(); double (*Cal_Productx)(); void (*Function_AssembleTerm)(); struct IntegralQuantityActive IntegralQuantityActive; int MHJacNL, MHJacNL_Index, MHJacNL_NbrPointsX, MHJacNL_HarOffSet; double MHJacNL_Factor; double **MHJacNL_H, ***MHJacNL_HH, *MHJacNL_t, *MHJacNL_w; int Full_Matrix; int NbrEqu, NbrHar, *NumEqu, *NumDof; struct Dof *Equ, *Dof; List_T *FirstElements; double **Matrix; }; struct GlobalQuantityStorage { int NumEquation; int NumDof; int CodeGlobalQuantity, CodeAssociateBasisFunction; int CodeEntity; int Constraint; double Value[NBR_MAX_HARMONIC]; int TimeFunctionIndex; }; struct GlobalEquationTerm { int DefineQuantityIndexNode, DefineQuantityIndexLoop; int DefineQuantityIndexEqu; int InIndex; }; /* EquationTerm.Type */ #define GALERKIN 1 #define GLOBALTERM 2 #define GLOBALEQUATION 3 #define DERHAM 4 /* Term.TypeOfTimeDerivative */ #define NODT_ 0 #define DT_ 1 #define DTDOF_ 2 #define DTDT_ 3 #define DTDTDOF_ 4 #define JACNL_ 10 #define NEVERDT_ 11 #define DTNL_ 12 #define DTDOFJACNL_ 13 /* Term.TypeOperator */ #define NOOP 0 #define EXTDER 1 #define GRAD 2 #define CURL 3 #define DIV 4 #define EXTDERINV 5 #define GRADINV 6 #define CURLINV 7 #define DIVINV 8 /* Tous ces operateurs de trace ne servent a RIEN pour le moment De plus, les 'x' sont ambigus. Il faut penser a definir des operateurs de trace (T ou T*), qui doivent avoir, outre \Gamma=\partial\Omega, l'info concernant \Omega. */ #define NPx 9 #define NPxEXTDER 10 #define NPxGRAD 11 #define NPxCURL 12 #define NPxDIV 13 #define NSx 14 #define NSxEXTDER 15 #define NSxGRAD 16 #define NSxCURL 17 #define NSxDIV 18 #define _D1 21 #define _D2 22 /* CanonicalWholeQuantity */ #define CWQ_NONE 0 #define CWQ_DOF 1 #define CWQ_EXP_TIME_DOF 2 #define CWQ_FCT_TIME_DOF 3 #define CWQ_FCT_PVEC_DOF 4 #define CWQ_FCT_DOF 20 #define CWQ_GF 5 #define CWQ_GF_PSCA_DOF 6 #define CWQ_GF_PSCA_EXP 7 #define CWQ_GF_PVEC_DOF 8 #define CWQ_DOF_PVEC_GF 9 #define CWQ_GF_PVEC_EXP 10 #define CWQ_EXP_PVEC_GF 11 #define CWQ_EXP_TIME_GF_PSCA_DOF 12 #define CWQ_EXP_TIME_GF_PVEC_DOF 13 #define CWQ_EXP_PVEC_GF_PSCA_DOF 14 #define CWQ_EXP_PVEC_GF_PVEC_DOF 15 #define CWQ_FCT_TIME_GF_PSCA_DOF 16 #define CWQ_FCT_TIME_GF_PVEC_DOF 17 #define CWQ_FCT_PVEC_GF_PSCA_DOF 18 #define CWQ_FCT_PVEC_GF_PVEC_DOF 19 /* ------------------------------------------------------------------------ */ /* W h o l e Q u a n t i t y */ /* ------------------------------------------------------------------------ */ struct WholeQuantity { int Type; union { double Constant; struct Function Function; struct { int TypeOperator, Index, NbrArguments; int TypeQuantity; } OperatorAndQuantity; struct { int Index, NbrArguments; } Expression; struct { List_T *WholeQuantity; } TimeDerivative; struct { List_T *WholeQuantity; int TimeStep; } AtAnteriorTimeStep; struct { double *Value; } CurrentValue; struct { int Index; } Argument; struct { List_T *WholeQuantity_True, *WholeQuantity_False; } Test; struct { int Index; } SaveValue; struct { int Index; } ShowValue; struct { int Index; } ValueSaved; struct { int TypeOperator; void (*Function)(); } Operator; /* binary or unary */ struct { List_T *WholeQuantity; int FunctionSpaceIndexForType, NbrHar; } Cast; struct { List_T *WholeQuantity ; } ChangeCurrentPosition ; struct { List_T *WholeQuantity ; int InIndex, DofIndexInWholeQuantity; } Trace; struct { char *SystemName; int DefineSystemIndex; int DofNumber; } DofValue; struct { List_T *WholeQuantity; int Index, NbrPoints; } MHTransform; struct { int Index, NbrPoints, FreqOffSet; } MHJacNL; } Case; }; /* WholeQuantity.Type */ #define WQ_OPERATORANDQUANTITY 1 #define WQ_OPERATORANDQUANTITYEVAL 2 #define WQ_BINARYOPERATOR 3 #define WQ_UNARYOPERATOR 4 #define WQ_EXPRESSION 5 #define WQ_BUILTINFUNCTION 6 #define WQ_EXTERNBUILTINFUNCTION 7 #define WQ_CONSTANT 8 #define WQ_CURRENTVALUE 9 #define WQ_ARGUMENT 10 #define WQ_TIMEDERIVATIVE 11 #define WQ_CAST 12 #define WQ_TEST 13 #define WQ_SAVEVALUE 14 #define WQ_VALUESAVED 15 #define WQ_SOLIDANGLE 16 #define WQ_TRACE 17 #define WQ_ORDER 18 #define WQ_MHTIMEINTEGRATION 19 #define WQ_MHTRANSFORM 199 #define WQ_SHOWVALUE 20 #define WQ_MHTIMEEVAL 211 #define WQ_MHJACNL 212 #define WQ_POSTSAVE 214 #define WQ_ATANTERIORTIMESTEP 22 #define WQ_CHANGECURRENTPOSITION 30 /* TypeOperator */ #define OP_PLUS 1 #define OP_MINUS 2 #define OP_TIME 3 #define OP_DIVIDE 4 #define OP_MODULO 5 #define OP_POWER 6 #define OP_CROSSPRODUCT 7 #define OP_LESS 8 #define OP_GREATER 9 #define OP_LESSOREQUAL 10 #define OP_GREATEROREQUAL 11 #define OP_EQUAL 12 #define OP_NOTEQUAL 13 #define OP_APPROXEQUAL 14 #define OP_AND 15 #define OP_OR 16 #define OP_NEG 17 #define OP_NOT 18 /* OperatorAndQuantity.TypeQuantity */ #define QUANTITY_SIMPLE 1 #define QUANTITY_DOF 2 #define QUANTITY_NODOF 3 #define QUANTITY_BF 4 /* ------------------------------------------------------------------------ */ /* R e s o l u t i o n */ /* ------------------------------------------------------------------------ */ struct Resolution { char *Name; List_T *DefineSystem, *Operation; }; struct DefineSystem { char *Name; int Type; List_T *FormulationIndex, *FrequencyValue; char *SolverDataFileName; char *MeshName, *AdaptName; List_T *OriginSystemIndex; char *DestinationSystemName; int DestinationSystemIndex; }; /* DefineSystem.Type */ #define VAL_REAL 1 #define VAL_COMPLEX 2 struct Operation { int Type, DefineSystemIndex, Rank; union { struct { List_T *MatrixIndex_L; } GenerateOnly; struct { int DefineSystemIndex; } SolveAgainWithOther; struct { char *String; } SystemCommand; struct { char *FileName; int ViewTag; } GmshRead; struct { char *FileName; } DeleteFile; struct { char *DirName; } CreateDir; struct { int ExpressionIndex; } SetTime; struct { int ExpressionIndex; } Update; struct { int GroupIndex, Type; } UpdateConstraint; struct { int ExpressionIndex; } SetFrequency; struct { List_T *Frequency; int DefineSystemIndex[2]; } FourierTransform; struct { int DefineSystemIndex[2]; double Period, Period_sofar; double *Scales; } FourierTransform2; struct { int Size; List_T *Save; double Shift; } Lanczos; struct { int NumEigenvalues; double Shift_r, Shift_i; } EigenSolve; struct { int ExpressionIndex; } Evaluate; struct { int Iteration ; } SelectCorrection ; struct { double Alpha ; } AddCorrection ; struct { double Alpha ; } MultiplySolution ; struct { int Size; List_T *Save; double Shift; int PertFreq; int DefineSystemIndex2, DefineSystemIndex3; } Perturbation; struct { double Time0, TimeMax; int DTimeIndex, ThetaIndex; List_T *Operation; } TimeLoopTheta; struct { double Time0, TimeMax, Beta, Gamma; int DTimeIndex; List_T *Operation; } TimeLoopNewmark; struct { double Time0, TimeMax; List_T *ButcherA, *ButcherB, *ButcherC; int DTimeIndex; } TimeLoopRungeKutta; struct { double Time0, TimeMax, DTimeInit, DTimeMin, DTimeMax; double LTEtarget, DTimeMaxScal, DTimeScal_NotConverged; char *Scheme; List_T *Breakpoints_L; List_T *TimeLoopAdaptiveSystems_L; List_T *TimeLoopAdaptivePOs_L; List_T *Operation, *OperationEnd; } TimeLoopAdaptive; struct { double Criterion; int NbrMaxIteration, RelaxationFactorIndex, Flag; List_T *IterativeLoopSystems_L; List_T *IterativeLoopPOs_L; List_T *Operation; } IterativeLoop; struct { double Criterion, DivisionCoefficient; int NbrMaxIteration, Flag; List_T *ChangeOfState; List_T *Operation, *OperationEnd; } IterativeTimeReduction; struct { char *OpMatMult; char *Type; double Tolerance; int MaxIter; int Restart; List_T *MyFieldTag; List_T *NeighborFieldTag; List_T *DeflationIndices; List_T *Operations_Ax, *Operations_Mx; } IterativeLinearSolver; struct { int ExpressionIndex; List_T *Operation_True, *Operation_False; } Test; struct { List_T *DofNumber, *TimeStep, *Expression; char *FileOut; } Print; struct { int GroupIndex, ExpressionIndex; int NumNode, ExpressionIndex2; } ChangeOfCoordinates; struct { int CheckAll; List_T *Factor_L; } SolveJac_AdaptRelax; struct{ int GroupIndex; bool SaveFixed; } SaveSolutionWithEntityNum; struct { int NbrFreq; char *ResFile; } SaveSolutionExtendedMH; struct { List_T *Time; char *ResFile; } SaveSolutionMHtoTime; struct { List_T *PostOperations; } PostOperation; struct { int GroupIndex; } Init_MovingBand2D; struct { int GroupIndex; } Mesh_MovingBand2D; struct { int GroupIndex; double Period; int NbrStep; List_T *Operation; } Generate_MH_Moving; struct { int GroupIndex; double Period; int NbrStep; List_T *Operation; } Generate_MH_Moving_S; struct { double dummy; } Add_MH_Moving; struct { int GroupIndex; } Generate; struct { int GroupIndex; char *FileName; int ExprIndex; } SaveMesh; struct { char *Quantity; char *Name_MshFile; int GeoDataIndex; double Factor; } DeformeMesh; // FIXME: Roman struct { List_T *SystemIndex, *ExpectationIndex; List_T *LocalMatrixIndex; List_T *ExpansionCoef; } TensorProductSolve; } Case; }; struct ChangeOfState { int Type; int QuantityIndex, InIndex, FormulationIndex; double Criterion; double *ActiveList[2]; int ExpressionIndex, ExpressionIndex2, FlagIndex; }; struct TimeLoopAdaptiveSystem { int SystemIndex; double SystemLTEreltol; double SystemLTEabstol; int NormType; char *NormTypeString; }; struct LoopErrorPostOperation { char *PostOperationName; int PostOperationIndex; double PostOperationReltol; double PostOperationAbstol; int NormType; char *NormTypeString; List_T *Save_Format_L, *Save_LastTimeStepOnly_L; List_T *Save_FileOut_L; }; struct IterativeLoopSystem { int SystemIndex; double SystemILreltol; double SystemILabstol; int NormType; char *NormTypeString; int NormOf; char *NormOfString; }; /* Operation.Type */ #define OPERATION_NONE 0 #define OPERATION_GENERATE 1 #define OPERATION_SOLVE 2 #define OPERATION_SOLVEAGAIN 223 #define OPERATION_SOLVEAGAINWITHOTHER 225 #define OPERATION_SOLVENL 233 #define OPERATION_GENERATEJAC 3 #define OPERATION_GENERATERHS 100 #define OPERATION_GENERATEONLY 101 #define OPERATION_GENERATEONLYJAC 103 #define OPERATION_SOLVEJAC 4 #define OPERATION_SOLVEJACAGAIN 224 #define OPERATION_SOLVEJACADAPTRELAX 888 #define OPERATION_GENERATESEPARATE 5 #define OPERATION_UPDATE 6 #define OPERATION_UPDATECONSTRAINT 7 #define OPERATION_LANCZOS 8 #define OPERATION_PERTURBATION 9 #define OPERATION_EIGENSOLVE 16 #define OPERATION_EIGENSOLVEJAC 17 #define OPERATION_EVALUATE 18 #define OPERATION_SELECTCORRECTION 80 #define OPERATION_ADDCORRECTION 81 #define OPERATION_INITCORRECTION 82 #define OPERATION_MULTIPLYSOLUTION 83 #define OPERATION_ADDOPPOSITEFULLSOLUTION 84 #define OPERATION_TENSORPRODUCTSOLVE 85 #define OPERATION_SAVESOLUTION 10 #define OPERATION_SAVESOLUTIONS 11 #define OPERATION_SAVESOLUTION_WITH_ENTITY_NUM 121 #define OPERATION_SAVESOLUTIONEXTENDEDMH 111 #define OPERATION_SAVESOLUTIONMHTOTIME 131 #define OPERATION_INIT_MOVINGBAND2D 444 #define OPERATION_MESH_MOVINGBAND2D 222 #define OPERATION_GENERATE_MH_MOVING 999 #define OPERATION_GENERATE_MH_MOVING_S 9991 #define OPERATION_ADD_MH_MOVING 9992 #define OPERATION_DUMMYDOFS 9993 #define OPERATION_SAVEMESH 333 #define OPERATION_DEFORMEMESH 334 #define OPERATION_READSOLUTION 12 #define OPERATION_TRANSFERSOLUTION 13 #define OPERATION_INITSOLUTION 15 #define OPERATION_INITSOLUTION1 115 #define OPERATION_SETCURRENTSYSTEM 70 #define OPERATION_SETTIME 20 #define OPERATION_SETFREQUENCY 21 #define OPERATION_TEST 22 #define OPERATION_FOURIERTRANSFORM 23 #define OPERATION_FOURIERTRANSFORM2 777 #define OPERATION_BREAK 24 #define OPERATION_PRINT 25 #define OPERATION_WRITE 26 #define OPERATION_SCAN 27 #define OPERATION_READ 28 #define OPERATION_TIMELOOPTHETA 30 #define OPERATION_TIMELOOPNEWMARK 31 #define OPERATION_ITERATIVELOOP 32 #define OPERATION_ITERATIVETIMEREDUCTION 33 #define OPERATION_TIMELOOPRUNGEKUTTA 34 #define OPERATION_ITERATIVELINEARSOLVER 35 #define OPERATION_TIMELOOPADAPTIVE 36 #define OPERATION_ITERATIVELOOPN 37 #define OPERATION_CHANGEOFCOORDINATES 40 #define OPERATION_CHANGEOFCOORDINATES2 400 #define OPERATION_SYSTEMCOMMAND 50 #define OPERATION_POSTOPERATION 60 #define OPERATION_GMSHREAD 61 #define OPERATION_GMSHCLEARALL 62 #define OPERATION_DELETEFILE 71 #define OPERATION_CREATEDIR 72 #define OPERATION_SETCOMMSELF 63 #define OPERATION_SETCOMMWORLD 64 #define OPERATION_BARRIER 65 /* ChangeOfState.Type */ #define CHANGEOFSTATE_NOCHANGE 0 #define CHANGEOFSTATE_CHANGESIGN 1 #define CHANGEOFSTATE_CHANGELEVEL 2 #define CHANGEOFSTATE_CHANGEREFERENCE 3 #define CHANGEOFSTATE_CHANGEREFERENCE2 4 /* TimeLoopAdaptiveSystem.NormType */ #define LINFNORM 1 #define L1NORM 2 #define MEANL1NORM 3 #define L2NORM 4 #define MEANL2NORM 5 /* IterativeLoopSystem.NormOf */ #define SOLUTION 1 #define RESIDUAL 2 #define RECALCRESIDUAL 3 /* ------------------------------------------------------------------------ */ /* P r e R e s o l u t i o n I n f o */ /* ------------------------------------------------------------------------ */ struct PreResolutionInfo { int Index, Type ; } ; /* Type PreResolution */ #define PR_CONSTRAINT 1 #define PR_GLOBALBASISFUNCTION 2 /* ------------------------------------------------------------------------ */ /* P o s t P r o c e s s i n g */ /* ------------------------------------------------------------------------ */ struct PostProcessing { char *Name; int FormulationIndex; List_T *OriginSystemIndex; char *NameOfSystem; List_T *PostQuantity; int Rank; }; struct PostQuantity { char *Name; List_T *PostQuantityTerm; }; struct PostQuantityTerm { int Type, EvaluationType; int TypeTimeDerivative; List_T *WholeQuantity; int NbrQuantityIndex, *QuantityIndexTable; int *QuantityTraceGroupIndexTable; int InIndex, JacobianMethodIndex, IntegrationMethodIndex; }; /* PostQuantityTerm.Type */ /* LOCALQUANTITY GLOBALQUANTITY INTEGRALQUANTITY */ /* PostQuantityTerm.EvaluationType */ #define LOCAL 1 #define INTEGRAL 2 /* ------------------------------------------------------------------------ */ /* P o s t O p e r a t i o n */ /* ------------------------------------------------------------------------ */ struct PostOperation { char *Name, *AppendString; int PostProcessingIndex, Format; List_T *PostSubOperation; int Rank; double ResampleTimeStart, ResampleTimeStop, ResampleTimeStep; bool ResampleTime; }; struct PostSubOperation { int PostQuantityIndex[2], PostQuantitySupport[2]; int Type, SubType, CombinationType; int Depth, Skin, Smoothing, Dimension, Comma, HarmonicToTime, CatFile; int Format, Adapt, Sort, Iso, NoNewLine, NoTitle, DecomposeInSimplex; int NewCoordinates; char *NewCoordinatesFile; int ValueIndex; int ChangeOfCoordinates[3], LastTimeStepOnly, AppendTimeStepToFileName; int OverrideTimeStepValue, NoMesh; int StoreInRegister; char *SendToServer, *Color; int StoreInField; int Legend, FrozenTimeStepList; double LegendPosition[3]; double Target; char *ValueName, *Label; char *FileOut; List_T *TimeStep_L, *Value_L, *Iso_L, *Frequency_L; List_T *ChangeOfValues; List_T *EvaluationPoints; union { struct { int RegionIndex; } OnRegion; struct { double x[4], y[4], z[4]; int n[3]; } OnGrid; struct { int ExpressionIndex[3]; List_T *ParameterValue[3]; } OnParamGrid; struct { double x[3], y[3], z[3]; } OnSection; struct { int RegionIndex, ArgumentIndex; double x[2]; int n; } WithArgument; struct { int ExtendedGroupIndex, GroupIndex; } Group; struct { char *String; char *String2; int ExpressionIndex; } Expression; } Case; }; struct PostOpSolutions { PostOperation *PostOperation_P; List_T *Solutions_L; }; /* PostOperation.Type */ #define POP_NONE 0 #define POP_PRINT 1 #define POP_GROUP 2 #define POP_EXPRESSION 4 /* PostOperation.SubType */ #define PRINT_ONREGION 1 #define PRINT_ONELEMENTSOF 2 #define PRINT_ONSECTION_1D 3 #define PRINT_ONSECTION_2D 4 #define PRINT_ONGRID 5 #define PRINT_ONGRID_0D 6 #define PRINT_ONGRID_1D 7 #define PRINT_ONGRID_2D 8 #define PRINT_ONGRID_3D 9 #define PRINT_ONGRID_PARAM 10 #define PRINT_WITHARGUMENT 11 /* PostOperation.CombinationType */ #define ADDITION 1 #define SOUSTRACTION 2 #define MULTIPLICATION 3 #define DIVISION 4 /* Unsuccessful search results */ #define NO_BRICK -999 #define NO_ELEMENT -999 #define NO_REGION -999 /* PostSubOperation Tags */ #define TAG_TIME 1 #define TAG_TIMESTEP 2 #define TAG_VALUE 3 #define TAG_X 4 #define TAG_Y 5 #define TAG_Z 6 #define TAG_NODES 7 #define TAG_TYPE 8 #define TAG_VERSION 9 #define TAG_DATE 10 #define TAG_HOST 11 #define TAG_FILENAME 12 #define TAG_USER 13 #define TAG_ABSCISSA 14 #define TAG_NORMAL 15 #define TAG_COMMAND 16 /* PostSubOperation.Format */ #define FORMAT_SPACE_TABLE 1 #define FORMAT_TIME_TABLE 2 #define FORMAT_SIMPLE_SPACE_TABLE 3 #define FORMAT_FREQUENCY_TABLE 4 #define FORMAT_VALUE_ONLY 5 #define FORMAT_ADAPT 9 #define FORMAT_GMSH 10 #define FORMAT_GMSH_PARSED 11 #define FORMAT_MATLAB 14 #define FORMAT_GNUPLOT 15 #define FORMAT_REGION_TABLE 16 #define FORMAT_REGION_VALUE 17 #define FORMAT_UNV 18 #define FORMAT_NODE_TABLE 19 #define FORMAT_LOOP_ERROR 20 /* PostSubOperation.Sort */ #define SORT_BY_POSITION 1 #define SORT_BY_CONNECTIVITY 2 /* PostSubOperation.Legend */ #define LEGEND_NONE 0 #define LEGEND_TIME 1 #define LEGEND_FREQUENCY 2 #define LEGEND_EIGENVALUES 3 /* ------------------------------------------------------------------------ */ /* C u r r e n t D a t a */ /* ------------------------------------------------------------------------ */ struct CurrentData { char *Name; int NbrSystem, NbrCpu, RankCpu; struct DefineSystem *DefineSystem_P ; struct DofData *DofData_P0; struct DofData *DofData; struct GeoData *GeoData; //PostOperation based solutions for TimeLoopAdaptive, IterativeLoopN List_T *PostOpData_L; int PostOpDataIndex; int NbrHar; int Region, SubRegion; int NumEntity, NumEntityInElement; int NumEntities[NBR_MAX_BASISFUNCTIONS]; struct Element *Element; int IntegrationSupportIndex; struct Element *ElementSource; int SourceIntegrationSupportIndex; int TypeTime, TypeAssembly; int SubTimeStep; int flagAssDiag; // All values below must be double double x, y, z; double u, v, w; double xs, ys, zs; double us, vs, ws; double a, b, c; double xp, yp, zp; double ut, vt, wt; double Val[NBR_MAX_HARMONIC * MAX_DIM]; // For TimeLoopTheta and TimeLoopNewmark double Time, TimeImag, TimeStep, DTime; double Theta, Beta, Gamma; // For TimeLoopAdaptive double PredOrder, CorrOrder; double aPredCoeff[7], aCorrCoeff[6], bCorrCoeff, PredErrorConst, CorrErrorConst; double Breakpoint; // For IterativeLoop double Iteration, RelativeDifference, RelativeDifferenceOld; double RelaxationFactor; }; /* ------------------------------------------------------------------------ */ /* E l e m e n t */ /* ------------------------------------------------------------------------ */ #define NBR_MAX_NODES_IN_ELEMENT 60 #define NBR_MAX_ENTITIES_IN_ELEMENT 60 #define NBR_MAX_GROUPS_IN_ELEMENT 60 #define NBR_MAX_SUBENTITIES_IN_ELEMENT 5 struct IntxList { int Int ; List_T * List ; } ; struct Matrix3x3 { double c11, c12, c13 ; double c21, c22, c23 ; double c31, c32, c33 ; } ; typedef struct Matrix3x3 MATRIX3x3 ; struct Element { struct Geo_Element * GeoElement ; int Num, Type, Region ; struct Element * ElementSource, * ElementTrace ; int NumLastElementForNodesCoordinates ; double x [NBR_MAX_NODES_IN_ELEMENT] ; double y [NBR_MAX_NODES_IN_ELEMENT] ; double z [NBR_MAX_NODES_IN_ELEMENT] ; int NumLastElementForSolidAngle ; double angle [NBR_MAX_NODES_IN_ELEMENT] ; int NumLastElementForSortedNodesByFacet ; struct TwoInt SortedNodesByFacet [6][NBR_MAX_SUBENTITIES_IN_ELEMENT] ; double n [NBR_MAX_NODES_IN_ELEMENT] ; double dndu [NBR_MAX_NODES_IN_ELEMENT] [3] ; struct JacobianCase * JacobianCase ; MATRIX3x3 Jac ; double DetJac ; MATRIX3x3 InvJac ; int NumLastElementForGroupsOfEntities ; int NbrGroupsOfEntities ; int NumGroupsOfEntities [NBR_MAX_GROUPS_IN_ELEMENT] ; int NbrEntitiesInGroups [NBR_MAX_GROUPS_IN_ELEMENT] ; int NumEntitiesInGroups [NBR_MAX_GROUPS_IN_ELEMENT] [NBR_MAX_ENTITIES_IN_ELEMENT] ; int NumSubFunction [3][NBR_MAX_GROUPS_IN_ELEMENT] ; struct GlobalBasisFunction * GlobalBasisFunction [NBR_MAX_GROUPS_IN_ELEMENT] ; } ; /* Element.Type */ #define POINT (1<<0) #define LINE (1<<1) #define TRIANGLE (1<<2) #define QUADRANGLE (1<<3) #define TETRAHEDRON (1<<4) #define HEXAHEDRON (1<<5) #define PRISM (1<<6) #define PYRAMID (1<<7) #define LINE_2 (1<<8) #define TRIANGLE_2 (1<<9) #define QUADRANGLE_2 (1<<10) #define TETRAHEDRON_2 (1<<11) #define HEXAHEDRON_2 (1<<12) #define PRISM_2 (1<<13) #define PYRAMID_2 (1<<14) #define QUADRANGLE_2_8N (1<<16) /* Adapt.Type */ #define P1 1 #define P2 2 #define H1 3 #define H2 4 struct Geo_Node { int Num ; double x, y, z ; } ; struct Geo_Element { int Num ; int Type, Region, ElementaryRegion ; int NbrNodes , * NumNodes ; int NbrEdges , * NumEdges ; int NbrFacets, * NumFacets ; } ; struct Entity2XEntity1 { int Num ; int NbrEntities, * NumEntities ; } ; struct EntityXVector { int Num; double Vector[3]; } ; struct EntityInTree { int Num, Index ; } ; /* ------------------------------------------------------------------------ */ /* I n t e r f a c e F u n c t i o n s */ /* ------------------------------------------------------------------------ */ int fcmp_Integer (const void *a, const void *b); int fcmp_Constant (const void *a, const void *b); int fcmp_Expression_Name (const void *a, const void *b); int fcmp_Group_Name (const void *a, const void *b); int fcmp_Constraint_Name (const void *a, const void *b); int fcmp_JacobianMethod_Name (const void *a, const void *b); int fcmp_IntegrationMethod_Name (const void *a, const void *b); int fcmp_BasisFunction_Name (const void *a, const void *b); int fcmp_FunctionSpace_Name (const void *a, const void *b); int fcmp_BasisFunction_NameOfCoef (const void *a, const void *b); int fcmp_SubSpace_Name (const void *a, const void *b); int fcmp_GlobalQuantity_Name (const void *a, const void *b); int fcmp_Formulation_Name (const void *a, const void *b); int fcmp_DefineQuantity_Name (const void *a, const void *b); int fcmp_DefineSystem_Name (const void *a, const void *b); int fcmp_Resolution_Name (const void *a, const void *b); int fcmp_PostProcessing_Name (const void *a, const void *b); int fcmp_PostQuantity_Name (const void *a, const void *b); int fcmp_PostOperation_Name (const void *a, const void *b); void Init_ProblemStructure(); void Read_ProblemStructure(const char *fileName); void Finalize_ProblemStructure(); void Print_ProblemStructure(); void Free_ProblemStructure(); std::string Get_AbsolutePath(const char *fileName); void Print_ListResolution(int choice, int flag_lres, char **name); void Print_ListPostOperation(int choice, int flag_lpos, char *name[NBR_MAX_POS]); #endif getdp-2.4.2-source/Interface/ProParser.yy.cpp000644 001750 001750 00000407457 12221300353 022571 0ustar00geuzainegeuzaine000000 000000 #line 2 "ProParser.yy.cpp" #line 4 "ProParser.yy.cpp" #define YY_INT_ALIGNED short int /* A lexical scanner generated by flex */ #define yy_create_buffer getdp_yy_create_buffer #define yy_delete_buffer getdp_yy_delete_buffer #define yy_flex_debug getdp_yy_flex_debug #define yy_init_buffer getdp_yy_init_buffer #define yy_flush_buffer getdp_yy_flush_buffer #define yy_load_buffer_state getdp_yy_load_buffer_state #define yy_switch_to_buffer getdp_yy_switch_to_buffer #define yyin getdp_yyin #define yyleng getdp_yyleng #define yylex getdp_yylex #define yylineno getdp_yylineno #define yyout getdp_yyout #define yyrestart getdp_yyrestart #define yytext getdp_yytext #define yywrap getdp_yywrap #define yyalloc getdp_yyalloc #define yyrealloc getdp_yyrealloc #define yyfree getdp_yyfree #define FLEX_SCANNER #define YY_FLEX_MAJOR_VERSION 2 #define YY_FLEX_MINOR_VERSION 5 #define YY_FLEX_SUBMINOR_VERSION 35 #if YY_FLEX_SUBMINOR_VERSION > 0 #define FLEX_BETA #endif /* First, we deal with platform-specific or compiler-specific issues. */ /* begin standard C headers. */ #include #include #include #include /* end standard C headers. */ /* flex integer type definitions */ #ifndef FLEXINT_H #define FLEXINT_H /* C99 systems have . Non-C99 systems may or may not. */ #if defined (__STDC_VERSION__) && __STDC_VERSION__ >= 199901L /* C99 says to define __STDC_LIMIT_MACROS before including stdint.h, * if you want the limit (max/min) macros for int types. */ #ifndef __STDC_LIMIT_MACROS #define __STDC_LIMIT_MACROS 1 #endif #include typedef int8_t flex_int8_t; typedef uint8_t flex_uint8_t; typedef int16_t flex_int16_t; typedef uint16_t flex_uint16_t; typedef int32_t flex_int32_t; typedef uint32_t flex_uint32_t; typedef uint64_t flex_uint64_t; #else typedef signed char flex_int8_t; typedef short int flex_int16_t; typedef int flex_int32_t; typedef unsigned char flex_uint8_t; typedef unsigned short int flex_uint16_t; typedef unsigned int flex_uint32_t; #endif /* ! C99 */ /* Limits of integral types. */ #ifndef INT8_MIN #define INT8_MIN (-128) #endif #ifndef INT16_MIN #define INT16_MIN (-32767-1) #endif #ifndef INT32_MIN #define INT32_MIN (-2147483647-1) #endif #ifndef INT8_MAX #define INT8_MAX (127) #endif #ifndef INT16_MAX #define INT16_MAX (32767) #endif #ifndef INT32_MAX #define INT32_MAX (2147483647) #endif #ifndef UINT8_MAX #define UINT8_MAX (255U) #endif #ifndef UINT16_MAX #define UINT16_MAX (65535U) #endif #ifndef UINT32_MAX #define UINT32_MAX (4294967295U) #endif #endif /* ! FLEXINT_H */ #ifdef __cplusplus /* The "const" storage-class-modifier is valid. */ #define YY_USE_CONST #else /* ! __cplusplus */ /* C99 requires __STDC__ to be defined as 1. */ #if defined (__STDC__) #define YY_USE_CONST #endif /* defined (__STDC__) */ #endif /* ! __cplusplus */ #ifdef YY_USE_CONST #define yyconst const #else #define yyconst #endif /* Returned upon end-of-file. */ #define YY_NULL 0 /* Promotes a possibly negative, possibly signed char to an unsigned * integer for use as an array index. If the signed char is negative, * we want to instead treat it as an 8-bit unsigned char, hence the * double cast. */ #define YY_SC_TO_UI(c) ((unsigned int) (unsigned char) c) /* Enter a start condition. This macro really ought to take a parameter, * but we do it the disgusting crufty way forced on us by the ()-less * definition of BEGIN. */ #define BEGIN (yy_start) = 1 + 2 * /* Translate the current start state into a value that can be later handed * to BEGIN to return to the state. The YYSTATE alias is for lex * compatibility. */ #define YY_START (((yy_start) - 1) / 2) #define YYSTATE YY_START /* Action number for EOF rule of a given start state. */ #define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1) /* Special action meaning "start processing a new file". */ #define YY_NEW_FILE getdp_yyrestart(getdp_yyin ) #define YY_END_OF_BUFFER_CHAR 0 /* Size of default input buffer. */ #ifndef YY_BUF_SIZE #define YY_BUF_SIZE 16384 #endif /* The state buf must be large enough to hold one state per character in the main buffer. */ #define YY_STATE_BUF_SIZE ((YY_BUF_SIZE + 2) * sizeof(yy_state_type)) #ifndef YY_TYPEDEF_YY_BUFFER_STATE #define YY_TYPEDEF_YY_BUFFER_STATE typedef struct yy_buffer_state *YY_BUFFER_STATE; #endif #ifndef YY_TYPEDEF_YY_SIZE_T #define YY_TYPEDEF_YY_SIZE_T typedef size_t yy_size_t; #endif extern yy_size_t getdp_yyleng; extern FILE *getdp_yyin, *getdp_yyout; #define EOB_ACT_CONTINUE_SCAN 0 #define EOB_ACT_END_OF_FILE 1 #define EOB_ACT_LAST_MATCH 2 #define YY_LESS_LINENO(n) /* Return all but the first "n" matched characters back to the input stream. */ #define yyless(n) \ do \ { \ /* Undo effects of setting up getdp_yytext. */ \ int yyless_macro_arg = (n); \ YY_LESS_LINENO(yyless_macro_arg);\ *yy_cp = (yy_hold_char); \ YY_RESTORE_YY_MORE_OFFSET \ (yy_c_buf_p) = yy_cp = yy_bp + yyless_macro_arg - YY_MORE_ADJ; \ YY_DO_BEFORE_ACTION; /* set up getdp_yytext again */ \ } \ while ( 0 ) #define unput(c) yyunput( c, (yytext_ptr) ) #ifndef YY_STRUCT_YY_BUFFER_STATE #define YY_STRUCT_YY_BUFFER_STATE struct yy_buffer_state { FILE *yy_input_file; char *yy_ch_buf; /* input buffer */ char *yy_buf_pos; /* current position in input buffer */ /* Size of input buffer in bytes, not including room for EOB * characters. */ yy_size_t yy_buf_size; /* Number of characters read into yy_ch_buf, not including EOB * characters. */ yy_size_t yy_n_chars; /* Whether we "own" the buffer - i.e., we know we created it, * and can realloc() it to grow it, and should free() it to * delete it. */ int yy_is_our_buffer; /* Whether this is an "interactive" input source; if so, and * if we're using stdio for input, then we want to use getc() * instead of fread(), to make sure we stop fetching input after * each newline. */ int yy_is_interactive; /* Whether we're considered to be at the beginning of a line. * If so, '^' rules will be active on the next match, otherwise * not. */ int yy_at_bol; int yy_bs_lineno; /**< The line count. */ int yy_bs_column; /**< The column count. */ /* Whether to try to fill the input buffer when we reach the * end of it. */ int yy_fill_buffer; int yy_buffer_status; #define YY_BUFFER_NEW 0 #define YY_BUFFER_NORMAL 1 /* When an EOF's been seen but there's still some text to process * then we mark the buffer as YY_EOF_PENDING, to indicate that we * shouldn't try reading from the input source any more. We might * still have a bunch of tokens to match, though, because of * possible backing-up. * * When we actually see the EOF, we change the status to "new" * (via getdp_yyrestart()), so that the user can continue scanning by * just pointing getdp_yyin at a new input file. */ #define YY_BUFFER_EOF_PENDING 2 }; #endif /* !YY_STRUCT_YY_BUFFER_STATE */ /* Stack of input buffers. */ static size_t yy_buffer_stack_top = 0; /**< index of top of stack. */ static size_t yy_buffer_stack_max = 0; /**< capacity of stack. */ static YY_BUFFER_STATE * yy_buffer_stack = 0; /**< Stack as an array. */ /* We provide macros for accessing buffer states in case in the * future we want to put the buffer states in a more general * "scanner state". * * Returns the top of the stack, or NULL. */ #define YY_CURRENT_BUFFER ( (yy_buffer_stack) \ ? (yy_buffer_stack)[(yy_buffer_stack_top)] \ : NULL) /* Same as previous macro, but useful when we know that the buffer stack is not * NULL or when we need an lvalue. For internal use only. */ #define YY_CURRENT_BUFFER_LVALUE (yy_buffer_stack)[(yy_buffer_stack_top)] /* yy_hold_char holds the character lost when getdp_yytext is formed. */ static char yy_hold_char; static yy_size_t yy_n_chars; /* number of characters read into yy_ch_buf */ yy_size_t getdp_yyleng; /* Points to current character in buffer. */ static char *yy_c_buf_p = (char *) 0; static int yy_init = 0; /* whether we need to initialize */ static int yy_start = 0; /* start state number */ /* Flag which is used to allow getdp_yywrap()'s to do buffer switches * instead of setting up a fresh getdp_yyin. A bit of a hack ... */ static int yy_did_buffer_switch_on_eof; void getdp_yyrestart (FILE *input_file ); void getdp_yy_switch_to_buffer (YY_BUFFER_STATE new_buffer ); YY_BUFFER_STATE getdp_yy_create_buffer (FILE *file,int size ); void getdp_yy_delete_buffer (YY_BUFFER_STATE b ); void getdp_yy_flush_buffer (YY_BUFFER_STATE b ); void getdp_yypush_buffer_state (YY_BUFFER_STATE new_buffer ); void getdp_yypop_buffer_state (void ); static void getdp_yyensure_buffer_stack (void ); static void getdp_yy_load_buffer_state (void ); static void getdp_yy_init_buffer (YY_BUFFER_STATE b,FILE *file ); #define YY_FLUSH_BUFFER getdp_yy_flush_buffer(YY_CURRENT_BUFFER ) YY_BUFFER_STATE getdp_yy_scan_buffer (char *base,yy_size_t size ); YY_BUFFER_STATE getdp_yy_scan_string (yyconst char *yy_str ); YY_BUFFER_STATE getdp_yy_scan_bytes (yyconst char *bytes,yy_size_t len ); void *getdp_yyalloc (yy_size_t ); void *getdp_yyrealloc (void *,yy_size_t ); void getdp_yyfree (void * ); #define yy_new_buffer getdp_yy_create_buffer #define yy_set_interactive(is_interactive) \ { \ if ( ! YY_CURRENT_BUFFER ){ \ getdp_yyensure_buffer_stack (); \ YY_CURRENT_BUFFER_LVALUE = \ getdp_yy_create_buffer(getdp_yyin,YY_BUF_SIZE ); \ } \ YY_CURRENT_BUFFER_LVALUE->yy_is_interactive = is_interactive; \ } #define yy_set_bol(at_bol) \ { \ if ( ! YY_CURRENT_BUFFER ){\ getdp_yyensure_buffer_stack (); \ YY_CURRENT_BUFFER_LVALUE = \ getdp_yy_create_buffer(getdp_yyin,YY_BUF_SIZE ); \ } \ YY_CURRENT_BUFFER_LVALUE->yy_at_bol = at_bol; \ } #define YY_AT_BOL() (YY_CURRENT_BUFFER_LVALUE->yy_at_bol) /* Begin user sect3 */ typedef unsigned char YY_CHAR; FILE *getdp_yyin = (FILE *) 0, *getdp_yyout = (FILE *) 0; typedef int yy_state_type; extern int getdp_yylineno; int getdp_yylineno = 1; extern char *getdp_yytext; #define yytext_ptr getdp_yytext static yy_state_type yy_get_previous_state (void ); static yy_state_type yy_try_NUL_trans (yy_state_type current_state ); static int yy_get_next_buffer (void ); static void yy_fatal_error (yyconst char msg[] ); /* Done after the current pattern has been matched and before the * corresponding action - sets up getdp_yytext. */ #define YY_DO_BEFORE_ACTION \ (yytext_ptr) = yy_bp; \ getdp_yyleng = (yy_size_t) (yy_cp - yy_bp); \ (yy_hold_char) = *yy_cp; \ *yy_cp = '\0'; \ (yy_c_buf_p) = yy_cp; #define YY_NUM_RULES 296 #define YY_END_OF_BUFFER 297 /* This struct is not used in this scanner, but its presence is necessary. */ struct yy_trans_info { flex_int32_t yy_verify; flex_int32_t yy_nxt; }; static yyconst flex_int16_t yy_accept[1820] = { 0, 0, 0, 297, 295, 1, 2, 295, 6, 295, 295, 295, 294, 295, 290, 290, 290, 290, 290, 20, 3, 295, 7, 295, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 295, 295, 13, 21, 0, 11, 8, 294, 292, 294, 4, 5, 9, 291, 290, 30, 0, 31, 32, 33, 18, 15, 12, 16, 17, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 138, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 279, 147, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 29, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 10, 14, 0, 19, 294, 291, 0, 0, 293, 294, 294, 294, 294, 294, 42, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 62, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 55, 294, 294, 294, 294, 294, 294, 282, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 263, 294, 294, 294, 294, 294, 294, 56, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 59, 294, 294, 294, 294, 294, 294, 294, 285, 294, 294, 294, 294, 65, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 0, 0, 292, 0, 0, 291, 63, 60, 64, 294, 294, 294, 294, 294, 61, 294, 66, 294, 294, 188, 294, 294, 103, 73, 294, 294, 294, 294, 294, 69, 294, 294, 294, 294, 286, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 140, 145, 294, 234, 294, 280, 294, 294, 294, 294, 71, 261, 294, 287, 294, 76, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 52, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 114, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 231, 294, 294, 294, 79, 25, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 75, 68, 249, 294, 294, 294, 262, 294, 58, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 70, 294, 294, 179, 294, 294, 294, 115, 294, 294, 294, 294, 294, 294, 294, 294, 0, 292, 0, 291, 235, 294, 294, 294, 294, 294, 67, 294, 294, 294, 207, 294, 294, 277, 255, 39, 294, 294, 80, 186, 294, 294, 294, 294, 253, 294, 294, 294, 294, 139, 294, 294, 294, 294, 281, 294, 294, 294, 72, 294, 294, 294, 294, 294, 294, 294, 294, 189, 294, 294, 294, 294, 294, 40, 294, 294, 78, 294, 294, 294, 294, 294, 294, 142, 294, 294, 294, 294, 294, 294, 57, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 246, 241, 294, 294, 294, 294, 294, 294, 294, 294, 294, 83, 294, 294, 294, 294, 294, 232, 294, 294, 294, 294, 294, 74, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 271, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 187, 184, 294, 294, 294, 294, 84, 294, 294, 294, 97, 294, 236, 294, 294, 0, 294, 294, 294, 229, 294, 294, 294, 99, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 283, 124, 294, 96, 251, 250, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 252, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 105, 294, 294, 294, 77, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 240, 244, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 24, 294, 91, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 157, 294, 294, 294, 22, 27, 294, 294, 294, 294, 294, 294, 294, 152, 260, 294, 294, 294, 294, 294, 294, 294, 164, 294, 294, 294, 294, 294, 137, 0, 294, 294, 294, 294, 294, 223, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 141, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 36, 294, 294, 294, 294, 294, 170, 294, 294, 53, 294, 294, 89, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 144, 294, 294, 265, 294, 294, 294, 245, 243, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 162, 294, 294, 294, 294, 23, 294, 294, 294, 294, 294, 116, 294, 123, 294, 294, 294, 294, 294, 294, 185, 294, 294, 294, 294, 294, 294, 294, 294, 37, 294, 294, 294, 294, 294, 294, 294, 294, 38, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 85, 294, 294, 294, 294, 294, 294, 173, 294, 294, 294, 294, 294, 119, 136, 294, 294, 294, 294, 294, 294, 202, 294, 294, 294, 294, 289, 294, 294, 101, 294, 86, 294, 87, 294, 34, 35, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 237, 238, 294, 294, 294, 294, 294, 294, 294, 294, 294, 132, 294, 294, 294, 294, 45, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 125, 294, 135, 294, 294, 294, 294, 294, 259, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 205, 106, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 254, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 155, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 43, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 264, 294, 294, 294, 242, 160, 294, 294, 294, 294, 294, 294, 294, 93, 294, 294, 294, 294, 294, 294, 294, 294, 294, 248, 294, 294, 294, 294, 294, 294, 294, 92, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 228, 294, 257, 294, 120, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 90, 294, 294, 294, 294, 294, 294, 294, 46, 294, 204, 294, 294, 143, 294, 171, 294, 294, 128, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 107, 294, 294, 149, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 118, 294, 294, 154, 294, 294, 294, 294, 294, 28, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 233, 294, 294, 151, 294, 294, 294, 294, 294, 294, 82, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 266, 294, 294, 294, 294, 294, 294, 256, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 95, 294, 294, 294, 294, 294, 41, 294, 47, 294, 294, 294, 294, 294, 294, 294, 131, 294, 294, 148, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 104, 294, 294, 294, 294, 294, 88, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 133, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 221, 294, 294, 294, 294, 294, 294, 294, 121, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 81, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 166, 294, 294, 294, 294, 203, 294, 294, 294, 294, 294, 294, 294, 54, 294, 294, 294, 102, 44, 294, 294, 294, 294, 294, 294, 225, 294, 294, 294, 294, 239, 161, 158, 294, 294, 294, 288, 294, 294, 230, 294, 294, 276, 222, 163, 294, 294, 294, 272, 294, 94, 122, 294, 294, 98, 294, 294, 294, 294, 294, 294, 247, 175, 294, 217, 294, 294, 117, 294, 197, 294, 294, 294, 294, 294, 294, 294, 294, 294, 172, 294, 129, 294, 294, 294, 113, 218, 294, 294, 294, 294, 294, 294, 294, 134, 294, 294, 190, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 226, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 201, 294, 294, 294, 294, 180, 294, 294, 294, 294, 294, 294, 200, 294, 294, 50, 48, 49, 294, 294, 156, 294, 294, 294, 294, 294, 294, 294, 294, 150, 127, 258, 294, 294, 191, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 278, 294, 108, 294, 224, 26, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 206, 294, 294, 294, 294, 294, 294, 267, 294, 167, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 193, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 270, 294, 294, 181, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 268, 269, 168, 219, 220, 294, 213, 294, 294, 273, 294, 294, 214, 176, 294, 130, 294, 294, 100, 294, 294, 194, 294, 294, 294, 174, 294, 294, 294, 294, 183, 294, 51, 165, 294, 294, 294, 294, 294, 159, 294, 169, 294, 294, 294, 294, 109, 294, 153, 294, 110, 294, 294, 294, 294, 294, 294, 112, 294, 294, 294, 294, 146, 294, 284, 294, 215, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 209, 182, 294, 294, 198, 196, 294, 294, 294, 294, 126, 294, 294, 294, 294, 294, 178, 208, 294, 294, 199, 294, 294, 294, 111, 227, 294, 294, 212, 294, 294, 294, 294, 192, 294, 275, 294, 294, 294, 294, 294, 195, 211, 294, 177, 294, 294, 294, 274, 294, 294, 294, 210, 294, 216, 0 } ; static yyconst flex_int32_t yy_ec[256] = { 0, 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, 1, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 4, 5, 6, 1, 1, 7, 1, 1, 1, 8, 9, 1, 9, 10, 11, 12, 13, 14, 15, 16, 16, 16, 16, 16, 16, 17, 18, 19, 20, 21, 1, 1, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 45, 45, 1, 46, 1, 47, 48, 1, 49, 50, 51, 52, 53, 54, 55, 56, 57, 45, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 1, 74, 1, 75, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 } ; static yyconst flex_int32_t yy_meta[76] = { 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 2, 2, 2, 2, 2, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 1 } ; static yyconst flex_int16_t yy_base[1821] = { 0, 0, 0, 1971, 1972, 1972, 1972, 1950, 1972, 70, 1962, 1921, 67, 76, 76, 83, 100, 118, 125, 1972, 1972, 84, 1947, 85, 118, 58, 99, 126, 138, 97, 127, 96, 137, 1917, 0, 151, 153, 161, 155, 160, 1897, 177, 178, 195, 58, 1915, 109, 67, 1889, 1942, 1972, 1972, 1900, 1972, 1972, 1950, 242, 0, 1972, 1972, 1972, 249, 264, 1972, 257, 1972, 1972, 1972, 1972, 1972, 1972, 1972, 1972, 1897, 1901, 1895, 98, 1897, 1892, 1897, 179, 52, 1886, 184, 1886, 1894, 1901, 228, 229, 1892, 1881, 242, 103, 1893, 218, 1886, 1889, 1889, 1877, 33, 1893, 1878, 1890, 1880, 111, 1876, 235, 1884, 173, 224, 237, 1874, 1869, 1872, 1868, 1883, 1868, 0, 264, 1868, 1876, 1877, 245, 246, 1872, 218, 1896, 242, 252, 258, 1866, 1864, 1858, 253, 279, 1862, 302, 1868, 272, 1867, 0, 1857, 1852, 1860, 1867, 1854, 285, 1846, 1844, 286, 277, 1855, 1849, 278, 1845, 1844, 271, 296, 288, 291, 289, 1855, 1847, 1857, 1842, 1852, 1851, 1845, 1842, 1833, 1842, 1830, 1858, 1972, 1972, 1845, 0, 348, 353, 361, 368, 373, 1829, 1833, 1827, 1829, 354, 0, 1838, 1829, 1828, 1827, 1822, 1829, 1836, 1823, 1834, 1829, 1822, 1819, 1825, 1816, 1817, 1810, 1819, 1825, 1806, 1806, 1811, 1817, 1807, 334, 1815, 1800, 1799, 1812, 1807, 1820, 330, 1829, 1801, 1798, 1806, 1805, 368, 1800, 1797, 0, 1789, 305, 1799, 1791, 1800, 1784, 1790, 1784, 1784, 1788, 1795, 1792, 1784, 1790, 1816, 1791, 1784, 1771, 1778, 1785, 1774, 1767, 1775, 1780, 1765, 1778, 0, 1765, 358, 1778, 1761, 1787, 1759, 381, 1776, 1759, 1775, 1757, 1786, 1764, 1754, 1750, 1760, 1749, 1762, 365, 1761, 1789, 1759, 1754, 1760, 1747, 1740, 1748, 342, 1749, 341, 1752, 1751, 1738, 1749, 1746, 1735, 1732, 1731, 1736, 1735, 1743, 1742, 1736, 1743, 356, 1730, 1737, 1736, 1736, 384, 1726, 1730, 1724, 1722, 353, 1716, 1725, 1714, 349, 1756, 388, 1716, 1718, 1710, 1720, 1720, 1708, 1706, 1705, 1718, 1719, 1716, 1715, 1718, 1705, 1697, 1708, 1696, 1701, 1705, 1701, 418, 423, 432, 437, 442, 0, 0, 0, 1692, 1696, 1694, 1722, 1694, 0, 1687, 1739, 1695, 1685, 0, 1699, 1691, 0, 0, 1693, 1693, 1681, 1696, 1677, 0, 1676, 1689, 1675, 1687, 0, 1679, 1677, 1672, 1669, 1679, 1677, 1672, 1666, 1682, 1676, 1704, 0, 1656, 0, 1666, 0, 1664, 1671, 1657, 1655, 0, 0, 1669, 0, 1656, 0, 1667, 374, 1662, 1650, 1669, 1649, 1650, 1665, 1648, 1653, 1662, 385, 1647, 1647, 1655, 1640, 1643, 1637, 1633, 1669, 1647, 1652, 1667, 1649, 1625, 1656, 1633, 437, 1683, 1631, 1642, 1643, 377, 1634, 1622, 1655, 1631, 1628, 1625, 1628, 1648, 1634, 1629, 1616, 1618, 1609, 1611, 1624, 1605, 1608, 1621, 1611, 1615, 1610, 1621, 1612, 1613, 1616, 1617, 1600, 1607, 1598, 0, 424, 1595, 1594, 0, 0, 1598, 1588, 1598, 1598, 1604, 379, 1604, 1613, 1591, 1587, 1594, 0, 0, 0, 1583, 1597, 1595, 0, 1586, 0, 1583, 1592, 414, 1576, 1590, 1579, 1569, 1613, 1577, 1585, 1584, 0, 1583, 1573, 0, 1585, 453, 1580, 0, 1578, 1564, 1575, 1576, 1606, 1574, 1575, 1576, 1556, 454, 463, 469, 0, 1558, 1559, 1592, 1568, 1566, 0, 1565, 1590, 1560, 0, 1562, 1557, 0, 0, 147, 1560, 1547, 1574, 0, 1547, 1556, 1548, 1554, 0, 1545, 1539, 1547, 1544, 1571, 1539, 1573, 403, 1534, 0, 1526, 1548, 1531, 0, 1530, 1527, 1534, 1539, 1538, 1556, 1532, 1530, 0, 1538, 1533, 1526, 1525, 1530, 0, 1521, 1516, 0, 1517, 1527, 1542, 1515, 1511, 1508, 0, 1517, 1511, 1515, 1522, 1511, 1504, 0, 1519, 1532, 1505, 1516, 1507, 1492, 1502, 1499, 1509, 1497, 1503, 1494, 1502, 1484, 1499, 1528, 1490, 1518, 1491, 1484, 0, 0, 1488, 1497, 1494, 1492, 1483, 1482, 1485, 1474, 1473, 0, 1478, 1481, 1474, 1471, 1467, 464, 1477, 1472, 1483, 1468, 1462, 0, 1476, 1466, 1460, 1464, 1465, 1471, 1463, 1466, 1499, 467, 1453, 1462, 1488, 1450, 1453, 1454, 1459, 1464, 1449, 1443, 1445, 1442, 1448, 1440, 1441, 0, 0, 1437, 437, 1455, 1436, 0, 1445, 1448, 1463, 461, 1434, 0, 1431, 1437, 1444, 1430, 1432, 1445, 1451, 1426, 1425, 1421, 0, 1452, 1436, 1425, 1436, 1459, 1426, 1417, 1419, 473, 460, 1453, 1430, 1421, 1415, 1408, 1426, 1420, 1408, 16, 156, 0, 462, 180, 0, 0, 0, 236, 227, 288, 322, 364, 414, 406, 435, 479, 451, 457, 450, 0, 446, 456, 456, 442, 463, 457, 466, 453, 461, 471, 456, 462, 474, 493, 461, 467, 456, 0, 480, 462, 492, 0, 511, 476, 513, 508, 482, 474, 477, 486, 491, 509, 493, 499, 0, 0, 496, 484, 492, 498, 499, 517, 506, 506, 498, 512, 500, 498, 0, 497, 526, 499, 508, 501, 503, 511, 547, 532, 513, 510, 522, 519, 516, 523, 530, 0, 526, 520, 521, 0, 0, 532, 527, 534, 533, 526, 521, 524, 566, 0, 554, 531, 538, 532, 524, 543, 536, 574, 537, 539, 552, 547, 546, 0, 551, 552, 540, 573, 551, 552, 0, 549, 557, 555, 546, 557, 558, 554, 555, 552, 557, 552, 556, 573, 570, 590, 568, 559, 565, 567, 576, 579, 0, 578, 573, 574, 566, 563, 583, 570, 597, 588, 574, 581, 582, 591, 592, 582, 579, 595, 600, 598, 600, 587, 0, 613, 597, 596, 587, 596, 0, 605, 606, 0, 600, 608, 0, 608, 606, 612, 613, 610, 615, 620, 598, 622, 610, 611, 621, 613, 623, 614, 611, 617, 0, 628, 620, 0, 628, 622, 625, 0, 0, 624, 625, 626, 617, 637, 626, 641, 632, 633, 633, 624, 644, 641, 646, 643, 645, 634, 641, 651, 665, 638, 0, 646, 653, 661, 660, 0, 657, 686, 647, 653, 663, 0, 666, 0, 646, 657, 655, 670, 669, 660, 0, 661, 673, 665, 662, 677, 670, 663, 670, 1972, 682, 677, 673, 676, 675, 687, 715, 687, 0, 680, 677, 682, 692, 692, 685, 686, 686, 684, 684, 698, 693, 696, 693, 732, 0, 722, 695, 691, 693, 712, 700, 0, 702, 708, 701, 695, 703, 729, 0, 742, 710, 704, 725, 710, 711, 0, 736, 712, 708, 721, 0, 726, 731, 0, 745, 0, 759, 0, 725, 0, 0, 723, 728, 730, 731, 753, 728, 742, 731, 731, 732, 733, 751, 735, 749, 743, 748, 753, 782, 741, 0, 0, 748, 749, 745, 771, 764, 761, 748, 750, 749, 0, 764, 758, 780, 760, 0, 756, 759, 760, 773, 765, 775, 774, 771, 774, 784, 809, 777, 782, 779, 776, 0, 771, 0, 779, 778, 774, 781, 821, 0, 820, 784, 779, 794, 795, 789, 789, 784, 785, 784, 801, 790, 790, 796, 792, 812, 802, 797, 812, 0, 798, 837, 802, 818, 802, 814, 816, 807, 821, 813, 0, 814, 844, 810, 826, 827, 840, 829, 822, 822, 836, 853, 830, 825, 824, 841, 830, 863, 859, 827, 846, 835, 837, 876, 837, 0, 834, 846, 840, 870, 837, 848, 841, 871, 853, 843, 858, 850, 856, 860, 849, 856, 861, 851, 857, 869, 854, 857, 857, 863, 0, 868, 864, 861, 0, 902, 862, 873, 864, 866, 876, 867, 872, 0, 875, 880, 877, 882, 875, 872, 883, 878, 883, 0, 892, 885, 925, 883, 896, 895, 889, 913, 896, 894, 903, 899, 905, 906, 906, 892, 905, 900, 897, 0, 893, 0, 912, 0, 909, 914, 911, 929, 929, 914, 910, 924, 915, 908, 0, 925, 926, 917, 912, 913, 918, 933, 0, 927, 0, 923, 932, 0, 933, 956, 955, 917, 0, 953, 930, 931, 940, 923, 946, 934, 946, 939, 959, 971, 0, 934, 935, 0, 944, 963, 938, 983, 946, 951, 952, 957, 952, 952, 960, 992, 954, 1003, 959, 953, 0, 953, 953, 0, 985, 964, 971, 972, 977, 0, 978, 959, 972, 994, 970, 979, 973, 977, 969, 969, 988, 0, 1011, 979, 0, 978, 988, 989, 989, 985, 994, 0, 1002, 995, 991, 990, 993, 990, 999, 991, 1005, 987, 994, 0, 1008, 988, 998, 1007, 1000, 995, 0, 1002, 1002, 1038, 1005, 1000, 1011, 1007, 1005, 1004, 1004, 0, 1006, 1007, 1035, 1027, 1020, 0, 1028, 0, 1039, 1026, 1020, 1033, 1030, 1021, 1023, 0, 1020, 1032, 0, 1037, 1021, 1062, 1019, 1064, 1045, 1037, 1038, 1037, 1040, 1045, 1050, 0, 1039, 1039, 1042, 1040, 1051, 0, 1080, 1057, 1042, 1083, 1041, 1083, 1046, 1053, 1048, 1046, 0, 1055, 1049, 1051, 1062, 1059, 1067, 1070, 1063, 1071, 1063, 1069, 1055, 1067, 1080, 1077, 1070, 1081, 1068, 0, 1082, 1063, 1079, 1088, 1071, 1087, 1074, 0, 1087, 1081, 1082, 1093, 1084, 1083, 1087, 1093, 1082, 1084, 1086, 1085, 1092, 1086, 1100, 1103, 1097, 1097, 1107, 1107, 1108, 1100, 0, 1106, 1103, 1103, 1107, 1095, 1114, 1118, 1119, 1116, 1119, 1116, 1120, 1122, 1123, 1114, 1113, 1148, 1115, 1147, 1120, 1116, 0, 1124, 1125, 1125, 1134, 1125, 1136, 1154, 0, 1134, 1130, 1132, 0, 0, 1127, 1127, 1147, 1148, 1136, 1132, 0, 1143, 1148, 1136, 1136, 0, 0, 0, 1164, 1144, 1145, 0, 1140, 1157, 0, 1183, 1143, 0, 0, 0, 1144, 1149, 1160, 0, 1147, 0, 0, 1163, 1149, 0, 1151, 1170, 1167, 1172, 1155, 1174, 0, 0, 1165, 0, 1162, 1173, 0, 1171, 0, 1163, 1165, 1171, 1165, 1172, 1181, 1169, 1179, 1165, 0, 1185, 0, 1178, 1178, 1180, 0, 0, 1180, 1194, 1182, 1183, 1185, 1175, 1195, 0, 1197, 1201, 1216, 1213, 1192, 1185, 1198, 1204, 1200, 1197, 1202, 1193, 1210, 1205, 1201, 1198, 1208, 1200, 1200, 0, 1213, 1203, 1203, 1200, 1243, 1216, 1217, 1219, 1209, 1212, 1225, 0, 1239, 1223, 1216, 1250, 0, 1234, 1227, 1226, 1245, 1247, 1227, 0, 1217, 1227, 0, 0, 0, 1224, 1241, 0, 1232, 1227, 1230, 1244, 1229, 1247, 1231, 1231, 0, 0, 0, 1287, 1237, 0, 1250, 1245, 1248, 1245, 1293, 1246, 1258, 1249, 1254, 1259, 1251, 1253, 0, 1253, 0, 1263, 0, 0, 1255, 1251, 1252, 1253, 1259, 1286, 1284, 1267, 1260, 1264, 1258, 1270, 1261, 1269, 1270, 1292, 1271, 1267, 1286, 0, 1277, 1284, 1281, 1287, 1274, 1281, 0, 1279, 0, 1280, 1287, 1320, 1306, 1295, 1276, 1283, 1283, 1326, 1291, 1286, 1287, 1293, 1290, 1296, 0, 1297, 1296, 1295, 1308, 1300, 1307, 1303, 1298, 1313, 1305, 0, 1309, 1316, 0, 1303, 1304, 1305, 1311, 1347, 1322, 1309, 1324, 1318, 1326, 0, 0, 1349, 0, 0, 1320, 0, 1320, 1315, 0, 1327, 1319, 0, 0, 1329, 0, 1326, 1322, 0, 1323, 1347, 0, 1330, 1351, 1367, 0, 1338, 1336, 1335, 1328, 0, 1331, 0, 0, 1340, 1343, 1338, 1349, 1332, 0, 1343, 0, 1350, 1347, 1356, 1346, 0, 1347, 0, 1353, 0, 1362, 1360, 1356, 1353, 1362, 1367, 0, 1364, 1369, 1351, 1361, 0, 1355, 0, 1355, 1375, 1355, 1358, 1365, 1366, 1367, 1370, 1377, 1371, 1365, 1368, 1363, 0, 0, 1368, 1383, 1423, 0, 1398, 1386, 1383, 1375, 0, 1387, 1375, 1392, 1392, 1389, 0, 0, 1390, 1413, 0, 1396, 1385, 1389, 0, 0, 1399, 1419, 0, 1387, 1393, 1407, 1394, 0, 1397, 0, 1430, 1388, 1400, 1402, 1414, 0, 0, 1429, 0, 1412, 1401, 1399, 0, 1419, 1409, 1403, 0, 1418, 0, 1972, 1470 } ; static yyconst flex_int16_t yy_def[1821] = { 0, 1819, 1, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1820, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1820, 1820, 1820, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1819, 1819, 1819, 1820, 1820, 1819, 1819, 1819, 1819, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1819, 1819, 1820, 1819, 1819, 1819, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1819, 1819, 1819, 1819, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1819, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1819, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1819, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1820, 0, 1819 } ; static yyconst flex_int16_t yy_nxt[2048] = { 0, 4, 5, 6, 7, 8, 9, 10, 11, 4, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 34, 4, 4, 34, 34, 34, 34, 47, 34, 34, 34, 34, 34, 34, 34, 34, 34, 34, 34, 34, 34, 34, 34, 34, 34, 34, 34, 34, 34, 48, 49, 51, 55, 842, 56, 56, 56, 56, 56, 58, 224, 61, 59, 62, 62, 62, 62, 62, 61, 171, 62, 62, 62, 62, 62, 225, 63, 64, 68, 69, 71, 72, 81, 65, 64, 61, 82, 62, 62, 62, 62, 62, 192, 193, 165, 172, 166, 60, 83, 167, 66, 64, 52, 61, 64, 62, 62, 62, 62, 62, 61, 64, 62, 62, 62, 62, 62, 73, 67, 64, 114, 102, 185, 84, 115, 186, 64, 85, 64, 103, 86, 104, 105, 74, 106, 230, 87, 107, 215, 88, 108, 169, 89, 116, 75, 76, 64, 216, 231, 170, 90, 109, 77, 64, 91, 110, 78, 125, 92, 79, 80, 111, 112, 93, 96, 126, 117, 113, 94, 95, 97, 681, 98, 118, 99, 122, 190, 127, 119, 120, 843, 128, 100, 123, 101, 131, 132, 682, 124, 133, 129, 136, 140, 137, 141, 138, 130, 142, 134, 139, 143, 145, 148, 191, 135, 146, 149, 237, 195, 238, 150, 151, 196, 152, 147, 153, 154, 155, 218, 159, 156, 157, 846, 160, 262, 158, 161, 162, 219, 56, 56, 56, 56, 56, 263, 163, 178, 178, 178, 178, 178, 180, 164, 177, 181, 181, 181, 181, 181, 61, 179, 62, 62, 62, 62, 62, 200, 205, 239, 240, 847, 206, 201, 202, 203, 64, 207, 848, 210, 204, 177, 211, 233, 241, 242, 234, 212, 179, 235, 249, 213, 257, 259, 214, 265, 269, 258, 260, 266, 276, 250, 251, 64, 267, 268, 277, 252, 274, 275, 288, 279, 280, 270, 281, 289, 282, 253, 305, 313, 296, 283, 314, 309, 306, 284, 297, 285, 286, 310, 298, 302, 315, 303, 317, 849, 321, 299, 319, 304, 318, 322, 320, 336, 391, 316, 337, 337, 337, 337, 337, 178, 178, 178, 178, 178, 339, 850, 392, 340, 340, 340, 340, 340, 345, 338, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 346, 371, 379, 418, 424, 386, 372, 380, 387, 437, 450, 447, 347, 451, 438, 466, 338, 448, 472, 566, 479, 473, 484, 630, 485, 487, 589, 590, 467, 631, 419, 425, 480, 555, 567, 474, 851, 488, 489, 490, 512, 512, 512, 512, 512, 337, 337, 337, 337, 337, 491, 513, 556, 697, 514, 514, 514, 514, 514, 340, 340, 340, 340, 340, 340, 340, 340, 340, 340, 583, 620, 621, 622, 643, 584, 656, 512, 512, 512, 512, 512, 852, 698, 853, 644, 514, 514, 514, 514, 514, 657, 514, 514, 514, 514, 514, 658, 659, 764, 781, 800, 807, 765, 660, 832, 854, 808, 828, 782, 801, 829, 830, 844, 845, 858, 855, 859, 860, 861, 862, 863, 864, 865, 833, 866, 867, 831, 856, 766, 868, 857, 869, 870, 871, 872, 873, 874, 875, 876, 877, 878, 879, 783, 880, 881, 882, 883, 884, 890, 891, 885, 892, 893, 894, 895, 896, 897, 886, 898, 899, 887, 900, 888, 889, 901, 902, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 925, 926, 927, 928, 929, 930, 931, 932, 933, 934, 935, 936, 937, 938, 939, 940, 941, 942, 943, 944, 945, 946, 947, 948, 949, 950, 951, 952, 953, 954, 955, 956, 957, 958, 959, 960, 961, 962, 963, 964, 965, 966, 967, 968, 969, 970, 971, 972, 973, 974, 975, 976, 977, 978, 979, 980, 981, 982, 983, 985, 986, 987, 984, 988, 989, 990, 991, 992, 993, 994, 995, 996, 997, 998, 999, 1000, 1001, 1002, 1004, 1005, 1006, 1007, 1008, 1009, 1010, 1003, 1011, 1012, 1013, 1014, 1015, 1016, 1017, 1018, 1019, 1020, 1021, 1022, 1023, 1024, 1026, 1027, 1028, 1029, 1030, 1031, 1032, 1033, 1025, 1034, 1035, 1036, 1037, 1038, 1039, 1040, 1041, 1042, 1043, 1044, 1045, 1046, 1047, 1048, 1049, 1050, 1051, 1052, 1054, 1055, 1056, 1053, 1057, 1058, 1059, 1060, 1062, 1063, 1064, 1065, 1066, 1067, 1068, 1069, 1070, 1071, 1072, 1061, 1073, 1074, 1075, 1076, 1077, 1078, 1079, 1080, 1081, 1082, 1083, 1084, 1085, 1086, 1089, 1090, 1091, 1092, 1093, 1094, 1095, 1096, 1097, 1098, 1099, 1100, 1101, 1102, 1103, 1087, 1104, 1105, 1088, 1106, 1107, 1108, 1109, 1110, 1111, 1112, 1113, 1114, 1115, 1116, 1117, 1122, 1123, 1118, 1124, 1125, 1126, 1127, 1119, 1128, 1129, 1120, 1130, 1131, 1132, 1133, 1134, 1135, 1136, 1137, 1121, 1138, 1139, 1140, 1141, 1142, 1144, 1145, 1146, 1147, 1148, 1149, 1150, 1143, 1151, 1152, 1153, 1154, 1156, 1157, 1158, 1159, 1160, 1161, 1162, 1163, 1164, 1165, 1166, 1155, 1167, 1168, 1169, 1170, 1171, 1172, 1173, 1174, 1175, 1176, 1177, 1178, 1179, 1180, 1181, 1182, 1183, 1184, 1185, 1186, 1187, 1188, 1189, 1190, 1194, 1195, 1196, 1197, 1198, 1199, 1200, 1201, 1202, 1203, 1204, 1205, 1191, 1206, 1207, 1208, 1192, 1209, 1193, 1210, 1211, 1212, 1213, 1214, 1215, 1216, 1217, 1218, 1219, 1220, 1221, 1222, 1223, 1224, 1225, 1226, 1227, 1228, 1229, 1230, 1231, 1232, 1233, 1234, 1235, 1236, 1237, 1238, 1239, 1240, 1241, 1242, 1243, 1244, 1245, 1246, 1247, 1248, 1249, 1250, 1252, 1253, 1254, 1255, 1256, 1257, 1258, 1251, 1259, 1260, 1261, 1262, 1263, 1264, 1265, 1266, 1267, 1268, 1269, 1270, 1271, 1272, 1273, 1274, 1275, 1276, 1277, 1278, 1279, 1280, 1281, 1282, 1283, 1284, 1285, 1286, 1287, 1288, 1289, 1290, 1291, 1292, 1293, 1294, 1295, 1296, 1297, 1298, 1299, 1300, 1301, 1302, 1303, 1304, 1305, 1306, 1307, 1308, 1309, 1310, 1311, 1312, 1313, 1314, 1315, 1316, 1317, 1318, 1319, 1320, 1321, 1322, 1323, 1324, 1325, 1326, 1327, 1328, 1329, 1330, 1331, 1332, 1333, 1334, 1335, 1336, 1337, 1338, 1339, 1340, 1341, 1342, 1343, 1344, 1345, 1346, 1347, 1348, 1349, 1350, 1351, 1352, 1353, 1354, 1355, 1357, 1358, 1359, 1360, 1356, 1361, 1362, 1363, 1364, 1365, 1366, 1367, 1368, 1369, 1370, 1371, 1372, 1373, 1374, 1375, 1376, 1377, 1378, 1379, 1380, 1381, 1382, 1383, 1384, 1385, 1386, 1387, 1388, 1389, 1390, 1391, 1392, 1393, 1394, 1395, 1396, 1397, 1398, 1399, 1400, 1401, 1402, 1403, 1404, 1405, 1406, 1407, 1408, 1409, 1410, 1411, 1412, 1413, 1414, 1415, 1416, 1417, 1418, 1419, 1420, 1421, 1422, 1423, 1424, 1425, 1426, 1427, 1428, 1429, 1430, 1431, 1432, 1433, 1434, 1435, 1436, 1437, 1438, 1439, 1440, 1441, 1442, 1443, 1444, 1445, 1446, 1447, 1448, 1449, 1450, 1451, 1452, 1454, 1455, 1456, 1457, 1458, 1459, 1460, 1461, 1462, 1463, 1464, 1453, 1465, 1466, 1467, 1468, 1469, 1470, 1471, 1472, 1473, 1474, 1475, 1476, 1477, 1478, 1479, 1480, 1481, 1482, 1483, 1484, 1485, 1486, 1487, 1488, 1489, 1490, 1491, 1492, 1493, 1494, 1495, 1496, 1497, 1498, 1499, 1500, 1501, 1502, 1503, 1504, 1505, 1506, 1507, 1508, 1509, 1510, 1511, 1512, 1513, 1514, 1515, 1516, 1517, 1518, 1519, 1520, 1521, 1522, 1523, 1524, 1525, 1526, 1527, 1528, 1529, 1530, 1531, 1532, 1533, 1534, 1535, 1536, 1537, 1538, 1539, 1540, 1541, 1542, 1543, 1544, 1545, 1546, 1547, 1548, 1549, 1550, 1551, 1552, 1553, 1554, 1555, 1556, 1559, 1560, 1561, 1562, 1563, 1564, 1565, 1557, 1566, 1567, 1568, 1569, 1570, 1571, 1572, 1573, 1574, 1558, 1575, 1576, 1577, 1578, 1579, 1580, 1581, 1582, 1583, 1584, 1585, 1586, 1587, 1588, 1589, 1590, 1591, 1592, 1593, 1594, 1595, 1596, 1597, 1598, 1599, 1600, 1601, 1602, 1603, 1604, 1605, 1606, 1607, 1608, 1609, 1610, 1611, 1612, 1613, 1614, 1615, 1616, 1617, 1618, 1619, 1620, 1621, 1622, 1623, 1624, 1625, 1626, 1627, 1628, 1629, 1630, 1631, 1632, 1633, 1634, 1635, 1636, 1637, 1638, 1639, 1640, 1641, 1642, 1643, 1644, 1645, 1646, 1647, 1648, 1649, 1650, 1651, 1652, 1653, 1654, 1655, 1656, 1657, 1658, 1659, 1660, 1661, 1662, 1663, 1664, 1665, 1666, 1667, 1668, 1669, 1670, 1671, 1672, 1673, 1674, 1675, 1676, 1677, 1678, 1679, 1680, 1681, 1682, 1683, 1684, 1685, 1686, 1687, 1688, 1689, 1690, 1691, 1692, 1693, 1694, 1695, 1696, 1697, 1698, 1699, 1700, 1701, 1702, 1703, 1704, 1705, 1706, 1707, 1708, 1709, 1710, 1711, 1712, 1713, 1714, 1715, 1716, 1717, 1718, 1719, 1720, 1721, 1722, 1723, 1724, 1725, 1726, 1727, 1728, 1729, 1730, 1731, 1732, 1733, 1734, 1735, 1736, 1737, 1738, 1739, 1740, 1741, 1742, 1743, 1744, 1745, 1746, 1747, 1748, 1749, 1750, 1751, 1752, 1753, 1754, 1755, 1756, 1757, 1758, 1759, 1760, 1761, 1762, 1763, 1764, 1765, 1766, 1767, 1768, 1769, 1770, 1771, 1772, 1773, 1774, 1775, 1776, 1777, 1778, 1779, 1780, 1781, 1782, 1783, 1784, 1785, 1786, 1787, 1788, 1789, 1790, 1791, 1792, 1793, 1794, 1795, 1796, 1797, 1798, 1799, 1800, 1801, 1802, 1803, 1804, 1805, 1806, 1807, 1808, 1809, 1810, 1811, 1812, 1813, 1814, 1815, 1816, 1817, 1818, 57, 841, 840, 839, 838, 837, 836, 835, 834, 827, 826, 825, 824, 823, 822, 821, 820, 819, 818, 817, 816, 815, 814, 813, 812, 811, 810, 809, 806, 805, 804, 803, 802, 799, 798, 797, 796, 795, 794, 793, 792, 791, 790, 789, 788, 787, 786, 785, 784, 780, 779, 778, 777, 776, 775, 774, 773, 772, 771, 770, 769, 768, 767, 763, 762, 761, 760, 759, 758, 757, 756, 755, 754, 753, 752, 751, 750, 749, 748, 747, 746, 745, 744, 743, 742, 741, 740, 739, 738, 737, 736, 735, 734, 733, 732, 731, 730, 729, 728, 727, 726, 725, 724, 723, 722, 721, 720, 719, 718, 717, 716, 715, 714, 713, 712, 711, 710, 709, 708, 707, 706, 705, 704, 703, 702, 701, 700, 699, 696, 695, 694, 693, 692, 691, 690, 689, 688, 687, 686, 685, 684, 683, 680, 679, 678, 677, 676, 675, 674, 673, 672, 671, 670, 669, 668, 667, 666, 665, 664, 663, 662, 661, 655, 654, 653, 652, 651, 650, 649, 648, 647, 646, 645, 642, 641, 640, 639, 638, 637, 636, 635, 634, 633, 632, 629, 628, 627, 626, 625, 624, 623, 619, 618, 617, 616, 615, 614, 613, 612, 611, 610, 609, 608, 607, 606, 605, 604, 603, 602, 601, 600, 599, 598, 597, 596, 595, 594, 593, 592, 591, 588, 587, 586, 585, 582, 581, 580, 579, 578, 577, 576, 575, 574, 573, 572, 571, 570, 569, 568, 565, 564, 563, 562, 561, 560, 559, 558, 557, 554, 553, 552, 551, 550, 549, 548, 547, 546, 545, 544, 543, 542, 541, 540, 539, 538, 537, 536, 535, 534, 533, 532, 531, 530, 529, 528, 527, 526, 525, 524, 523, 522, 521, 520, 519, 518, 517, 516, 515, 511, 510, 509, 508, 507, 506, 505, 504, 503, 502, 501, 500, 499, 498, 497, 496, 495, 494, 493, 492, 486, 483, 482, 481, 478, 477, 476, 475, 471, 470, 469, 468, 465, 464, 463, 462, 461, 460, 459, 458, 457, 456, 455, 454, 453, 452, 449, 446, 445, 444, 443, 442, 441, 440, 439, 436, 435, 434, 433, 432, 431, 430, 429, 428, 427, 426, 423, 422, 421, 420, 417, 416, 415, 414, 413, 412, 411, 410, 409, 408, 407, 406, 405, 404, 403, 402, 401, 400, 399, 398, 397, 396, 395, 394, 393, 390, 389, 388, 385, 384, 383, 382, 381, 378, 377, 376, 375, 374, 373, 370, 369, 368, 367, 366, 365, 364, 363, 362, 361, 360, 359, 358, 357, 356, 355, 354, 353, 352, 351, 350, 349, 348, 344, 343, 342, 341, 335, 334, 333, 332, 331, 330, 329, 328, 327, 326, 325, 324, 323, 312, 311, 308, 307, 301, 300, 295, 294, 293, 292, 291, 290, 287, 278, 273, 272, 271, 264, 261, 256, 255, 254, 248, 247, 246, 245, 244, 243, 236, 232, 229, 228, 227, 226, 223, 222, 221, 220, 217, 209, 208, 199, 198, 197, 194, 189, 188, 187, 184, 183, 182, 176, 175, 174, 173, 168, 144, 121, 70, 54, 53, 50, 1819, 3, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819 } ; static yyconst flex_int16_t yy_chk[2048] = { 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 9, 12, 697, 12, 12, 12, 12, 12, 13, 99, 14, 13, 14, 14, 14, 14, 14, 15, 47, 15, 15, 15, 15, 15, 99, 14, 14, 21, 21, 23, 23, 25, 15, 15, 16, 25, 16, 16, 16, 16, 16, 81, 81, 44, 47, 44, 13, 25, 44, 16, 16, 9, 17, 14, 17, 17, 17, 17, 17, 18, 15, 18, 18, 18, 18, 18, 24, 17, 17, 31, 29, 76, 26, 31, 76, 18, 26, 16, 29, 26, 29, 29, 24, 29, 104, 26, 29, 92, 26, 29, 46, 27, 31, 24, 24, 17, 92, 104, 46, 27, 30, 24, 18, 27, 30, 24, 36, 27, 24, 24, 30, 30, 27, 28, 36, 32, 30, 27, 27, 28, 530, 28, 32, 28, 35, 80, 36, 32, 32, 698, 36, 28, 35, 28, 37, 37, 530, 35, 37, 36, 38, 39, 38, 39, 38, 36, 39, 37, 38, 39, 41, 42, 80, 37, 41, 42, 108, 83, 108, 42, 42, 83, 42, 41, 42, 42, 42, 94, 43, 42, 42, 701, 43, 125, 42, 43, 43, 94, 56, 56, 56, 56, 56, 125, 43, 61, 61, 61, 61, 61, 64, 43, 56, 64, 64, 64, 64, 64, 62, 61, 62, 62, 62, 62, 62, 87, 88, 109, 109, 705, 88, 87, 87, 87, 62, 88, 706, 91, 87, 56, 91, 106, 110, 110, 106, 91, 61, 106, 118, 91, 122, 123, 91, 127, 129, 122, 123, 127, 134, 118, 118, 62, 128, 128, 134, 118, 133, 133, 138, 136, 136, 129, 136, 138, 136, 118, 150, 156, 146, 136, 156, 153, 150, 136, 146, 136, 136, 153, 146, 149, 157, 149, 158, 707, 160, 146, 159, 149, 158, 160, 159, 177, 229, 157, 177, 177, 177, 177, 177, 178, 178, 178, 178, 178, 179, 708, 229, 179, 179, 179, 179, 179, 186, 178, 180, 180, 180, 180, 180, 181, 181, 181, 181, 181, 186, 211, 218, 256, 261, 224, 211, 218, 224, 273, 284, 282, 186, 284, 273, 299, 178, 282, 304, 407, 309, 304, 313, 469, 313, 315, 428, 428, 299, 469, 256, 261, 309, 397, 407, 304, 709, 315, 315, 315, 336, 336, 336, 336, 336, 337, 337, 337, 337, 337, 315, 338, 397, 547, 338, 338, 338, 338, 338, 339, 339, 339, 339, 339, 340, 340, 340, 340, 340, 423, 459, 459, 459, 486, 423, 500, 512, 512, 512, 512, 512, 710, 547, 711, 486, 513, 513, 513, 513, 513, 500, 514, 514, 514, 514, 514, 500, 500, 623, 639, 658, 665, 623, 500, 688, 712, 665, 687, 639, 658, 687, 687, 700, 700, 714, 713, 715, 716, 718, 719, 720, 721, 722, 688, 723, 724, 687, 713, 623, 725, 713, 726, 727, 728, 729, 730, 731, 732, 733, 734, 736, 737, 639, 738, 740, 741, 742, 742, 743, 744, 742, 745, 746, 747, 748, 749, 750, 742, 751, 754, 742, 755, 742, 742, 756, 757, 758, 759, 760, 761, 762, 763, 764, 765, 767, 768, 769, 770, 771, 772, 773, 774, 775, 776, 777, 778, 779, 780, 781, 782, 784, 785, 786, 789, 790, 791, 792, 793, 794, 795, 796, 798, 799, 800, 801, 802, 803, 804, 805, 806, 807, 808, 809, 810, 812, 813, 814, 815, 816, 817, 819, 820, 821, 822, 823, 824, 825, 826, 827, 828, 829, 830, 831, 832, 833, 834, 835, 836, 837, 838, 839, 841, 842, 843, 844, 845, 846, 847, 848, 849, 846, 850, 851, 852, 853, 854, 855, 856, 857, 858, 859, 860, 861, 863, 864, 865, 866, 867, 869, 870, 872, 873, 875, 865, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 893, 894, 896, 897, 898, 901, 889, 902, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 923, 924, 920, 925, 926, 928, 929, 930, 931, 932, 934, 936, 937, 938, 939, 940, 941, 943, 929, 944, 945, 946, 947, 948, 949, 950, 952, 953, 954, 955, 956, 957, 958, 959, 961, 962, 963, 964, 965, 966, 967, 968, 969, 970, 971, 972, 973, 974, 958, 975, 977, 958, 978, 979, 980, 981, 982, 984, 985, 986, 987, 988, 989, 991, 992, 993, 991, 994, 995, 996, 998, 991, 999, 1000, 991, 1001, 1003, 1004, 1006, 1008, 1010, 1013, 1014, 991, 1015, 1016, 1017, 1018, 1019, 1020, 1021, 1022, 1023, 1024, 1025, 1026, 1019, 1027, 1028, 1029, 1030, 1031, 1034, 1035, 1036, 1037, 1038, 1039, 1040, 1041, 1042, 1044, 1030, 1045, 1046, 1047, 1049, 1050, 1051, 1052, 1053, 1054, 1055, 1056, 1057, 1058, 1059, 1060, 1061, 1062, 1063, 1065, 1067, 1068, 1069, 1070, 1071, 1073, 1074, 1075, 1076, 1077, 1078, 1079, 1080, 1081, 1082, 1083, 1084, 1071, 1085, 1086, 1087, 1071, 1088, 1071, 1089, 1090, 1091, 1093, 1094, 1095, 1096, 1097, 1098, 1099, 1100, 1101, 1102, 1104, 1105, 1106, 1107, 1108, 1109, 1110, 1111, 1112, 1113, 1114, 1115, 1116, 1117, 1118, 1119, 1120, 1121, 1122, 1123, 1124, 1125, 1126, 1127, 1129, 1130, 1131, 1132, 1133, 1134, 1135, 1136, 1137, 1138, 1139, 1132, 1140, 1141, 1142, 1143, 1144, 1145, 1146, 1147, 1148, 1149, 1150, 1151, 1152, 1154, 1155, 1156, 1158, 1159, 1160, 1161, 1162, 1163, 1164, 1165, 1167, 1168, 1169, 1170, 1171, 1172, 1173, 1174, 1175, 1177, 1178, 1179, 1180, 1181, 1182, 1183, 1184, 1185, 1186, 1187, 1188, 1189, 1190, 1191, 1192, 1193, 1194, 1195, 1197, 1199, 1201, 1202, 1203, 1204, 1205, 1206, 1207, 1208, 1209, 1210, 1212, 1213, 1214, 1215, 1216, 1217, 1218, 1220, 1222, 1223, 1225, 1226, 1227, 1228, 1230, 1231, 1232, 1233, 1234, 1235, 1236, 1237, 1238, 1239, 1240, 1242, 1243, 1245, 1246, 1247, 1248, 1249, 1250, 1251, 1252, 1253, 1254, 1250, 1255, 1256, 1257, 1258, 1259, 1260, 1262, 1263, 1265, 1266, 1267, 1268, 1269, 1271, 1272, 1273, 1274, 1275, 1276, 1277, 1278, 1279, 1280, 1281, 1283, 1284, 1286, 1287, 1288, 1289, 1290, 1291, 1293, 1294, 1295, 1296, 1297, 1298, 1299, 1300, 1301, 1302, 1303, 1305, 1306, 1307, 1308, 1309, 1310, 1312, 1313, 1314, 1315, 1316, 1317, 1318, 1319, 1320, 1321, 1323, 1324, 1325, 1326, 1327, 1329, 1331, 1332, 1333, 1334, 1335, 1336, 1337, 1339, 1340, 1342, 1343, 1344, 1345, 1346, 1347, 1348, 1349, 1350, 1351, 1352, 1353, 1355, 1356, 1357, 1358, 1359, 1361, 1362, 1363, 1364, 1365, 1366, 1367, 1368, 1369, 1370, 1372, 1373, 1361, 1374, 1375, 1376, 1377, 1378, 1379, 1380, 1381, 1382, 1383, 1384, 1385, 1386, 1387, 1388, 1389, 1391, 1392, 1393, 1394, 1395, 1396, 1397, 1399, 1400, 1401, 1402, 1403, 1404, 1405, 1406, 1407, 1408, 1409, 1410, 1411, 1412, 1413, 1414, 1415, 1416, 1417, 1418, 1419, 1420, 1422, 1423, 1424, 1425, 1426, 1427, 1428, 1429, 1430, 1431, 1432, 1433, 1434, 1435, 1436, 1437, 1438, 1439, 1440, 1441, 1442, 1444, 1445, 1446, 1447, 1448, 1449, 1450, 1452, 1453, 1454, 1457, 1458, 1459, 1460, 1461, 1462, 1464, 1465, 1466, 1467, 1471, 1472, 1473, 1475, 1476, 1478, 1479, 1483, 1484, 1485, 1487, 1490, 1491, 1478, 1493, 1494, 1495, 1496, 1497, 1498, 1501, 1503, 1504, 1478, 1506, 1508, 1509, 1510, 1511, 1512, 1513, 1514, 1515, 1516, 1518, 1520, 1521, 1522, 1525, 1526, 1527, 1528, 1529, 1530, 1531, 1533, 1534, 1535, 1536, 1537, 1538, 1539, 1540, 1541, 1542, 1543, 1544, 1545, 1546, 1547, 1548, 1549, 1550, 1551, 1553, 1554, 1555, 1556, 1557, 1558, 1559, 1560, 1561, 1562, 1563, 1565, 1566, 1567, 1568, 1570, 1571, 1572, 1573, 1574, 1575, 1577, 1578, 1582, 1583, 1585, 1586, 1587, 1588, 1589, 1590, 1591, 1592, 1596, 1597, 1599, 1600, 1601, 1602, 1603, 1604, 1605, 1606, 1607, 1608, 1609, 1610, 1612, 1614, 1617, 1618, 1619, 1620, 1621, 1622, 1623, 1624, 1625, 1626, 1627, 1628, 1629, 1630, 1631, 1632, 1633, 1634, 1635, 1637, 1638, 1639, 1640, 1641, 1642, 1644, 1646, 1647, 1648, 1649, 1650, 1651, 1652, 1653, 1654, 1655, 1656, 1657, 1658, 1659, 1660, 1662, 1663, 1664, 1665, 1666, 1667, 1668, 1669, 1670, 1671, 1673, 1674, 1676, 1677, 1678, 1679, 1680, 1681, 1682, 1683, 1684, 1685, 1688, 1691, 1693, 1694, 1696, 1697, 1700, 1702, 1703, 1705, 1706, 1708, 1709, 1710, 1712, 1713, 1714, 1715, 1717, 1720, 1721, 1722, 1723, 1724, 1726, 1728, 1729, 1730, 1731, 1733, 1735, 1737, 1738, 1739, 1740, 1741, 1742, 1744, 1745, 1746, 1747, 1749, 1751, 1752, 1753, 1754, 1755, 1756, 1757, 1758, 1759, 1760, 1761, 1762, 1763, 1766, 1767, 1768, 1770, 1771, 1772, 1773, 1775, 1776, 1777, 1778, 1779, 1782, 1783, 1785, 1786, 1787, 1790, 1791, 1793, 1794, 1795, 1796, 1798, 1800, 1801, 1802, 1803, 1804, 1807, 1809, 1810, 1811, 1813, 1814, 1815, 1817, 1820, 696, 695, 694, 693, 692, 691, 690, 689, 686, 685, 684, 683, 682, 681, 680, 679, 677, 676, 675, 674, 673, 672, 671, 670, 669, 668, 666, 664, 663, 662, 660, 659, 657, 654, 653, 652, 651, 650, 649, 648, 647, 646, 645, 644, 643, 642, 641, 640, 638, 637, 636, 635, 634, 633, 632, 631, 630, 628, 627, 626, 625, 624, 622, 621, 620, 619, 618, 616, 615, 614, 613, 612, 611, 610, 609, 608, 605, 604, 603, 602, 601, 600, 599, 598, 597, 596, 595, 594, 593, 592, 591, 590, 589, 588, 587, 586, 584, 583, 582, 581, 580, 579, 577, 576, 575, 574, 573, 572, 570, 569, 567, 566, 565, 564, 563, 561, 560, 559, 558, 557, 556, 555, 554, 552, 551, 550, 548, 546, 545, 544, 543, 542, 541, 540, 538, 537, 536, 535, 533, 532, 531, 527, 526, 524, 523, 522, 520, 519, 518, 517, 516, 511, 510, 509, 508, 507, 506, 505, 504, 503, 501, 499, 497, 496, 494, 493, 492, 491, 490, 489, 488, 487, 485, 484, 482, 480, 479, 478, 474, 473, 472, 471, 470, 468, 467, 466, 465, 464, 461, 460, 457, 456, 455, 454, 453, 452, 451, 450, 449, 448, 447, 446, 445, 444, 443, 442, 441, 440, 439, 438, 437, 436, 435, 434, 433, 432, 431, 430, 429, 427, 426, 425, 424, 422, 421, 420, 419, 418, 417, 416, 415, 414, 413, 412, 411, 410, 409, 408, 406, 405, 404, 403, 402, 401, 400, 399, 398, 396, 394, 392, 389, 388, 387, 386, 384, 382, 380, 379, 378, 377, 376, 375, 374, 373, 372, 371, 370, 368, 367, 366, 365, 363, 362, 361, 360, 359, 356, 355, 353, 352, 351, 350, 348, 347, 346, 345, 344, 335, 334, 333, 332, 331, 330, 329, 328, 327, 326, 325, 324, 323, 322, 321, 320, 319, 318, 317, 316, 314, 312, 311, 310, 308, 307, 306, 305, 303, 302, 301, 300, 298, 297, 296, 295, 294, 293, 292, 291, 290, 289, 288, 287, 286, 285, 283, 281, 280, 279, 278, 277, 276, 275, 274, 272, 271, 270, 269, 268, 267, 266, 265, 264, 263, 262, 260, 259, 258, 257, 255, 253, 252, 251, 250, 249, 248, 247, 246, 245, 244, 243, 242, 241, 240, 239, 238, 237, 236, 235, 234, 233, 232, 231, 230, 228, 226, 225, 223, 222, 221, 220, 219, 217, 216, 215, 214, 213, 212, 210, 209, 208, 207, 206, 205, 204, 203, 202, 201, 200, 199, 198, 197, 196, 195, 194, 193, 192, 191, 190, 189, 188, 185, 184, 183, 182, 175, 172, 171, 170, 169, 168, 167, 166, 165, 164, 163, 162, 161, 155, 154, 152, 151, 148, 147, 145, 144, 143, 142, 141, 139, 137, 135, 132, 131, 130, 126, 124, 121, 120, 119, 116, 115, 114, 113, 112, 111, 107, 105, 103, 102, 101, 100, 98, 97, 96, 95, 93, 90, 89, 86, 85, 84, 82, 79, 78, 77, 75, 74, 73, 55, 52, 49, 48, 45, 40, 33, 22, 11, 10, 7, 3, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819, 1819 } ; static yy_state_type yy_last_accepting_state; static char *yy_last_accepting_cpos; extern int getdp_yy_flex_debug; int getdp_yy_flex_debug = 0; /* The intent behind this definition is that it'll catch * any uses of REJECT which flex missed. */ #define REJECT reject_used_but_not_detected #define yymore() yymore_used_but_not_detected #define YY_MORE_ADJ 0 #define YY_RESTORE_YY_MORE_OFFSET char *getdp_yytext; #line 1 "ProParser.l" #line 2 "ProParser.l" // GetDP - Copyright (C) 1997-2008 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include #include #include "ProData.h" #include "ProParser.h" #include "ProParser.tab.hpp" #include "MallocUtils.h" #include "Message.h" // Redefinition of YY_INPUT to allow input character count (this is // slower than fread(), but the .pro files are never that big) #ifdef YY_INPUT #undef YY_INPUT #endif #define YY_INPUT(buf,result,max_size) { \ int c = getc(getdp_yyin); \ getdp_yycolnum++; \ result = (c == EOF) ? YY_NULL : (buf[0] = c, 1); \ } #line 1549 "ProParser.yy.cpp" #define INITIAL 0 #ifndef YY_NO_UNISTD_H /* Special case for "unistd.h", since it is non-ANSI. We include it way * down here because we want the user's section 1 to have been scanned first. * The user has a chance to override it with an option. */ #include #endif #ifndef YY_EXTRA_TYPE #define YY_EXTRA_TYPE void * #endif static int yy_init_globals (void ); /* Accessor methods to globals. These are made visible to non-reentrant scanners for convenience. */ int getdp_yylex_destroy (void ); int getdp_yyget_debug (void ); void getdp_yyset_debug (int debug_flag ); YY_EXTRA_TYPE getdp_yyget_extra (void ); void getdp_yyset_extra (YY_EXTRA_TYPE user_defined ); FILE *getdp_yyget_in (void ); void getdp_yyset_in (FILE * in_str ); FILE *getdp_yyget_out (void ); void getdp_yyset_out (FILE * out_str ); yy_size_t getdp_yyget_leng (void ); char *getdp_yyget_text (void ); int getdp_yyget_lineno (void ); void getdp_yyset_lineno (int line_number ); /* Macros after this point can all be overridden by user definitions in * section 1. */ #ifndef YY_SKIP_YYWRAP #ifdef __cplusplus extern "C" int getdp_yywrap (void ); #else extern int getdp_yywrap (void ); #endif #endif static void yyunput (int c,char *buf_ptr ); #ifndef yytext_ptr static void yy_flex_strncpy (char *,yyconst char *,int ); #endif #ifdef YY_NEED_STRLEN static int yy_flex_strlen (yyconst char * ); #endif #ifndef YY_NO_INPUT #ifdef __cplusplus static int yyinput (void ); #else static int input (void ); #endif #endif /* Amount of stuff to slurp up with each read. */ #ifndef YY_READ_BUF_SIZE #define YY_READ_BUF_SIZE 8192 #endif /* Copy whatever the last rule matched to the standard output. */ #ifndef ECHO /* This used to be an fputs(), but since the string might contain NUL's, * we now use fwrite(). */ #define ECHO fwrite( getdp_yytext, getdp_yyleng, 1, getdp_yyout ) #endif /* Gets input and stuffs it into "buf". number of characters read, or YY_NULL, * is returned in "result". */ #ifndef YY_INPUT #define YY_INPUT(buf,result,max_size) \ if ( YY_CURRENT_BUFFER_LVALUE->yy_is_interactive ) \ { \ int c = '*'; \ yy_size_t n; \ for ( n = 0; n < max_size && \ (c = getc( getdp_yyin )) != EOF && c != '\n'; ++n ) \ buf[n] = (char) c; \ if ( c == '\n' ) \ buf[n++] = (char) c; \ if ( c == EOF && ferror( getdp_yyin ) ) \ YY_FATAL_ERROR( "input in flex scanner failed" ); \ result = n; \ } \ else \ { \ errno=0; \ while ( (result = fread(buf, 1, max_size, getdp_yyin))==0 && ferror(getdp_yyin)) \ { \ if( errno != EINTR) \ { \ YY_FATAL_ERROR( "input in flex scanner failed" ); \ break; \ } \ errno=0; \ clearerr(getdp_yyin); \ } \ }\ \ #endif /* No semi-colon after return; correct usage is to write "yyterminate();" - * we don't want an extra ';' after the "return" because that will cause * some compilers to complain about unreachable statements. */ #ifndef yyterminate #define yyterminate() return YY_NULL #endif /* Number of entries by which start-condition stack grows. */ #ifndef YY_START_STACK_INCR #define YY_START_STACK_INCR 25 #endif /* Report a fatal error. */ #ifndef YY_FATAL_ERROR #define YY_FATAL_ERROR(msg) yy_fatal_error( msg ) #endif /* end tables serialization structures and prototypes */ /* Default declaration of generated scanner - a define so the user can * easily add parameters. */ #ifndef YY_DECL #define YY_DECL_IS_OURS 1 extern int getdp_yylex (void); #define YY_DECL int getdp_yylex (void) #endif /* !YY_DECL */ /* Code executed at the beginning of each rule, after getdp_yytext and getdp_yyleng * have been set up. */ #ifndef YY_USER_ACTION #define YY_USER_ACTION #endif /* Code executed at the end of each rule. */ #ifndef YY_BREAK #define YY_BREAK break; #endif #define YY_RULE_SETUP \ YY_USER_ACTION /** The main scanner function which does all the work. */ YY_DECL { register yy_state_type yy_current_state; register char *yy_cp, *yy_bp; register int yy_act; #line 35 "ProParser.l" #line 1734 "ProParser.yy.cpp" if ( !(yy_init) ) { (yy_init) = 1; #ifdef YY_USER_INIT YY_USER_INIT; #endif if ( ! (yy_start) ) (yy_start) = 1; /* first start state */ if ( ! getdp_yyin ) getdp_yyin = stdin; if ( ! getdp_yyout ) getdp_yyout = stdout; if ( ! YY_CURRENT_BUFFER ) { getdp_yyensure_buffer_stack (); YY_CURRENT_BUFFER_LVALUE = getdp_yy_create_buffer(getdp_yyin,YY_BUF_SIZE ); } getdp_yy_load_buffer_state( ); } while ( 1 ) /* loops until end-of-file is reached */ { yy_cp = (yy_c_buf_p); /* Support of getdp_yytext. */ *yy_cp = (yy_hold_char); /* yy_bp points to the position in yy_ch_buf of the start of * the current run. */ yy_bp = yy_cp; yy_current_state = (yy_start); yy_match: do { register YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)]; if ( yy_accept[yy_current_state] ) { (yy_last_accepting_state) = yy_current_state; (yy_last_accepting_cpos) = yy_cp; } while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) { yy_current_state = (int) yy_def[yy_current_state]; if ( yy_current_state >= 1820 ) yy_c = yy_meta[(unsigned int) yy_c]; } yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; ++yy_cp; } while ( yy_base[yy_current_state] != 1972 ); yy_find_action: yy_act = yy_accept[yy_current_state]; if ( yy_act == 0 ) { /* have to back up */ yy_cp = (yy_last_accepting_cpos); yy_current_state = (yy_last_accepting_state); yy_act = yy_accept[yy_current_state]; } YY_DO_BEFORE_ACTION; do_action: /* This label is used only to access EOF actions. */ switch ( yy_act ) { /* beginning of action switch */ case 0: /* must back up */ /* undo the effects of YY_DO_BEFORE_ACTION */ *yy_cp = (yy_hold_char); yy_cp = (yy_last_accepting_cpos); yy_current_state = (yy_last_accepting_state); goto yy_find_action; case 1: YY_RULE_SETUP #line 37 "ProParser.l" /* nothing to do */; YY_BREAK case 2: /* rule 2 can match eol */ YY_RULE_SETUP #line 38 "ProParser.l" { getdp_yycolnum = 0; getdp_yylinenum++; } YY_BREAK case YY_STATE_EOF(INITIAL): #line 39 "ProParser.l" { getdp_yyincludenum = 0; return(0); } YY_BREAK case 3: YY_RULE_SETUP #line 41 "ProParser.l" return tEND; YY_BREAK case 4: YY_RULE_SETUP #line 42 "ProParser.l" cStyleComments(); YY_BREAK case 5: YY_RULE_SETUP #line 43 "ProParser.l" cxxStyleComments(); YY_BREAK case 6: YY_RULE_SETUP #line 44 "ProParser.l" { parseString('\"'); return tBIGSTR; } YY_BREAK case 7: YY_RULE_SETUP #line 46 "ProParser.l" return tDEF; YY_BREAK case 8: YY_RULE_SETUP #line 47 "ProParser.l" return tCROSSPRODUCT; YY_BREAK case 9: YY_RULE_SETUP #line 48 "ProParser.l" return tCROSSPRODUCT; YY_BREAK case 10: YY_RULE_SETUP #line 49 "ProParser.l" return tOR; YY_BREAK case 11: YY_RULE_SETUP #line 50 "ProParser.l" return tAND; YY_BREAK case 12: YY_RULE_SETUP #line 51 "ProParser.l" return tEQUAL; YY_BREAK case 13: YY_RULE_SETUP #line 52 "ProParser.l" return tNOTEQUAL; YY_BREAK case 14: YY_RULE_SETUP #line 53 "ProParser.l" return tAPPROXEQUAL; YY_BREAK case 15: YY_RULE_SETUP #line 54 "ProParser.l" return tLESSOREQUAL; YY_BREAK case 16: YY_RULE_SETUP #line 55 "ProParser.l" return tGREATEROREQUAL; YY_BREAK case 17: YY_RULE_SETUP #line 56 "ProParser.l" return tGREATERGREATER; YY_BREAK case 18: YY_RULE_SETUP #line 57 "ProParser.l" return tLESSLESS; YY_BREAK case 19: YY_RULE_SETUP #line 58 "ProParser.l" return tDOTS; YY_BREAK case 20: YY_RULE_SETUP #line 59 "ProParser.l" return tDOTS; YY_BREAK case 21: YY_RULE_SETUP #line 60 "ProParser.l" return tSHOW; YY_BREAK case 22: YY_RULE_SETUP #line 62 "ProParser.l" return tStrCat; YY_BREAK case 23: YY_RULE_SETUP #line 63 "ProParser.l" return tSprintf; YY_BREAK case 24: YY_RULE_SETUP #line 64 "ProParser.l" return tPrintf; YY_BREAK case 25: YY_RULE_SETUP #line 65 "ProParser.l" return tRead; YY_BREAK case 26: YY_RULE_SETUP #line 66 "ProParser.l" return tPrintConstants; YY_BREAK case 27: YY_RULE_SETUP #line 67 "ProParser.l" return tStrCmp ; YY_BREAK case 28: YY_RULE_SETUP #line 68 "ProParser.l" return tNbrRegions ; YY_BREAK case 29: YY_RULE_SETUP #line 70 "ProParser.l" return tPi; YY_BREAK case 30: YY_RULE_SETUP #line 71 "ProParser.l" return t0D; YY_BREAK case 31: YY_RULE_SETUP #line 72 "ProParser.l" return t1D; YY_BREAK case 32: YY_RULE_SETUP #line 73 "ProParser.l" return t2D; YY_BREAK case 33: YY_RULE_SETUP #line 74 "ProParser.l" return t3D; YY_BREAK case 34: YY_RULE_SETUP #line 75 "ProParser.l" return tMPI_Rank; YY_BREAK case 35: YY_RULE_SETUP #line 76 "ProParser.l" return tMPI_Size; YY_BREAK case 36: YY_RULE_SETUP #line 78 "ProParser.l" return tInclude; YY_BREAK case 37: YY_RULE_SETUP #line 79 "ProParser.l" return tInclude; YY_BREAK case 38: YY_RULE_SETUP #line 81 "ProParser.l" return tConstant; YY_BREAK case 39: YY_RULE_SETUP #line 82 "ProParser.l" return tConstant; YY_BREAK case 40: YY_RULE_SETUP #line 84 "ProParser.l" return tGroup; YY_BREAK case 41: YY_RULE_SETUP #line 85 "ProParser.l" return tDefineGroup; YY_BREAK case 42: YY_RULE_SETUP #line 86 "ProParser.l" return tAll; YY_BREAK case 43: YY_RULE_SETUP #line 87 "ProParser.l" return tInSupport; YY_BREAK case 44: YY_RULE_SETUP #line 88 "ProParser.l" return tMovingBand2D; YY_BREAK case 45: YY_RULE_SETUP #line 89 "ProParser.l" return tSaveMesh; YY_BREAK case 46: YY_RULE_SETUP #line 90 "ProParser.l" return tDeformeMesh; YY_BREAK case 47: YY_RULE_SETUP #line 91 "ProParser.l" return tDeformeMesh; YY_BREAK case 48: YY_RULE_SETUP #line 93 "ProParser.l" return tDefineFunction; YY_BREAK case 49: YY_RULE_SETUP #line 94 "ProParser.l" return tDefineConstant; YY_BREAK case 50: YY_RULE_SETUP #line 95 "ProParser.l" return tDefineConstant; YY_BREAK case 51: YY_RULE_SETUP #line 96 "ProParser.l" return tUndefineConstant; YY_BREAK case 52: YY_RULE_SETUP #line 98 "ProParser.l" return tList; YY_BREAK case 53: YY_RULE_SETUP #line 99 "ProParser.l" return tListAlt; YY_BREAK case 54: YY_RULE_SETUP #line 100 "ProParser.l" return tListFromFile; YY_BREAK case 55: YY_RULE_SETUP #line 102 "ProParser.l" return tExp; YY_BREAK case 56: YY_RULE_SETUP #line 103 "ProParser.l" return tLog; YY_BREAK case 57: YY_RULE_SETUP #line 104 "ProParser.l" return tLog10; YY_BREAK case 58: YY_RULE_SETUP #line 105 "ProParser.l" return tSqrt; YY_BREAK case 59: YY_RULE_SETUP #line 106 "ProParser.l" return tSin; YY_BREAK case 60: YY_RULE_SETUP #line 107 "ProParser.l" return tAsin; YY_BREAK case 61: YY_RULE_SETUP #line 108 "ProParser.l" return tAsin; YY_BREAK case 62: YY_RULE_SETUP #line 109 "ProParser.l" return tCos; YY_BREAK case 63: YY_RULE_SETUP #line 110 "ProParser.l" return tAcos; YY_BREAK case 64: YY_RULE_SETUP #line 111 "ProParser.l" return tAcos; YY_BREAK case 65: YY_RULE_SETUP #line 112 "ProParser.l" return tTan; YY_BREAK case 66: YY_RULE_SETUP #line 113 "ProParser.l" return tAtan; YY_BREAK case 67: YY_RULE_SETUP #line 114 "ProParser.l" return tAtan2; YY_BREAK case 68: YY_RULE_SETUP #line 115 "ProParser.l" return tSinh; YY_BREAK case 69: YY_RULE_SETUP #line 116 "ProParser.l" return tCosh; YY_BREAK case 70: YY_RULE_SETUP #line 117 "ProParser.l" return tTanh; YY_BREAK case 71: YY_RULE_SETUP #line 118 "ProParser.l" return tFabs; YY_BREAK case 72: YY_RULE_SETUP #line 119 "ProParser.l" return tFloor; YY_BREAK case 73: YY_RULE_SETUP #line 120 "ProParser.l" return tCeil; YY_BREAK case 74: YY_RULE_SETUP #line 121 "ProParser.l" return tRound; YY_BREAK case 75: YY_RULE_SETUP #line 122 "ProParser.l" return tSign; YY_BREAK case 76: YY_RULE_SETUP #line 123 "ProParser.l" return tFmod; YY_BREAK case 77: YY_RULE_SETUP #line 124 "ProParser.l" return tModulo; YY_BREAK case 78: YY_RULE_SETUP #line 125 "ProParser.l" return tHypot; YY_BREAK case 79: YY_RULE_SETUP #line 126 "ProParser.l" return tRand; YY_BREAK case 80: YY_RULE_SETUP #line 127 "ProParser.l" return tCrossProduct; YY_BREAK case 81: YY_RULE_SETUP #line 128 "ProParser.l" return tCrossProduct; YY_BREAK case 82: YY_RULE_SETUP #line 129 "ProParser.l" return tSolidAngle; YY_BREAK case 83: YY_RULE_SETUP #line 130 "ProParser.l" return tOrder; YY_BREAK case 84: YY_RULE_SETUP #line 131 "ProParser.l" return tTrace; YY_BREAK case 85: YY_RULE_SETUP #line 132 "ProParser.l" return tDofValue; YY_BREAK case 86: YY_RULE_SETUP #line 133 "ProParser.l" return tLinSpace; YY_BREAK case 87: YY_RULE_SETUP #line 134 "ProParser.l" return tLogSpace; YY_BREAK case 88: YY_RULE_SETUP #line 136 "ProParser.l" return tMHTransform; YY_BREAK case 89: YY_RULE_SETUP #line 137 "ProParser.l" return tMHJacNL; YY_BREAK case 90: YY_RULE_SETUP #line 139 "ProParser.l" return tConstraint; YY_BREAK case 91: YY_RULE_SETUP #line 140 "ProParser.l" return tRegion; YY_BREAK case 92: YY_RULE_SETUP #line 141 "ProParser.l" return tSubRegion; YY_BREAK case 93: YY_RULE_SETUP #line 142 "ProParser.l" return tRegionRef; YY_BREAK case 94: YY_RULE_SETUP #line 143 "ProParser.l" return tSubRegionRef; YY_BREAK case 95: YY_RULE_SETUP #line 144 "ProParser.l" return tCoefficient; YY_BREAK case 96: YY_RULE_SETUP #line 145 "ProParser.l" return tFilter; YY_BREAK case 97: YY_RULE_SETUP #line 146 "ProParser.l" return tValue; YY_BREAK case 98: YY_RULE_SETUP #line 147 "ProParser.l" return tTimeFunction; YY_BREAK case 99: YY_RULE_SETUP #line 148 "ProParser.l" return tBranch; YY_BREAK case 100: YY_RULE_SETUP #line 149 "ProParser.l" return tNameOfResolution; YY_BREAK case 101: YY_RULE_SETUP #line 151 "ProParser.l" return tJacobian; YY_BREAK case 102: YY_RULE_SETUP #line 152 "ProParser.l" return tMetricTensor; YY_BREAK case 103: YY_RULE_SETUP #line 153 "ProParser.l" return tCase; YY_BREAK case 104: YY_RULE_SETUP #line 155 "ProParser.l" return tIntegration; YY_BREAK case 105: YY_RULE_SETUP #line 156 "ProParser.l" return tMatrix; YY_BREAK case 106: YY_RULE_SETUP #line 157 "ProParser.l" return tCriterion; YY_BREAK case 107: YY_RULE_SETUP #line 158 "ProParser.l" return tGeoElement; YY_BREAK case 108: YY_RULE_SETUP #line 159 "ProParser.l" return tNumberOfPoints; YY_BREAK case 109: YY_RULE_SETUP #line 160 "ProParser.l" return tMaxNumberOfPoints; YY_BREAK case 110: YY_RULE_SETUP #line 161 "ProParser.l" return tNumberOfDivisions; YY_BREAK case 111: YY_RULE_SETUP #line 162 "ProParser.l" return tMaxNumberOfDivisions; YY_BREAK case 112: YY_RULE_SETUP #line 163 "ProParser.l" return tStoppingCriterion; YY_BREAK case 113: YY_RULE_SETUP #line 165 "ProParser.l" return tFunctionSpace; YY_BREAK case 114: YY_RULE_SETUP #line 166 "ProParser.l" return tName; YY_BREAK case 115: YY_RULE_SETUP #line 167 "ProParser.l" return tType; YY_BREAK case 116: YY_RULE_SETUP #line 168 "ProParser.l" return tSubType; YY_BREAK case 117: YY_RULE_SETUP #line 169 "ProParser.l" return tBasisFunction; YY_BREAK case 118: YY_RULE_SETUP #line 170 "ProParser.l" return tNameOfCoef; YY_BREAK case 119: YY_RULE_SETUP #line 171 "ProParser.l" return tFunction; YY_BREAK case 120: YY_RULE_SETUP #line 172 "ProParser.l" return tdFunction; YY_BREAK case 121: YY_RULE_SETUP #line 173 "ProParser.l" return tSubFunction; YY_BREAK case 122: YY_RULE_SETUP #line 174 "ProParser.l" return tSubdFunction; YY_BREAK case 123: YY_RULE_SETUP #line 175 "ProParser.l" return tSupport; YY_BREAK case 124: YY_RULE_SETUP #line 176 "ProParser.l" return tEntity; YY_BREAK case 125: YY_RULE_SETUP #line 177 "ProParser.l" return tSubSpace; YY_BREAK case 126: YY_RULE_SETUP #line 178 "ProParser.l" return tNameOfBasisFunction; YY_BREAK case 127: YY_RULE_SETUP #line 179 "ProParser.l" return tGlobalQuantity; YY_BREAK case 128: YY_RULE_SETUP #line 180 "ProParser.l" return tEntityType; YY_BREAK case 129: YY_RULE_SETUP #line 181 "ProParser.l" return tEntitySubType; YY_BREAK case 130: YY_RULE_SETUP #line 182 "ProParser.l" return tNameOfConstraint; YY_BREAK case 131: YY_RULE_SETUP #line 184 "ProParser.l" return tFormulation; YY_BREAK case 132: YY_RULE_SETUP #line 185 "ProParser.l" return tQuantity; YY_BREAK case 133: YY_RULE_SETUP #line 186 "ProParser.l" return tNameOfSpace; YY_BREAK case 134: YY_RULE_SETUP #line 187 "ProParser.l" return tIndexOfSystem; YY_BREAK case 135: YY_RULE_SETUP #line 188 "ProParser.l" return tSymmetry; YY_BREAK case 136: YY_RULE_SETUP #line 189 "ProParser.l" return tGalerkin; YY_BREAK case 137: YY_RULE_SETUP #line 190 "ProParser.l" return tdeRham; YY_BREAK case 138: YY_RULE_SETUP #line 192 "ProParser.l" return tDt; YY_BREAK case 139: YY_RULE_SETUP #line 193 "ProParser.l" return tDtDof; YY_BREAK case 140: YY_RULE_SETUP #line 194 "ProParser.l" return tDtDt; YY_BREAK case 141: YY_RULE_SETUP #line 195 "ProParser.l" return tDtDtDof; YY_BREAK case 142: YY_RULE_SETUP #line 196 "ProParser.l" return tJacNL; YY_BREAK case 143: YY_RULE_SETUP #line 197 "ProParser.l" return tDtDofJacNL; YY_BREAK case 144: YY_RULE_SETUP #line 198 "ProParser.l" return tNeverDt; YY_BREAK case 145: YY_RULE_SETUP #line 199 "ProParser.l" return tDtNL; YY_BREAK case 146: YY_RULE_SETUP #line 200 "ProParser.l" return tAtAnteriorTimeStep; YY_BREAK case 147: YY_RULE_SETUP #line 202 "ProParser.l" return tIn; YY_BREAK case 148: YY_RULE_SETUP #line 203 "ProParser.l" return tFull_Matrix; YY_BREAK case 149: YY_RULE_SETUP #line 204 "ProParser.l" return tGlobalTerm; YY_BREAK case 150: YY_RULE_SETUP #line 205 "ProParser.l" return tGlobalEquation; YY_BREAK case 151: YY_RULE_SETUP #line 207 "ProParser.l" return tResolution; YY_BREAK case 152: YY_RULE_SETUP #line 208 "ProParser.l" return tDefineSystem; YY_BREAK case 153: YY_RULE_SETUP #line 209 "ProParser.l" return tNameOfFormulation; YY_BREAK case 154: YY_RULE_SETUP #line 210 "ProParser.l" return tNameOfMesh; YY_BREAK case 155: YY_RULE_SETUP #line 211 "ProParser.l" return tFrequency; YY_BREAK case 156: YY_RULE_SETUP #line 212 "ProParser.l" return tDummyFrequency; YY_BREAK case 157: YY_RULE_SETUP #line 213 "ProParser.l" return tSolver; YY_BREAK case 158: YY_RULE_SETUP #line 214 "ProParser.l" return tOriginSystem; YY_BREAK case 159: YY_RULE_SETUP #line 215 "ProParser.l" return tDestinationSystem; YY_BREAK case 160: YY_RULE_SETUP #line 217 "ProParser.l" return tOperation; YY_BREAK case 161: YY_RULE_SETUP #line 218 "ProParser.l" return tOperationEnd; YY_BREAK case 162: YY_RULE_SETUP #line 219 "ProParser.l" return tSetTime; YY_BREAK case 163: YY_RULE_SETUP #line 220 "ProParser.l" return tSetFrequency; YY_BREAK case 164: YY_RULE_SETUP #line 221 "ProParser.l" return tUpdate; YY_BREAK case 165: YY_RULE_SETUP #line 222 "ProParser.l" return tUpdateConstraint; YY_BREAK case 166: YY_RULE_SETUP #line 223 "ProParser.l" return tGenerateOnly; YY_BREAK case 167: YY_RULE_SETUP #line 224 "ProParser.l" return tGenerateOnlyJac; YY_BREAK case 168: YY_RULE_SETUP #line 225 "ProParser.l" return tFourierTransform; YY_BREAK case 169: YY_RULE_SETUP #line 226 "ProParser.l" return tFourierTransformJ; YY_BREAK case 170: YY_RULE_SETUP #line 227 "ProParser.l" return tLanczos; YY_BREAK case 171: YY_RULE_SETUP #line 228 "ProParser.l" return tEigenSolve; YY_BREAK case 172: YY_RULE_SETUP #line 229 "ProParser.l" return tEigenSolveJac; YY_BREAK case 173: YY_RULE_SETUP #line 230 "ProParser.l" return tEvaluate; YY_BREAK case 174: YY_RULE_SETUP #line 231 "ProParser.l" return tSelectCorrection ; YY_BREAK case 175: YY_RULE_SETUP #line 232 "ProParser.l" return tAddCorrection ; YY_BREAK case 176: YY_RULE_SETUP #line 233 "ProParser.l" return tMultiplySolution ; YY_BREAK case 177: YY_RULE_SETUP #line 234 "ProParser.l" return tAddOppositeFullSolution ; YY_BREAK case 178: YY_RULE_SETUP #line 235 "ProParser.l" return tSolveAgainWithOther; YY_BREAK case 179: YY_RULE_SETUP #line 236 "ProParser.l" return tIf; YY_BREAK case 180: YY_RULE_SETUP #line 237 "ProParser.l" return tTimeLoopTheta; YY_BREAK case 181: YY_RULE_SETUP #line 238 "ProParser.l" return tTimeLoopNewmark; YY_BREAK case 182: YY_RULE_SETUP #line 239 "ProParser.l" return tTimeLoopRungeKutta; YY_BREAK case 183: YY_RULE_SETUP #line 240 "ProParser.l" return tTimeLoopAdaptive; YY_BREAK case 184: YY_RULE_SETUP #line 241 "ProParser.l" return tTime0; YY_BREAK case 185: YY_RULE_SETUP #line 242 "ProParser.l" return tTimeMax; YY_BREAK case 186: YY_RULE_SETUP #line 243 "ProParser.l" return tDTime; YY_BREAK case 187: YY_RULE_SETUP #line 244 "ProParser.l" return tTheta; YY_BREAK case 188: YY_RULE_SETUP #line 245 "ProParser.l" return tBeta; YY_BREAK case 189: YY_RULE_SETUP #line 246 "ProParser.l" return tGamma; YY_BREAK case 190: YY_RULE_SETUP #line 247 "ProParser.l" return tIterativeLoop; YY_BREAK case 191: YY_RULE_SETUP #line 248 "ProParser.l" return tIterativeLoopN; YY_BREAK case 192: YY_RULE_SETUP #line 249 "ProParser.l" return tIterativeLinearSolver; YY_BREAK case 193: YY_RULE_SETUP #line 250 "ProParser.l" return tNbrMaxIteration; YY_BREAK case 194: YY_RULE_SETUP #line 251 "ProParser.l" return tRelaxationFactor; YY_BREAK case 195: YY_RULE_SETUP #line 252 "ProParser.l" return tIterativeTimeReduction; YY_BREAK case 196: YY_RULE_SETUP #line 253 "ProParser.l" return tDivisionCoefficient; YY_BREAK case 197: YY_RULE_SETUP #line 254 "ProParser.l" return tChangeOfState; YY_BREAK case 198: YY_RULE_SETUP #line 255 "ProParser.l" return tChangeOfCoordinates; YY_BREAK case 199: YY_RULE_SETUP #line 256 "ProParser.l" return tChangeOfCoordinates2; YY_BREAK case 200: YY_RULE_SETUP #line 257 "ProParser.l" return tChangeOfValues; YY_BREAK case 201: YY_RULE_SETUP #line 258 "ProParser.l" return tSystemCommand; YY_BREAK case 202: YY_RULE_SETUP #line 259 "ProParser.l" return tGmshRead; YY_BREAK case 203: YY_RULE_SETUP #line 260 "ProParser.l" return tGmshClearAll; YY_BREAK case 204: YY_RULE_SETUP #line 261 "ProParser.l" return tDeleteFile; YY_BREAK case 205: YY_RULE_SETUP #line 262 "ProParser.l" return tCreateDir; YY_BREAK case 206: YY_RULE_SETUP #line 263 "ProParser.l" return tCreateDir; YY_BREAK case 207: YY_RULE_SETUP #line 264 "ProParser.l" return tBreak; YY_BREAK case 208: YY_RULE_SETUP #line 265 "ProParser.l" return tSolveJac_AdaptRelax; YY_BREAK case 209: YY_RULE_SETUP #line 266 "ProParser.l" return tTensorProductSolve; YY_BREAK case 210: YY_RULE_SETUP #line 267 "ProParser.l" return tSaveSolutionWithEntityNum; YY_BREAK case 211: YY_RULE_SETUP #line 268 "ProParser.l" return tSaveSolutionExtendedMH; YY_BREAK case 212: YY_RULE_SETUP #line 269 "ProParser.l" return tSaveSolutionMHtoTime; YY_BREAK case 213: YY_RULE_SETUP #line 270 "ProParser.l" return tInitMovingBand2D; YY_BREAK case 214: YY_RULE_SETUP #line 271 "ProParser.l" return tMeshMovingBand2D; YY_BREAK case 215: YY_RULE_SETUP #line 272 "ProParser.l" return tGenerate_MH_Moving; YY_BREAK case 216: YY_RULE_SETUP #line 273 "ProParser.l" return tGenerate_MH_Moving_Separate; YY_BREAK case 217: YY_RULE_SETUP #line 274 "ProParser.l" return tAdd_MH_Moving; YY_BREAK case 218: YY_RULE_SETUP #line 275 "ProParser.l" return tGenerateGroup; YY_BREAK case 219: YY_RULE_SETUP #line 276 "ProParser.l" return tGenerateJacGroup; YY_BREAK case 220: YY_RULE_SETUP #line 277 "ProParser.l" return tGenerateRHSGroup; YY_BREAK case 221: YY_RULE_SETUP #line 278 "ProParser.l" return tSetCommSelf; YY_BREAK case 222: YY_RULE_SETUP #line 279 "ProParser.l" return tSetCommWorld; YY_BREAK case 223: YY_RULE_SETUP #line 280 "ProParser.l" return tBarrier; YY_BREAK case 224: YY_RULE_SETUP #line 282 "ProParser.l" return tPostProcessing; YY_BREAK case 225: YY_RULE_SETUP #line 283 "ProParser.l" return tNameOfSystem; YY_BREAK case 226: YY_RULE_SETUP #line 285 "ProParser.l" return tPostOperation; YY_BREAK case 227: YY_RULE_SETUP #line 286 "ProParser.l" return tNameOfPostProcessing; YY_BREAK case 228: YY_RULE_SETUP #line 287 "ProParser.l" return tUsingPost; YY_BREAK case 229: YY_RULE_SETUP #line 288 "ProParser.l" return tAppend; YY_BREAK case 230: YY_RULE_SETUP #line 289 "ProParser.l" return tResampleTime; YY_BREAK case 231: YY_RULE_SETUP #line 290 "ProParser.l" return tPlot; YY_BREAK case 232: YY_RULE_SETUP #line 291 "ProParser.l" return tPrint; YY_BREAK case 233: YY_RULE_SETUP #line 292 "ProParser.l" return tPrintGroup; YY_BREAK case 234: YY_RULE_SETUP #line 293 "ProParser.l" return tEcho; YY_BREAK case 235: YY_RULE_SETUP #line 294 "ProParser.l" return tAdapt; YY_BREAK case 236: YY_RULE_SETUP #line 295 "ProParser.l" return tWrite; YY_BREAK case 237: YY_RULE_SETUP #line 296 "ProParser.l" return tOnGlobal; YY_BREAK case 238: YY_RULE_SETUP #line 297 "ProParser.l" return tOnRegion; YY_BREAK case 239: YY_RULE_SETUP #line 298 "ProParser.l" return tOnElementsOf; YY_BREAK case 240: YY_RULE_SETUP #line 299 "ProParser.l" return tOnGrid; YY_BREAK case 241: YY_RULE_SETUP #line 300 "ProParser.l" return tOnSection; YY_BREAK case 242: YY_RULE_SETUP #line 301 "ProParser.l" return tOnSection; YY_BREAK case 243: YY_RULE_SETUP #line 302 "ProParser.l" return tOnPoint; YY_BREAK case 244: YY_RULE_SETUP #line 303 "ProParser.l" return tOnLine; YY_BREAK case 245: YY_RULE_SETUP #line 304 "ProParser.l" return tOnPlane; YY_BREAK case 246: YY_RULE_SETUP #line 305 "ProParser.l" return tOnBox; YY_BREAK case 247: YY_RULE_SETUP #line 306 "ProParser.l" return tWithArgument; YY_BREAK case 248: YY_RULE_SETUP #line 307 "ProParser.l" return tSmoothing; YY_BREAK case 249: YY_RULE_SETUP #line 308 "ProParser.l" return tSkin; YY_BREAK case 250: YY_RULE_SETUP #line 309 "ProParser.l" return tFormat; YY_BREAK case 251: YY_RULE_SETUP #line 310 "ProParser.l" return tFooter; YY_BREAK case 252: YY_RULE_SETUP #line 311 "ProParser.l" return tHeader; YY_BREAK case 253: YY_RULE_SETUP #line 312 "ProParser.l" return tDepth; YY_BREAK case 254: YY_RULE_SETUP #line 313 "ProParser.l" return tDimension; YY_BREAK case 255: YY_RULE_SETUP #line 314 "ProParser.l" return tComma; YY_BREAK case 256: YY_RULE_SETUP #line 315 "ProParser.l" return tValueIndex; YY_BREAK case 257: YY_RULE_SETUP #line 316 "ProParser.l" return tValueName; YY_BREAK case 258: YY_RULE_SETUP #line 317 "ProParser.l" return tHarmonicToTime; YY_BREAK case 259: YY_RULE_SETUP #line 318 "ProParser.l" return tTimeStep; YY_BREAK case 260: YY_RULE_SETUP #line 319 "ProParser.l" return tTarget; YY_BREAK case 261: YY_RULE_SETUP #line 320 "ProParser.l" return tFile; YY_BREAK case 262: YY_RULE_SETUP #line 321 "ProParser.l" return tSort; YY_BREAK case 263: YY_RULE_SETUP #line 322 "ProParser.l" return tIso; YY_BREAK case 264: YY_RULE_SETUP #line 323 "ProParser.l" return tNoNewLine; YY_BREAK case 265: YY_RULE_SETUP #line 324 "ProParser.l" return tNoTitle; YY_BREAK case 266: YY_RULE_SETUP #line 325 "ProParser.l" return tTimeLegend; YY_BREAK case 267: YY_RULE_SETUP #line 326 "ProParser.l" return tFrequencyLegend; YY_BREAK case 268: YY_RULE_SETUP #line 327 "ProParser.l" return tEigenvalueLegend; YY_BREAK case 269: YY_RULE_SETUP #line 328 "ProParser.l" return tEvaluationPoints; YY_BREAK case 270: YY_RULE_SETUP #line 329 "ProParser.l" return tStoreInRegister; YY_BREAK case 271: YY_RULE_SETUP #line 330 "ProParser.l" return tStoreInRegister; YY_BREAK case 272: YY_RULE_SETUP #line 331 "ProParser.l" return tStoreInField; YY_BREAK case 273: YY_RULE_SETUP #line 332 "ProParser.l" return tLastTimeStepOnly; YY_BREAK case 274: YY_RULE_SETUP #line 333 "ProParser.l" return tAppendTimeStepToFileName; YY_BREAK case 275: YY_RULE_SETUP #line 334 "ProParser.l" return tOverrideTimeStepValue; YY_BREAK case 276: YY_RULE_SETUP #line 335 "ProParser.l" return tSendToServer; YY_BREAK case 277: YY_RULE_SETUP #line 336 "ProParser.l" return tColor; YY_BREAK case 278: YY_RULE_SETUP #line 337 "ProParser.l" return tNewCoordinates; YY_BREAK case 279: YY_RULE_SETUP #line 339 "ProParser.l" return tIf; YY_BREAK case 280: YY_RULE_SETUP #line 340 "ProParser.l" return tElse; YY_BREAK case 281: YY_RULE_SETUP #line 341 "ProParser.l" return tEndIf; YY_BREAK case 282: YY_RULE_SETUP #line 342 "ProParser.l" return tFor; YY_BREAK case 283: YY_RULE_SETUP #line 343 "ProParser.l" return tEndFor; YY_BREAK case 284: YY_RULE_SETUP #line 345 "ProParser.l" return tDecomposeInSimplex; YY_BREAK case 285: YY_RULE_SETUP #line 346 "ProParser.l" return tStr; YY_BREAK case 286: YY_RULE_SETUP #line 347 "ProParser.l" return tDate; YY_BREAK case 287: YY_RULE_SETUP #line 349 "ProParser.l" return tFlag; YY_BREAK case 288: YY_RULE_SETUP #line 351 "ProParser.l" return tQuantity; YY_BREAK case 289: YY_RULE_SETUP #line 352 "ProParser.l" return tGalerkin; YY_BREAK case 290: YY_RULE_SETUP #line 354 "ProParser.l" { getdp_yylval.i = atoi(getdp_yytext); return tINT; } YY_BREAK case 291: #line 357 "ProParser.l" case 292: #line 358 "ProParser.l" case 293: YY_RULE_SETUP #line 358 "ProParser.l" { getdp_yylval.d = atof(getdp_yytext); return tFLOAT; } YY_BREAK case 294: YY_RULE_SETUP #line 360 "ProParser.l" { getdp_yylval.c = strSave(getdp_yytext); return tSTRING; } YY_BREAK case 295: YY_RULE_SETUP #line 362 "ProParser.l" return getdp_yytext[0]; YY_BREAK case 296: YY_RULE_SETUP #line 364 "ProParser.l" ECHO; YY_BREAK #line 3296 "ProParser.yy.cpp" case YY_END_OF_BUFFER: { /* Amount of text matched not including the EOB char. */ int yy_amount_of_matched_text = (int) (yy_cp - (yytext_ptr)) - 1; /* Undo the effects of YY_DO_BEFORE_ACTION. */ *yy_cp = (yy_hold_char); YY_RESTORE_YY_MORE_OFFSET if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_NEW ) { /* We're scanning a new file or input source. It's * possible that this happened because the user * just pointed getdp_yyin at a new source and called * getdp_yylex(). If so, then we have to assure * consistency between YY_CURRENT_BUFFER and our * globals. Here is the right place to do so, because * this is the first action (other than possibly a * back-up) that will match for the new input source. */ (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; YY_CURRENT_BUFFER_LVALUE->yy_input_file = getdp_yyin; YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = YY_BUFFER_NORMAL; } /* Note that here we test for yy_c_buf_p "<=" to the position * of the first EOB in the buffer, since yy_c_buf_p will * already have been incremented past the NUL character * (since all states make transitions on EOB to the * end-of-buffer state). Contrast this with the test * in input(). */ if ( (yy_c_buf_p) <= &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) { /* This was really a NUL. */ yy_state_type yy_next_state; (yy_c_buf_p) = (yytext_ptr) + yy_amount_of_matched_text; yy_current_state = yy_get_previous_state( ); /* Okay, we're now positioned to make the NUL * transition. We couldn't have * yy_get_previous_state() go ahead and do it * for us because it doesn't know how to deal * with the possibility of jamming (and we don't * want to build jamming into it because then it * will run more slowly). */ yy_next_state = yy_try_NUL_trans( yy_current_state ); yy_bp = (yytext_ptr) + YY_MORE_ADJ; if ( yy_next_state ) { /* Consume the NUL. */ yy_cp = ++(yy_c_buf_p); yy_current_state = yy_next_state; goto yy_match; } else { yy_cp = (yy_c_buf_p); goto yy_find_action; } } else switch ( yy_get_next_buffer( ) ) { case EOB_ACT_END_OF_FILE: { (yy_did_buffer_switch_on_eof) = 0; if ( getdp_yywrap( ) ) { /* Note: because we've taken care in * yy_get_next_buffer() to have set up * getdp_yytext, we can now set up * yy_c_buf_p so that if some total * hoser (like flex itself) wants to * call the scanner after we return the * YY_NULL, it'll still work - another * YY_NULL will get returned. */ (yy_c_buf_p) = (yytext_ptr) + YY_MORE_ADJ; yy_act = YY_STATE_EOF(YY_START); goto do_action; } else { if ( ! (yy_did_buffer_switch_on_eof) ) YY_NEW_FILE; } break; } case EOB_ACT_CONTINUE_SCAN: (yy_c_buf_p) = (yytext_ptr) + yy_amount_of_matched_text; yy_current_state = yy_get_previous_state( ); yy_cp = (yy_c_buf_p); yy_bp = (yytext_ptr) + YY_MORE_ADJ; goto yy_match; case EOB_ACT_LAST_MATCH: (yy_c_buf_p) = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)]; yy_current_state = yy_get_previous_state( ); yy_cp = (yy_c_buf_p); yy_bp = (yytext_ptr) + YY_MORE_ADJ; goto yy_find_action; } break; } default: YY_FATAL_ERROR( "fatal flex scanner internal error--no action found" ); } /* end of action switch */ } /* end of scanning one token */ } /* end of getdp_yylex */ /* yy_get_next_buffer - try to read in a new buffer * * Returns a code representing an action: * EOB_ACT_LAST_MATCH - * EOB_ACT_CONTINUE_SCAN - continue scanning from current position * EOB_ACT_END_OF_FILE - end of file */ static int yy_get_next_buffer (void) { register char *dest = YY_CURRENT_BUFFER_LVALUE->yy_ch_buf; register char *source = (yytext_ptr); register int number_to_move, i; int ret_val; if ( (yy_c_buf_p) > &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] ) YY_FATAL_ERROR( "fatal flex scanner internal error--end of buffer missed" ); if ( YY_CURRENT_BUFFER_LVALUE->yy_fill_buffer == 0 ) { /* Don't try to fill the buffer, so this is an EOF. */ if ( (yy_c_buf_p) - (yytext_ptr) - YY_MORE_ADJ == 1 ) { /* We matched a single character, the EOB, so * treat this as a final EOF. */ return EOB_ACT_END_OF_FILE; } else { /* We matched some text prior to the EOB, first * process it. */ return EOB_ACT_LAST_MATCH; } } /* Try to read more data. */ /* First move last chars to start of buffer. */ number_to_move = (int) ((yy_c_buf_p) - (yytext_ptr)) - 1; for ( i = 0; i < number_to_move; ++i ) *(dest++) = *(source++); if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_EOF_PENDING ) /* don't do the read, it's not guaranteed to return an EOF, * just force an EOF */ YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars) = 0; else { yy_size_t num_to_read = YY_CURRENT_BUFFER_LVALUE->yy_buf_size - number_to_move - 1; while ( num_to_read <= 0 ) { /* Not enough room in the buffer - grow it. */ /* just a shorter name for the current buffer */ YY_BUFFER_STATE b = YY_CURRENT_BUFFER; int yy_c_buf_p_offset = (int) ((yy_c_buf_p) - b->yy_ch_buf); if ( b->yy_is_our_buffer ) { yy_size_t new_size = b->yy_buf_size * 2; if ( new_size <= 0 ) b->yy_buf_size += b->yy_buf_size / 8; else b->yy_buf_size *= 2; b->yy_ch_buf = (char *) /* Include room in for 2 EOB chars. */ getdp_yyrealloc((void *) b->yy_ch_buf,b->yy_buf_size + 2 ); } else /* Can't grow it, we don't own it. */ b->yy_ch_buf = 0; if ( ! b->yy_ch_buf ) YY_FATAL_ERROR( "fatal error - scanner input buffer overflow" ); (yy_c_buf_p) = &b->yy_ch_buf[yy_c_buf_p_offset]; num_to_read = YY_CURRENT_BUFFER_LVALUE->yy_buf_size - number_to_move - 1; } if ( num_to_read > YY_READ_BUF_SIZE ) num_to_read = YY_READ_BUF_SIZE; /* Read in more data. */ YY_INPUT( (&YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]), (yy_n_chars), num_to_read ); YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); } if ( (yy_n_chars) == 0 ) { if ( number_to_move == YY_MORE_ADJ ) { ret_val = EOB_ACT_END_OF_FILE; getdp_yyrestart(getdp_yyin ); } else { ret_val = EOB_ACT_LAST_MATCH; YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = YY_BUFFER_EOF_PENDING; } } else ret_val = EOB_ACT_CONTINUE_SCAN; if ((yy_size_t) ((yy_n_chars) + number_to_move) > YY_CURRENT_BUFFER_LVALUE->yy_buf_size) { /* Extend the array by 50%, plus the number we really need. */ yy_size_t new_size = (yy_n_chars) + number_to_move + ((yy_n_chars) >> 1); YY_CURRENT_BUFFER_LVALUE->yy_ch_buf = (char *) getdp_yyrealloc((void *) YY_CURRENT_BUFFER_LVALUE->yy_ch_buf,new_size ); if ( ! YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) YY_FATAL_ERROR( "out of dynamic memory in yy_get_next_buffer()" ); } (yy_n_chars) += number_to_move; YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] = YY_END_OF_BUFFER_CHAR; YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] = YY_END_OF_BUFFER_CHAR; (yytext_ptr) = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[0]; return ret_val; } /* yy_get_previous_state - get the state just before the EOB char was reached */ static yy_state_type yy_get_previous_state (void) { register yy_state_type yy_current_state; register char *yy_cp; yy_current_state = (yy_start); for ( yy_cp = (yytext_ptr) + YY_MORE_ADJ; yy_cp < (yy_c_buf_p); ++yy_cp ) { register YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1); if ( yy_accept[yy_current_state] ) { (yy_last_accepting_state) = yy_current_state; (yy_last_accepting_cpos) = yy_cp; } while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) { yy_current_state = (int) yy_def[yy_current_state]; if ( yy_current_state >= 1820 ) yy_c = yy_meta[(unsigned int) yy_c]; } yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; } return yy_current_state; } /* yy_try_NUL_trans - try to make a transition on the NUL character * * synopsis * next_state = yy_try_NUL_trans( current_state ); */ static yy_state_type yy_try_NUL_trans (yy_state_type yy_current_state ) { register int yy_is_jam; register char *yy_cp = (yy_c_buf_p); register YY_CHAR yy_c = 1; if ( yy_accept[yy_current_state] ) { (yy_last_accepting_state) = yy_current_state; (yy_last_accepting_cpos) = yy_cp; } while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) { yy_current_state = (int) yy_def[yy_current_state]; if ( yy_current_state >= 1820 ) yy_c = yy_meta[(unsigned int) yy_c]; } yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; yy_is_jam = (yy_current_state == 1819); return yy_is_jam ? 0 : yy_current_state; } static void yyunput (int c, register char * yy_bp ) { register char *yy_cp; yy_cp = (yy_c_buf_p); /* undo effects of setting up getdp_yytext */ *yy_cp = (yy_hold_char); if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) { /* need to shift things up to make room */ /* +2 for EOB chars. */ register yy_size_t number_to_move = (yy_n_chars) + 2; register char *dest = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[ YY_CURRENT_BUFFER_LVALUE->yy_buf_size + 2]; register char *source = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]; while ( source > YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) *--dest = *--source; yy_cp += (int) (dest - source); yy_bp += (int) (dest - source); YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_buf_size; if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) YY_FATAL_ERROR( "flex scanner push-back overflow" ); } *--yy_cp = (char) c; (yytext_ptr) = yy_bp; (yy_hold_char) = *yy_cp; (yy_c_buf_p) = yy_cp; } #ifndef YY_NO_INPUT #ifdef __cplusplus static int yyinput (void) #else static int input (void) #endif { int c; *(yy_c_buf_p) = (yy_hold_char); if ( *(yy_c_buf_p) == YY_END_OF_BUFFER_CHAR ) { /* yy_c_buf_p now points to the character we want to return. * If this occurs *before* the EOB characters, then it's a * valid NUL; if not, then we've hit the end of the buffer. */ if ( (yy_c_buf_p) < &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) /* This was really a NUL. */ *(yy_c_buf_p) = '\0'; else { /* need more input */ yy_size_t offset = (yy_c_buf_p) - (yytext_ptr); ++(yy_c_buf_p); switch ( yy_get_next_buffer( ) ) { case EOB_ACT_LAST_MATCH: /* This happens because yy_g_n_b() * sees that we've accumulated a * token and flags that we need to * try matching the token before * proceeding. But for input(), * there's no matching to consider. * So convert the EOB_ACT_LAST_MATCH * to EOB_ACT_END_OF_FILE. */ /* Reset buffer status. */ getdp_yyrestart(getdp_yyin ); /*FALLTHROUGH*/ case EOB_ACT_END_OF_FILE: { if ( getdp_yywrap( ) ) return 0; if ( ! (yy_did_buffer_switch_on_eof) ) YY_NEW_FILE; #ifdef __cplusplus return yyinput(); #else return input(); #endif } case EOB_ACT_CONTINUE_SCAN: (yy_c_buf_p) = (yytext_ptr) + offset; break; } } } c = *(unsigned char *) (yy_c_buf_p); /* cast for 8-bit char's */ *(yy_c_buf_p) = '\0'; /* preserve getdp_yytext */ (yy_hold_char) = *++(yy_c_buf_p); return c; } #endif /* ifndef YY_NO_INPUT */ /** Immediately switch to a different input stream. * @param input_file A readable stream. * * @note This function does not reset the start condition to @c INITIAL . */ void getdp_yyrestart (FILE * input_file ) { if ( ! YY_CURRENT_BUFFER ){ getdp_yyensure_buffer_stack (); YY_CURRENT_BUFFER_LVALUE = getdp_yy_create_buffer(getdp_yyin,YY_BUF_SIZE ); } getdp_yy_init_buffer(YY_CURRENT_BUFFER,input_file ); getdp_yy_load_buffer_state( ); } /** Switch to a different input buffer. * @param new_buffer The new input buffer. * */ void getdp_yy_switch_to_buffer (YY_BUFFER_STATE new_buffer ) { /* TODO. We should be able to replace this entire function body * with * getdp_yypop_buffer_state(); * getdp_yypush_buffer_state(new_buffer); */ getdp_yyensure_buffer_stack (); if ( YY_CURRENT_BUFFER == new_buffer ) return; if ( YY_CURRENT_BUFFER ) { /* Flush out information for old buffer. */ *(yy_c_buf_p) = (yy_hold_char); YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); } YY_CURRENT_BUFFER_LVALUE = new_buffer; getdp_yy_load_buffer_state( ); /* We don't actually know whether we did this switch during * EOF (getdp_yywrap()) processing, but the only time this flag * is looked at is after getdp_yywrap() is called, so it's safe * to go ahead and always set it. */ (yy_did_buffer_switch_on_eof) = 1; } static void getdp_yy_load_buffer_state (void) { (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; (yytext_ptr) = (yy_c_buf_p) = YY_CURRENT_BUFFER_LVALUE->yy_buf_pos; getdp_yyin = YY_CURRENT_BUFFER_LVALUE->yy_input_file; (yy_hold_char) = *(yy_c_buf_p); } /** Allocate and initialize an input buffer state. * @param file A readable stream. * @param size The character buffer size in bytes. When in doubt, use @c YY_BUF_SIZE. * * @return the allocated buffer state. */ YY_BUFFER_STATE getdp_yy_create_buffer (FILE * file, int size ) { YY_BUFFER_STATE b; b = (YY_BUFFER_STATE) getdp_yyalloc(sizeof( struct yy_buffer_state ) ); if ( ! b ) YY_FATAL_ERROR( "out of dynamic memory in getdp_yy_create_buffer()" ); b->yy_buf_size = size; /* yy_ch_buf has to be 2 characters longer than the size given because * we need to put in 2 end-of-buffer characters. */ b->yy_ch_buf = (char *) getdp_yyalloc(b->yy_buf_size + 2 ); if ( ! b->yy_ch_buf ) YY_FATAL_ERROR( "out of dynamic memory in getdp_yy_create_buffer()" ); b->yy_is_our_buffer = 1; getdp_yy_init_buffer(b,file ); return b; } /** Destroy the buffer. * @param b a buffer created with getdp_yy_create_buffer() * */ void getdp_yy_delete_buffer (YY_BUFFER_STATE b ) { if ( ! b ) return; if ( b == YY_CURRENT_BUFFER ) /* Not sure if we should pop here. */ YY_CURRENT_BUFFER_LVALUE = (YY_BUFFER_STATE) 0; if ( b->yy_is_our_buffer ) getdp_yyfree((void *) b->yy_ch_buf ); getdp_yyfree((void *) b ); } #ifndef __cplusplus extern int isatty (int ); #endif /* __cplusplus */ /* Initializes or reinitializes a buffer. * This function is sometimes called more than once on the same buffer, * such as during a getdp_yyrestart() or at EOF. */ static void getdp_yy_init_buffer (YY_BUFFER_STATE b, FILE * file ) { int oerrno = errno; getdp_yy_flush_buffer(b ); b->yy_input_file = file; b->yy_fill_buffer = 1; /* If b is the current buffer, then getdp_yy_init_buffer was _probably_ * called from getdp_yyrestart() or through yy_get_next_buffer. * In that case, we don't want to reset the lineno or column. */ if (b != YY_CURRENT_BUFFER){ b->yy_bs_lineno = 1; b->yy_bs_column = 0; } b->yy_is_interactive = file ? (isatty( fileno(file) ) > 0) : 0; errno = oerrno; } /** Discard all buffered characters. On the next scan, YY_INPUT will be called. * @param b the buffer state to be flushed, usually @c YY_CURRENT_BUFFER. * */ void getdp_yy_flush_buffer (YY_BUFFER_STATE b ) { if ( ! b ) return; b->yy_n_chars = 0; /* We always need two end-of-buffer characters. The first causes * a transition to the end-of-buffer state. The second causes * a jam in that state. */ b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR; b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR; b->yy_buf_pos = &b->yy_ch_buf[0]; b->yy_at_bol = 1; b->yy_buffer_status = YY_BUFFER_NEW; if ( b == YY_CURRENT_BUFFER ) getdp_yy_load_buffer_state( ); } /** Pushes the new state onto the stack. The new state becomes * the current state. This function will allocate the stack * if necessary. * @param new_buffer The new state. * */ void getdp_yypush_buffer_state (YY_BUFFER_STATE new_buffer ) { if (new_buffer == NULL) return; getdp_yyensure_buffer_stack(); /* This block is copied from getdp_yy_switch_to_buffer. */ if ( YY_CURRENT_BUFFER ) { /* Flush out information for old buffer. */ *(yy_c_buf_p) = (yy_hold_char); YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); } /* Only push if top exists. Otherwise, replace top. */ if (YY_CURRENT_BUFFER) (yy_buffer_stack_top)++; YY_CURRENT_BUFFER_LVALUE = new_buffer; /* copied from getdp_yy_switch_to_buffer. */ getdp_yy_load_buffer_state( ); (yy_did_buffer_switch_on_eof) = 1; } /** Removes and deletes the top of the stack, if present. * The next element becomes the new top. * */ void getdp_yypop_buffer_state (void) { if (!YY_CURRENT_BUFFER) return; getdp_yy_delete_buffer(YY_CURRENT_BUFFER ); YY_CURRENT_BUFFER_LVALUE = NULL; if ((yy_buffer_stack_top) > 0) --(yy_buffer_stack_top); if (YY_CURRENT_BUFFER) { getdp_yy_load_buffer_state( ); (yy_did_buffer_switch_on_eof) = 1; } } /* Allocates the stack if it does not exist. * Guarantees space for at least one push. */ static void getdp_yyensure_buffer_stack (void) { yy_size_t num_to_alloc; if (!(yy_buffer_stack)) { /* First allocation is just for 2 elements, since we don't know if this * scanner will even need a stack. We use 2 instead of 1 to avoid an * immediate realloc on the next call. */ num_to_alloc = 1; (yy_buffer_stack) = (struct yy_buffer_state**)getdp_yyalloc (num_to_alloc * sizeof(struct yy_buffer_state*) ); if ( ! (yy_buffer_stack) ) YY_FATAL_ERROR( "out of dynamic memory in getdp_yyensure_buffer_stack()" ); memset((yy_buffer_stack), 0, num_to_alloc * sizeof(struct yy_buffer_state*)); (yy_buffer_stack_max) = num_to_alloc; (yy_buffer_stack_top) = 0; return; } if ((yy_buffer_stack_top) >= ((yy_buffer_stack_max)) - 1){ /* Increase the buffer to prepare for a possible push. */ int grow_size = 8 /* arbitrary grow size */; num_to_alloc = (yy_buffer_stack_max) + grow_size; (yy_buffer_stack) = (struct yy_buffer_state**)getdp_yyrealloc ((yy_buffer_stack), num_to_alloc * sizeof(struct yy_buffer_state*) ); if ( ! (yy_buffer_stack) ) YY_FATAL_ERROR( "out of dynamic memory in getdp_yyensure_buffer_stack()" ); /* zero only the new slots.*/ memset((yy_buffer_stack) + (yy_buffer_stack_max), 0, grow_size * sizeof(struct yy_buffer_state*)); (yy_buffer_stack_max) = num_to_alloc; } } /** Setup the input buffer state to scan directly from a user-specified character buffer. * @param base the character buffer * @param size the size in bytes of the character buffer * * @return the newly allocated buffer state object. */ YY_BUFFER_STATE getdp_yy_scan_buffer (char * base, yy_size_t size ) { YY_BUFFER_STATE b; if ( size < 2 || base[size-2] != YY_END_OF_BUFFER_CHAR || base[size-1] != YY_END_OF_BUFFER_CHAR ) /* They forgot to leave room for the EOB's. */ return 0; b = (YY_BUFFER_STATE) getdp_yyalloc(sizeof( struct yy_buffer_state ) ); if ( ! b ) YY_FATAL_ERROR( "out of dynamic memory in getdp_yy_scan_buffer()" ); b->yy_buf_size = size - 2; /* "- 2" to take care of EOB's */ b->yy_buf_pos = b->yy_ch_buf = base; b->yy_is_our_buffer = 0; b->yy_input_file = 0; b->yy_n_chars = b->yy_buf_size; b->yy_is_interactive = 0; b->yy_at_bol = 1; b->yy_fill_buffer = 0; b->yy_buffer_status = YY_BUFFER_NEW; getdp_yy_switch_to_buffer(b ); return b; } /** Setup the input buffer state to scan a string. The next call to getdp_yylex() will * scan from a @e copy of @a str. * @param yystr a NUL-terminated string to scan * * @return the newly allocated buffer state object. * @note If you want to scan bytes that may contain NUL values, then use * getdp_yy_scan_bytes() instead. */ YY_BUFFER_STATE getdp_yy_scan_string (yyconst char * yystr ) { return getdp_yy_scan_bytes(yystr,strlen(yystr) ); } /** Setup the input buffer state to scan the given bytes. The next call to getdp_yylex() will * scan from a @e copy of @a bytes. * @param bytes the byte buffer to scan * @param len the number of bytes in the buffer pointed to by @a bytes. * * @return the newly allocated buffer state object. */ YY_BUFFER_STATE getdp_yy_scan_bytes (yyconst char * yybytes, yy_size_t _yybytes_len ) { YY_BUFFER_STATE b; char *buf; yy_size_t n, i; /* Get memory for full buffer, including space for trailing EOB's. */ n = _yybytes_len + 2; buf = (char *) getdp_yyalloc(n ); if ( ! buf ) YY_FATAL_ERROR( "out of dynamic memory in getdp_yy_scan_bytes()" ); for ( i = 0; i < _yybytes_len; ++i ) buf[i] = yybytes[i]; buf[_yybytes_len] = buf[_yybytes_len+1] = YY_END_OF_BUFFER_CHAR; b = getdp_yy_scan_buffer(buf,n ); if ( ! b ) YY_FATAL_ERROR( "bad buffer in getdp_yy_scan_bytes()" ); /* It's okay to grow etc. this buffer, and we should throw it * away when we're done. */ b->yy_is_our_buffer = 1; return b; } #ifndef YY_EXIT_FAILURE #define YY_EXIT_FAILURE 2 #endif static void yy_fatal_error (yyconst char* msg ) { (void) fprintf( stderr, "%s\n", msg ); exit( YY_EXIT_FAILURE ); } /* Redefine yyless() so it works in section 3 code. */ #undef yyless #define yyless(n) \ do \ { \ /* Undo effects of setting up getdp_yytext. */ \ int yyless_macro_arg = (n); \ YY_LESS_LINENO(yyless_macro_arg);\ getdp_yytext[getdp_yyleng] = (yy_hold_char); \ (yy_c_buf_p) = getdp_yytext + yyless_macro_arg; \ (yy_hold_char) = *(yy_c_buf_p); \ *(yy_c_buf_p) = '\0'; \ getdp_yyleng = yyless_macro_arg; \ } \ while ( 0 ) /* Accessor methods (get/set functions) to struct members. */ /** Get the current line number. * */ int getdp_yyget_lineno (void) { return getdp_yylineno; } /** Get the input stream. * */ FILE *getdp_yyget_in (void) { return getdp_yyin; } /** Get the output stream. * */ FILE *getdp_yyget_out (void) { return getdp_yyout; } /** Get the length of the current token. * */ yy_size_t getdp_yyget_leng (void) { return getdp_yyleng; } /** Get the current token. * */ char *getdp_yyget_text (void) { return getdp_yytext; } /** Set the current line number. * @param line_number * */ void getdp_yyset_lineno (int line_number ) { getdp_yylineno = line_number; } /** Set the input stream. This does not discard the current * input buffer. * @param in_str A readable stream. * * @see getdp_yy_switch_to_buffer */ void getdp_yyset_in (FILE * in_str ) { getdp_yyin = in_str ; } void getdp_yyset_out (FILE * out_str ) { getdp_yyout = out_str ; } int getdp_yyget_debug (void) { return getdp_yy_flex_debug; } void getdp_yyset_debug (int bdebug ) { getdp_yy_flex_debug = bdebug ; } static int yy_init_globals (void) { /* Initialization is the same as for the non-reentrant scanner. * This function is called from getdp_yylex_destroy(), so don't allocate here. */ (yy_buffer_stack) = 0; (yy_buffer_stack_top) = 0; (yy_buffer_stack_max) = 0; (yy_c_buf_p) = (char *) 0; (yy_init) = 0; (yy_start) = 0; /* Defined in main.c */ #ifdef YY_STDINIT getdp_yyin = stdin; getdp_yyout = stdout; #else getdp_yyin = (FILE *) 0; getdp_yyout = (FILE *) 0; #endif /* For future reference: Set errno on error, since we are called by * getdp_yylex_init() */ return 0; } /* getdp_yylex_destroy is for both reentrant and non-reentrant scanners. */ int getdp_yylex_destroy (void) { /* Pop the buffer stack, destroying each element. */ while(YY_CURRENT_BUFFER){ getdp_yy_delete_buffer(YY_CURRENT_BUFFER ); YY_CURRENT_BUFFER_LVALUE = NULL; getdp_yypop_buffer_state(); } /* Destroy the stack itself. */ getdp_yyfree((yy_buffer_stack) ); (yy_buffer_stack) = NULL; /* Reset the globals. This is important in a non-reentrant scanner so the next time * getdp_yylex() is called, initialization will occur. */ yy_init_globals( ); return 0; } /* * Internal utility routines. */ #ifndef yytext_ptr static void yy_flex_strncpy (char* s1, yyconst char * s2, int n ) { register int i; for ( i = 0; i < n; ++i ) s1[i] = s2[i]; } #endif #ifdef YY_NEED_STRLEN static int yy_flex_strlen (yyconst char * s ) { register int n; for ( n = 0; s[n]; ++n ) ; return n; } #endif void *getdp_yyalloc (yy_size_t size ) { return (void *) malloc( size ); } void *getdp_yyrealloc (void * ptr, yy_size_t size ) { /* The cast to (char *) in the following accommodates both * implementations that use char* generic pointers, and those * that use void* generic pointers. It works with the latter * because both ANSI C and C++ allow castless assignment from * any pointer type to void*, and deal with argument conversions * as though doing an assignment. */ return (void *) realloc( (char *) ptr, size ); } void getdp_yyfree (void * ptr ) { free( (char *) ptr ); /* see getdp_yyrealloc() for (char *) cast */ } #define YYTABLES_NAME "yytables" #line 364 "ProParser.l" #undef getdp_yywrap int getdp_yywrap() { return 1; } #ifdef __cplusplus #define input yyinput #endif #ifndef yytext_ptr #define yytext_ptr getdp_yytext #endif char *strSave(const char *string) { return ((char *)strcpy((char *)Malloc(strlen(string)+1), string)); } void cStyleComments() { int c; while(1) { while((c = input()) != '*'){ if(c == '\n') getdp_yylinenum++; if(feof(getdp_yyin)) { Message::Error("End of file in commented region"); exit(1); } } if((c = input()) == '/') return; unput(c); } } void cxxStyleComments() { int c; while(1){ c = input(); if(c == '\n' || feof(getdp_yyin)) break; } getdp_yylinenum++; } void parseString(char endchar) { char tmp[2048]; int c = input(); int i = 0; while(c != endchar){ if(feof(getdp_yyin)) { Message::Error("End of file in string"); getdp_yycolnum = 0; break; } else if(c == '\n') { getdp_yycolnum = 0; } else if(i >= (int)sizeof(tmp)-1) { Message::Error("String too long"); break; } else { tmp[i++] = c; } c = input(); } tmp[i] = '\0'; getdp_yylval.c = strSave(tmp); } void skipUntil(const char *skip, const char *until) { int l, l_skip, l_until; char chars[256]; int c_next, c_next_skip, c_next_until; int nb_skip = 0; if(skip) l_skip = strlen(skip); else l_skip = 0; l_until = strlen(until); while(1){ while (1){ chars[0] = input(); if(chars[0] == '\n') getdp_yylinenum++; if(feof(getdp_yyin)){ Message::Error("Unexpected end of file"); return; } if(chars[0] == '/'){ c_next = input(); if (c_next == '*') cStyleComments(); else if(c_next == '/') cxxStyleComments(); else unput(c_next); } if(chars[0] == until[0]) break; if(skip && chars[0] == skip[0]) break; } l = (l_skip > l_until) ? l_skip : l_until; if(l >= (int)sizeof(chars)){ Message::Error("Search pattern too long in skip_until"); return; } for(int i = 1; i < l; i++){ chars[i] = input(); if(chars[i] == '\n') getdp_yylinenum++; if(feof(getdp_yyin)){ l = i; break; } } c_next = input(); unput(c_next); c_next_skip = (l_skip='a' && c_next_until<='z') && !(c_next_until>='A' && c_next_until<='Z') && c_next_until!='_' ) ){ if(!nb_skip){ return; } else{ nb_skip--; } } else if(skip && !strncmp(chars,skip,l_skip) && (!(c_next_skip>='a' && c_next_skip<='z') && !(c_next_skip>='A' && c_next_skip<='Z') && c_next_skip!='_' ) ){ nb_skip++; } else{ for(int i = 1; i < l - 1; i++){ unput(chars[l-i]); if(chars[l-i] == '\n') getdp_yylinenum--; } } } } void hack_fsetpos_printf() { char chars[5]; int c = input(), c2 = input(), c3 = input(); unput(c3); unput(c2); unput(c); chars[0] = c; chars[1] = c2; chars[2] = c3; chars[3] = 0; printf("++++++ c: %d %d %d /%s/\n", (int)c, (int)c2, (int)c3, chars); } void hack_fsetpos() { input(); } getdp-2.4.2-source/Interface/ProDefine.cpp000644 001750 001750 00000012463 12116424200 022055 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "ProData.h" #include "ProDefine.h" #include "Message.h" /* --------------------------------------------------------------------------- */ /* G e t S t r i n g , D e f i n e , F u n c t i o n , P o i n t e r */ /* --------------------------------------------------------------------------- */ int Get_DefineForString(struct StringXDefine SXD[], const char *string, int *FlagError) { int i = 0, define ; while ((SXD[i].string != NULL) && (strcmp(SXD[i].string, string))) i++ ; define = SXD[i].define ; *FlagError = (SXD[i].string == NULL)? 1 : 0 ; return(define) ; } int Get_Define1NbrForString(struct StringXDefine1Nbr SXD[], const char *string, int *FlagError, int *Nbr1) { int i = 0, define ; while ((SXD[i].string != NULL) && (strcmp(SXD[i].string, string))) i++ ; define = SXD[i].define ; *Nbr1 = SXD[i].Nbr1 ; *FlagError = (SXD[i].string == NULL)? 1 : 0 ; return(define) ; } void Get_PointerForString(struct StringXPointer SXF[], const char *string, int *FlagError, void **Pointer) { int i = 0 ; while ((SXF[i].string != NULL) && (strcmp(SXF[i].string, string))) i++ ; *Pointer = SXF[i].Pointer ; *FlagError = (SXF[i].string == NULL)? 1 : 0 ; } void Get_3Function3NbrForString(struct StringX3Function3Nbr SXF[], const char *string, int *FlagError, void (**Function1)(), void (**Function2)(), void (**Function3)(), double *Nbr1, int *Nbr2, int *Nbr3) { int i = 0 ; while ((SXF[i].string != NULL) && (strcmp(SXF[i].string, string))) i++ ; *Function1 = SXF[i].Function1 ; *Function2 = SXF[i].Function2 ; *Function3 = SXF[i].Function3 ; *Nbr1 = SXF[i].Nbr1 ; *Nbr2 = SXF[i].Nbr2 ; *Nbr3 = SXF[i].Nbr3 ; *FlagError = (SXF[i].string == NULL)? 1 : 0 ; } void Get_Function2NbrForString(struct StringXFunction2Nbr SXF[], const char *string, int *FlagError, void (**Function)(), int *Nbr1, int *Nbr2) { int i = 0 ; while ((SXF[i].string != NULL) && (strcmp(SXF[i].string, string))) i++ ; *Function = SXF[i].Function ; *Nbr1 = SXF[i].Nbr1 ; *Nbr2 = SXF[i].Nbr2 ; *FlagError = (SXF[i].string == NULL)? 1 : 0 ; } void Get_FunctionForFunction(struct FunctionXFunction FXF[], void (*Function1)(), int *FlagError, void (**Function2)() ) { int i = 0 ; while ((FXF[i].Function1 != NULL) && (FXF[i].Function1 != Function1)) i++ ; *Function2 = FXF[i].Function2 ; *FlagError = (FXF[i].Function1 == NULL)? 1 : 0 ; } void Get_FunctionForDefine(struct DefineXFunction DXF[], int define, int *FlagError, void (**Function)()) { int i = 0 ; while ((DXF[i].define != 0) && (DXF[i].define != define)) i++ ; *Function = DXF[i].Function ; *FlagError = (DXF[i].define == 0)? 1 : 0 ; } const char *Get_StringForDefine(struct StringXDefine SXD[], int define) { int i = 0 ; const char *string ; while ((SXD[i].string != NULL) && (SXD[i].define != define)) i++ ; if (SXD[i].string != NULL) string = SXD[i].string ; else string = "?" ; return(string) ; } const char *Get_StringForDefine1Nbr(struct StringXDefine1Nbr SXD[], int define) { int i = 0 ; const char *string ; while ((SXD[i].string != NULL) && (SXD[i].define != define)) i++ ; if (SXD[i].string != NULL) string = SXD[i].string ; else string = "?" ; return(string) ; } const char *Get_StringForPointer(struct StringXPointer SXF[], void *Pointer) { int i = 0 ; const char *string ; while ((SXF[i].string != NULL) && (SXF[i].Pointer != Pointer)) i++ ; if (SXF[i].string != NULL) string = SXF[i].string ; else string = "?" ; return(string) ; } const char *Get_StringFor3Function3Nbr(struct StringX3Function3Nbr SXF[], void (*Function1)()) { int i = 0 ; const char *string ; while ((SXF[i].string != NULL) && (SXF[i].Function1 != Function1)) i++ ; if (SXF[i].string != NULL) string = SXF[i].string ; else string = "?" ; return(string) ; } const char *Get_StringForFunction2Nbr(struct StringXFunction2Nbr SXF[], void (*Function)()) { int i = 0 ; const char *string ; while ((SXF[i].string != NULL) && (SXF[i].Function != Function)) i++ ; if (SXF[i].string != NULL) string = SXF[i].string ; else string = "?" ; return(string) ; } /* ------------------------------------------------------------------------ Get_Valid_XXX ------------------------------------------------------------------------ */ static char Valid[5000]; #define GV(Get_Valid_X) \ int i = 0; \ Message::Direct("Valid Choices are:"); \ while (V[i].string != NULL){ \ if(!(i%3)){ \ if(i) Message::Direct(" %s", Valid); \ strcpy(Valid, V[i].string); \ } \ else strcat(Valid, V[i].string); \ strcat(Valid, " "); \ i++ ; \ } \ Message::Direct(" %s", Valid); \ return(Valid) char* Get_Valid_SXD (struct StringXDefine V[]) { GV("Get_Valid_SXD"); } char* Get_Valid_SXD1N (struct StringXDefine1Nbr V[]) { GV("Get_Valid_SXD1N"); } char* Get_Valid_SXP (struct StringXPointer V[]) { GV("Get_Valid_SXP"); } char* Get_Valid_SX3F3N(struct StringX3Function3Nbr V[]) { GV("Get_Valid_SX3F3N"); } char* Get_Valid_SXF2N (struct StringXFunction2Nbr V[]) { GV("Get_Valid_SXF2N"); } #undef GV getdp-2.4.2-source/Interface/ProParser.tab.cpp000644 001750 001750 00002221732 12221300353 022666 0ustar00geuzainegeuzaine000000 000000 /* A Bison parser, made by GNU Bison 2.3. */ /* Skeleton implementation for Bison's Yacc-like parsers in C Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ /* As a special exception, you may create a larger work that contains part or all of the Bison parser skeleton and distribute that work under terms of your choice, so long as that work isn't itself a parser generator using the skeleton or a modified version thereof as a parser skeleton. Alternatively, if you modify or redistribute the parser skeleton itself, you may (at your option) remove this special exception, which will cause the skeleton and the resulting Bison output files to be licensed under the GNU General Public License without this special exception. This special exception was added by the Free Software Foundation in version 2.2 of Bison. */ /* C LALR(1) parser skeleton written by Richard Stallman, by simplifying the original so-called "semantic" parser. */ /* All symbols defined below should begin with yy or YY, to avoid infringing on user name space. This should be done even for local variables, as they might otherwise be expanded by user macros. There are some unavoidable exceptions within include files to define necessary library symbols; they are noted "INFRINGES ON USER NAME SPACE" below. */ /* Identify Bison output. */ #define YYBISON 1 /* Bison version. */ #define YYBISON_VERSION "2.3" /* Skeleton name. */ #define YYSKELETON_NAME "yacc.c" /* Pure parsers. */ #define YYPURE 0 /* Using locations. */ #define YYLSP_NEEDED 0 /* Substitute the variable and function names. */ #define yyparse getdp_yyparse #define yylex getdp_yylex #define yyerror getdp_yyerror #define yylval getdp_yylval #define yychar getdp_yychar #define yydebug getdp_yydebug #define yynerrs getdp_yynerrs /* Tokens. */ #ifndef YYTOKENTYPE # define YYTOKENTYPE /* Put the tokens into the symbol table, so that GDB and other debuggers know about them. */ enum yytokentype { tINT = 258, tFLOAT = 259, tSTRING = 260, tBIGSTR = 261, tEND = 262, tDOTS = 263, tStrCat = 264, tSprintf = 265, tPrintf = 266, tRead = 267, tPrintConstants = 268, tStrCmp = 269, tNbrRegions = 270, tFor = 271, tEndFor = 272, tIf = 273, tElse = 274, tEndIf = 275, tFlag = 276, tInclude = 277, tConstant = 278, tList = 279, tListAlt = 280, tLinSpace = 281, tLogSpace = 282, tListFromFile = 283, tChangeCurrentPosition = 284, tDefineConstant = 285, tUndefineConstant = 286, tPi = 287, tMPI_Rank = 288, tMPI_Size = 289, t0D = 290, t1D = 291, t2D = 292, t3D = 293, tExp = 294, tLog = 295, tLog10 = 296, tSqrt = 297, tSin = 298, tAsin = 299, tCos = 300, tAcos = 301, tTan = 302, tAtan = 303, tAtan2 = 304, tSinh = 305, tCosh = 306, tTanh = 307, tFabs = 308, tFloor = 309, tCeil = 310, tRound = 311, tSign = 312, tFmod = 313, tModulo = 314, tHypot = 315, tRand = 316, tSolidAngle = 317, tTrace = 318, tOrder = 319, tCrossProduct = 320, tDofValue = 321, tMHTransform = 322, tMHJacNL = 323, tGroup = 324, tDefineGroup = 325, tAll = 326, tInSupport = 327, tMovingBand2D = 328, tDefineFunction = 329, tConstraint = 330, tRegion = 331, tSubRegion = 332, tRegionRef = 333, tSubRegionRef = 334, tFilter = 335, tCoefficient = 336, tValue = 337, tTimeFunction = 338, tBranch = 339, tNameOfResolution = 340, tJacobian = 341, tCase = 342, tMetricTensor = 343, tIntegration = 344, tMatrix = 345, tType = 346, tSubType = 347, tCriterion = 348, tGeoElement = 349, tNumberOfPoints = 350, tMaxNumberOfPoints = 351, tNumberOfDivisions = 352, tMaxNumberOfDivisions = 353, tStoppingCriterion = 354, tFunctionSpace = 355, tName = 356, tBasisFunction = 357, tNameOfCoef = 358, tFunction = 359, tdFunction = 360, tSubFunction = 361, tSubdFunction = 362, tSupport = 363, tEntity = 364, tSubSpace = 365, tNameOfBasisFunction = 366, tGlobalQuantity = 367, tEntityType = 368, tEntitySubType = 369, tNameOfConstraint = 370, tFormulation = 371, tQuantity = 372, tNameOfSpace = 373, tIndexOfSystem = 374, tSymmetry = 375, tGalerkin = 376, tdeRham = 377, tGlobalTerm = 378, tGlobalEquation = 379, tDt = 380, tDtDof = 381, tDtDt = 382, tDtDtDof = 383, tJacNL = 384, tDtDofJacNL = 385, tNeverDt = 386, tDtNL = 387, tAtAnteriorTimeStep = 388, tIn = 389, tFull_Matrix = 390, tResolution = 391, tDefineSystem = 392, tNameOfFormulation = 393, tNameOfMesh = 394, tFrequency = 395, tSolver = 396, tOriginSystem = 397, tDestinationSystem = 398, tOperation = 399, tOperationEnd = 400, tSetTime = 401, tDTime = 402, tSetFrequency = 403, tFourierTransform = 404, tFourierTransformJ = 405, tLanczos = 406, tEigenSolve = 407, tEigenSolveJac = 408, tPerturbation = 409, tUpdate = 410, tUpdateConstraint = 411, tBreak = 412, tEvaluate = 413, tSelectCorrection = 414, tAddCorrection = 415, tMultiplySolution = 416, tAddOppositeFullSolution = 417, tSolveAgainWithOther = 418, tTimeLoopTheta = 419, tTimeLoopNewmark = 420, tTimeLoopRungeKutta = 421, tTimeLoopAdaptive = 422, tTime0 = 423, tTimeMax = 424, tTheta = 425, tBeta = 426, tGamma = 427, tIterativeLoop = 428, tIterativeLoopN = 429, tIterativeLinearSolver = 430, tNbrMaxIteration = 431, tRelaxationFactor = 432, tIterativeTimeReduction = 433, tSetCommSelf = 434, tSetCommWorld = 435, tBarrier = 436, tDivisionCoefficient = 437, tChangeOfState = 438, tChangeOfCoordinates = 439, tChangeOfCoordinates2 = 440, tSystemCommand = 441, tGmshRead = 442, tGmshClearAll = 443, tDeleteFile = 444, tCreateDir = 445, tGenerateOnly = 446, tGenerateOnlyJac = 447, tSolveJac_AdaptRelax = 448, tTensorProductSolve = 449, tSaveSolutionExtendedMH = 450, tSaveSolutionMHtoTime = 451, tSaveSolutionWithEntityNum = 452, tInitMovingBand2D = 453, tMeshMovingBand2D = 454, tGenerate_MH_Moving = 455, tGenerate_MH_Moving_Separate = 456, tAdd_MH_Moving = 457, tGenerateGroup = 458, tGenerateJacGroup = 459, tGenerateRHSGroup = 460, tSaveMesh = 461, tDeformeMesh = 462, tDummyFrequency = 463, tPostProcessing = 464, tNameOfSystem = 465, tPostOperation = 466, tNameOfPostProcessing = 467, tUsingPost = 468, tAppend = 469, tResampleTime = 470, tPlot = 471, tPrint = 472, tPrintGroup = 473, tEcho = 474, tWrite = 475, tAdapt = 476, tOnGlobal = 477, tOnRegion = 478, tOnElementsOf = 479, tOnGrid = 480, tOnSection = 481, tOnPoint = 482, tOnLine = 483, tOnPlane = 484, tOnBox = 485, tWithArgument = 486, tFile = 487, tDepth = 488, tDimension = 489, tComma = 490, tTimeStep = 491, tHarmonicToTime = 492, tValueIndex = 493, tValueName = 494, tFormat = 495, tHeader = 496, tFooter = 497, tSkin = 498, tSmoothing = 499, tTarget = 500, tSort = 501, tIso = 502, tNoNewLine = 503, tNoTitle = 504, tDecomposeInSimplex = 505, tChangeOfValues = 506, tTimeLegend = 507, tFrequencyLegend = 508, tEigenvalueLegend = 509, tEvaluationPoints = 510, tStoreInRegister = 511, tStoreInField = 512, tLastTimeStepOnly = 513, tAppendTimeStepToFileName = 514, tOverrideTimeStepValue = 515, tNoMesh = 516, tSendToServer = 517, tColor = 518, tStr = 519, tDate = 520, tNewCoordinates = 521, tDEF = 522, tOR = 523, tAND = 524, tAPPROXEQUAL = 525, tNOTEQUAL = 526, tEQUAL = 527, tGREATERGREATER = 528, tLESSLESS = 529, tGREATEROREQUAL = 530, tLESSOREQUAL = 531, tCROSSPRODUCT = 532, UNARYPREC = 533, tSHOW = 534 }; #endif /* Tokens. */ #define tINT 258 #define tFLOAT 259 #define tSTRING 260 #define tBIGSTR 261 #define tEND 262 #define tDOTS 263 #define tStrCat 264 #define tSprintf 265 #define tPrintf 266 #define tRead 267 #define tPrintConstants 268 #define tStrCmp 269 #define tNbrRegions 270 #define tFor 271 #define tEndFor 272 #define tIf 273 #define tElse 274 #define tEndIf 275 #define tFlag 276 #define tInclude 277 #define tConstant 278 #define tList 279 #define tListAlt 280 #define tLinSpace 281 #define tLogSpace 282 #define tListFromFile 283 #define tChangeCurrentPosition 284 #define tDefineConstant 285 #define tUndefineConstant 286 #define tPi 287 #define tMPI_Rank 288 #define tMPI_Size 289 #define t0D 290 #define t1D 291 #define t2D 292 #define t3D 293 #define tExp 294 #define tLog 295 #define tLog10 296 #define tSqrt 297 #define tSin 298 #define tAsin 299 #define tCos 300 #define tAcos 301 #define tTan 302 #define tAtan 303 #define tAtan2 304 #define tSinh 305 #define tCosh 306 #define tTanh 307 #define tFabs 308 #define tFloor 309 #define tCeil 310 #define tRound 311 #define tSign 312 #define tFmod 313 #define tModulo 314 #define tHypot 315 #define tRand 316 #define tSolidAngle 317 #define tTrace 318 #define tOrder 319 #define tCrossProduct 320 #define tDofValue 321 #define tMHTransform 322 #define tMHJacNL 323 #define tGroup 324 #define tDefineGroup 325 #define tAll 326 #define tInSupport 327 #define tMovingBand2D 328 #define tDefineFunction 329 #define tConstraint 330 #define tRegion 331 #define tSubRegion 332 #define tRegionRef 333 #define tSubRegionRef 334 #define tFilter 335 #define tCoefficient 336 #define tValue 337 #define tTimeFunction 338 #define tBranch 339 #define tNameOfResolution 340 #define tJacobian 341 #define tCase 342 #define tMetricTensor 343 #define tIntegration 344 #define tMatrix 345 #define tType 346 #define tSubType 347 #define tCriterion 348 #define tGeoElement 349 #define tNumberOfPoints 350 #define tMaxNumberOfPoints 351 #define tNumberOfDivisions 352 #define tMaxNumberOfDivisions 353 #define tStoppingCriterion 354 #define tFunctionSpace 355 #define tName 356 #define tBasisFunction 357 #define tNameOfCoef 358 #define tFunction 359 #define tdFunction 360 #define tSubFunction 361 #define tSubdFunction 362 #define tSupport 363 #define tEntity 364 #define tSubSpace 365 #define tNameOfBasisFunction 366 #define tGlobalQuantity 367 #define tEntityType 368 #define tEntitySubType 369 #define tNameOfConstraint 370 #define tFormulation 371 #define tQuantity 372 #define tNameOfSpace 373 #define tIndexOfSystem 374 #define tSymmetry 375 #define tGalerkin 376 #define tdeRham 377 #define tGlobalTerm 378 #define tGlobalEquation 379 #define tDt 380 #define tDtDof 381 #define tDtDt 382 #define tDtDtDof 383 #define tJacNL 384 #define tDtDofJacNL 385 #define tNeverDt 386 #define tDtNL 387 #define tAtAnteriorTimeStep 388 #define tIn 389 #define tFull_Matrix 390 #define tResolution 391 #define tDefineSystem 392 #define tNameOfFormulation 393 #define tNameOfMesh 394 #define tFrequency 395 #define tSolver 396 #define tOriginSystem 397 #define tDestinationSystem 398 #define tOperation 399 #define tOperationEnd 400 #define tSetTime 401 #define tDTime 402 #define tSetFrequency 403 #define tFourierTransform 404 #define tFourierTransformJ 405 #define tLanczos 406 #define tEigenSolve 407 #define tEigenSolveJac 408 #define tPerturbation 409 #define tUpdate 410 #define tUpdateConstraint 411 #define tBreak 412 #define tEvaluate 413 #define tSelectCorrection 414 #define tAddCorrection 415 #define tMultiplySolution 416 #define tAddOppositeFullSolution 417 #define tSolveAgainWithOther 418 #define tTimeLoopTheta 419 #define tTimeLoopNewmark 420 #define tTimeLoopRungeKutta 421 #define tTimeLoopAdaptive 422 #define tTime0 423 #define tTimeMax 424 #define tTheta 425 #define tBeta 426 #define tGamma 427 #define tIterativeLoop 428 #define tIterativeLoopN 429 #define tIterativeLinearSolver 430 #define tNbrMaxIteration 431 #define tRelaxationFactor 432 #define tIterativeTimeReduction 433 #define tSetCommSelf 434 #define tSetCommWorld 435 #define tBarrier 436 #define tDivisionCoefficient 437 #define tChangeOfState 438 #define tChangeOfCoordinates 439 #define tChangeOfCoordinates2 440 #define tSystemCommand 441 #define tGmshRead 442 #define tGmshClearAll 443 #define tDeleteFile 444 #define tCreateDir 445 #define tGenerateOnly 446 #define tGenerateOnlyJac 447 #define tSolveJac_AdaptRelax 448 #define tTensorProductSolve 449 #define tSaveSolutionExtendedMH 450 #define tSaveSolutionMHtoTime 451 #define tSaveSolutionWithEntityNum 452 #define tInitMovingBand2D 453 #define tMeshMovingBand2D 454 #define tGenerate_MH_Moving 455 #define tGenerate_MH_Moving_Separate 456 #define tAdd_MH_Moving 457 #define tGenerateGroup 458 #define tGenerateJacGroup 459 #define tGenerateRHSGroup 460 #define tSaveMesh 461 #define tDeformeMesh 462 #define tDummyFrequency 463 #define tPostProcessing 464 #define tNameOfSystem 465 #define tPostOperation 466 #define tNameOfPostProcessing 467 #define tUsingPost 468 #define tAppend 469 #define tResampleTime 470 #define tPlot 471 #define tPrint 472 #define tPrintGroup 473 #define tEcho 474 #define tWrite 475 #define tAdapt 476 #define tOnGlobal 477 #define tOnRegion 478 #define tOnElementsOf 479 #define tOnGrid 480 #define tOnSection 481 #define tOnPoint 482 #define tOnLine 483 #define tOnPlane 484 #define tOnBox 485 #define tWithArgument 486 #define tFile 487 #define tDepth 488 #define tDimension 489 #define tComma 490 #define tTimeStep 491 #define tHarmonicToTime 492 #define tValueIndex 493 #define tValueName 494 #define tFormat 495 #define tHeader 496 #define tFooter 497 #define tSkin 498 #define tSmoothing 499 #define tTarget 500 #define tSort 501 #define tIso 502 #define tNoNewLine 503 #define tNoTitle 504 #define tDecomposeInSimplex 505 #define tChangeOfValues 506 #define tTimeLegend 507 #define tFrequencyLegend 508 #define tEigenvalueLegend 509 #define tEvaluationPoints 510 #define tStoreInRegister 511 #define tStoreInField 512 #define tLastTimeStepOnly 513 #define tAppendTimeStepToFileName 514 #define tOverrideTimeStepValue 515 #define tNoMesh 516 #define tSendToServer 517 #define tColor 518 #define tStr 519 #define tDate 520 #define tNewCoordinates 521 #define tDEF 522 #define tOR 523 #define tAND 524 #define tAPPROXEQUAL 525 #define tNOTEQUAL 526 #define tEQUAL 527 #define tGREATERGREATER 528 #define tLESSLESS 529 #define tGREATEROREQUAL 530 #define tLESSOREQUAL 531 #define tCROSSPRODUCT 532 #define UNARYPREC 533 #define tSHOW 534 /* Copy the first part of user declarations. */ #line 1 "ProParser.y" // GetDP - Copyright (C) 1997-2008 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Ruth Sabariego // Johan Gyselinck // #include #include #include #include #include #include #include #include #include "GetDPConfig.h" #include "ProData.h" #include "ProDefine.h" #include "ProDefines.h" #include "ProParser.h" #include "MallocUtils.h" #include "TreeUtils.h" #include "Message.h" #include "OS.h" // Global problem structure filled by the parser extern struct Problem Problem_S; // Global parser variables char getdp_yyname[256] = ""; char getdp_yyincludename[256] = ""; long int getdp_yylinenum = 0; int getdp_yycolnum = 0; int getdp_yyincludenum = 0; int getdp_yyerrorlevel = 0; std::map CommandLineNumbers; std::map CommandLineStrings; // Static parser variables (accessible only in this file) static Tree_T *ConstantTable_L = 0; static List_T *ListOfInt_L = 0; static List_T *ListOfPointer_L = 0, *ListOfPointer2_L = 0, *ListOfChar_L = 0; static List_T *ListOfFormulation = 0, *ListOfBasisFunction = 0, *ListOfEntityIndex = 0; static List_T *Operation_L = 0; static List_T *Current_BasisFunction_L = 0, *Current_SubSpace_L = 0; static List_T *Current_GlobalQuantity_L = 0, *Current_WholeQuantity_L = 0; static List_T *Current_System_L = 0; static int Num_BasisFunction = 1; static int FlagError = 0; static int Type_TermOperator = 0, Type_Function = 0, Type_SuppList = 0; static int Quantity_TypeOperator = 0, Quantity_Index = 0; static int Current_DofIndexInWholeQuantity = 0, Last_DofIndexInWholeQuantity = 0; static int Current_NoDofIndexInWholeQuantity = 0; static int Current_System = 0, Constraint_Index = 0; static int TypeOperatorDofInTrace = 0, DefineQuantityIndexDofInTrace = 0; static int ImbricatedLoop = 0; #define MAX_RECUR_LOOPS 100 static fpos_t FposImbricatedLoopsTab[MAX_RECUR_LOOPS]; static int LinenoImbricatedLoopsTab[MAX_RECUR_LOOPS]; static double LoopControlVariablesTab[MAX_RECUR_LOOPS][3]; static char *LoopControlVariablesNameTab[MAX_RECUR_LOOPS]; static struct Constant Constant_S, Constant1_S, Constant2_S; static struct Expression Expression_S, *Expression_P; static struct ExpressionPerRegion ExpressionPerRegion_S; static struct Group Group_S; static struct Constraint Constraint_S, *Constraint_P; static struct ConstraintPerRegion ConstraintPerRegion_S, *ConstraintPerRegion_P; static struct MultiConstraintPerRegion MultiConstraintPerRegion_S; static struct JacobianMethod JacobianMethod_S; static struct JacobianCase JacobianCase_S; static struct IntegrationMethod IntegrationMethod_S; static struct IntegrationCase IntegrationCase_S; static struct Quadrature QuadratureCase_S; static struct FunctionSpace FunctionSpace_S; static struct BasisFunction BasisFunction_S; static struct GlobalBasisFunction GlobalBasisFunction_S; static struct SubSpace SubSpace_S; static struct GlobalQuantity GlobalQuantity_S; static struct ConstraintInFS ConstraintInFS_S; static struct Formulation Formulation_S; static struct DefineQuantity DefineQuantity_S; static struct EquationTerm EquationTerm_S; static struct WholeQuantity WholeQuantity_S, *WholeQuantity_P; static struct GlobalEquationTerm GlobalEquationTerm_S; static struct Resolution Resolution_S; static struct DefineSystem DefineSystem_S; static struct Operation Operation_S, *Operation_P; static struct ChangeOfState ChangeOfState_S; static struct TimeLoopAdaptiveSystem TimeLoopAdaptiveSystem_S; static struct LoopErrorPostOperation TimeLoopAdaptivePO_S, IterativeLoopPO_S; static struct IterativeLoopSystem IterativeLoopSystem_S; static struct PostProcessing PostProcessing_S, InteractivePostProcessing_S; static struct PostQuantity PostQuantity_S; static struct PostQuantityTerm PostQuantityTerm_S; static struct PostOperation PostOperation_S; static struct PostSubOperation PostSubOperation_S; static std::map > FloatOptions_S; static std::map > CharOptions_S; // External lexer functions void hack_fsetpos(); void hack_fsetpos_printf(); int getdp_yylex(); // Forward function declarations void Alloc_ParserVariables(); void Check_NameOfStructNotExist(const char *Struct, List_T *List_L, void *data, int (*fcmp)(const void *a, const void *b)); int Add_Group(struct Group *Group_P, char *Name, bool Flag_Add, int Flag_Plus, int Num_Index); int Num_Group(struct Group *Group_P, char *Name, int Num_Group); void Fill_GroupInitialListFromString(List_T *list, const char *str); int Add_Expression(struct Expression *Expression_P, char *Name, int Flag_Plus); bool Is_ExpressionPieceWiseDefined(int index); void Pro_DefineQuantityIndex(List_T *WholeQuantity_L,int DefineQuantityIndexEqu, int *NbrQuantityIndex, int **QuantityIndexTable, int **QuantityTraceGroupIndexTable); void Pro_DefineQuantityIndex_1(List_T *WholeQuantity_L, int TraceGroupIndex); int Print_ListOfDouble(char *format, List_T *list, char *buffer); void yyerror(const char *s); void vyyerror(const char *fmt, ...); struct doubleXstring{ double d; char *s; }; /* Enabling traces. */ #ifndef YYDEBUG # define YYDEBUG 0 #endif /* Enabling verbose error messages. */ #ifdef YYERROR_VERBOSE # undef YYERROR_VERBOSE # define YYERROR_VERBOSE 1 #else # define YYERROR_VERBOSE 0 #endif /* Enabling the token table. */ #ifndef YYTOKEN_TABLE # define YYTOKEN_TABLE 0 #endif #if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED typedef union YYSTYPE #line 140 "ProParser.y" { char *c; int i; double d; List_T *l; struct TwoInt t; } /* Line 193 of yacc.c. */ #line 808 "ProParser.tab.cpp" YYSTYPE; # define yystype YYSTYPE /* obsolescent; will be withdrawn */ # define YYSTYPE_IS_DECLARED 1 # define YYSTYPE_IS_TRIVIAL 1 #endif /* Copy the second part of user declarations. */ /* Line 216 of yacc.c. */ #line 821 "ProParser.tab.cpp" #ifdef short # undef short #endif #ifdef YYTYPE_UINT8 typedef YYTYPE_UINT8 yytype_uint8; #else typedef unsigned char yytype_uint8; #endif #ifdef YYTYPE_INT8 typedef YYTYPE_INT8 yytype_int8; #elif (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) typedef signed char yytype_int8; #else typedef short int yytype_int8; #endif #ifdef YYTYPE_UINT16 typedef YYTYPE_UINT16 yytype_uint16; #else typedef unsigned short int yytype_uint16; #endif #ifdef YYTYPE_INT16 typedef YYTYPE_INT16 yytype_int16; #else typedef short int yytype_int16; #endif #ifndef YYSIZE_T # ifdef __SIZE_TYPE__ # define YYSIZE_T __SIZE_TYPE__ # elif defined size_t # define YYSIZE_T size_t # elif ! defined YYSIZE_T && (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) # include /* INFRINGES ON USER NAME SPACE */ # define YYSIZE_T size_t # else # define YYSIZE_T unsigned int # endif #endif #define YYSIZE_MAXIMUM ((YYSIZE_T) -1) #ifndef YY_ # if defined YYENABLE_NLS && YYENABLE_NLS # if ENABLE_NLS # include /* INFRINGES ON USER NAME SPACE */ # define YY_(msgid) dgettext ("bison-runtime", msgid) # endif # endif # ifndef YY_ # define YY_(msgid) msgid # endif #endif /* Suppress unused-variable warnings by "using" E. */ #if ! defined lint || defined __GNUC__ # define YYUSE(e) ((void) (e)) #else # define YYUSE(e) /* empty */ #endif /* Identity function, used to suppress warnings about constant conditions. */ #ifndef lint # define YYID(n) (n) #else #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) static int YYID (int i) #else static int YYID (i) int i; #endif { return i; } #endif #if ! defined yyoverflow || YYERROR_VERBOSE /* The parser invokes alloca or malloc; define the necessary symbols. */ # ifdef YYSTACK_USE_ALLOCA # if YYSTACK_USE_ALLOCA # ifdef __GNUC__ # define YYSTACK_ALLOC __builtin_alloca # elif defined __BUILTIN_VA_ARG_INCR # include /* INFRINGES ON USER NAME SPACE */ # elif defined _AIX # define YYSTACK_ALLOC __alloca # elif defined _MSC_VER # include /* INFRINGES ON USER NAME SPACE */ # define alloca _alloca # else # define YYSTACK_ALLOC alloca # if ! defined _ALLOCA_H && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) # include /* INFRINGES ON USER NAME SPACE */ # ifndef _STDLIB_H # define _STDLIB_H 1 # endif # endif # endif # endif # endif # ifdef YYSTACK_ALLOC /* Pacify GCC's `empty if-body' warning. */ # define YYSTACK_FREE(Ptr) do { /* empty */; } while (YYID (0)) # ifndef YYSTACK_ALLOC_MAXIMUM /* The OS might guarantee only one guard page at the bottom of the stack, and a page size can be as small as 4096 bytes. So we cannot safely invoke alloca (N) if N exceeds 4096. Use a slightly smaller number to allow for a few compiler-allocated temporary stack slots. */ # define YYSTACK_ALLOC_MAXIMUM 4032 /* reasonable circa 2006 */ # endif # else # define YYSTACK_ALLOC YYMALLOC # define YYSTACK_FREE YYFREE # ifndef YYSTACK_ALLOC_MAXIMUM # define YYSTACK_ALLOC_MAXIMUM YYSIZE_MAXIMUM # endif # if (defined __cplusplus && ! defined _STDLIB_H \ && ! ((defined YYMALLOC || defined malloc) \ && (defined YYFREE || defined free))) # include /* INFRINGES ON USER NAME SPACE */ # ifndef _STDLIB_H # define _STDLIB_H 1 # endif # endif # ifndef YYMALLOC # define YYMALLOC malloc # if ! defined malloc && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) void *malloc (YYSIZE_T); /* INFRINGES ON USER NAME SPACE */ # endif # endif # ifndef YYFREE # define YYFREE free # if ! defined free && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) void free (void *); /* INFRINGES ON USER NAME SPACE */ # endif # endif # endif #endif /* ! defined yyoverflow || YYERROR_VERBOSE */ #if (! defined yyoverflow \ && (! defined __cplusplus \ || (defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL))) /* A type that is properly aligned for any stack member. */ union yyalloc { yytype_int16 yyss; YYSTYPE yyvs; }; /* The size of the maximum gap between one aligned stack and the next. */ # define YYSTACK_GAP_MAXIMUM (sizeof (union yyalloc) - 1) /* The size of an array large to enough to hold all stacks, each with N elements. */ # define YYSTACK_BYTES(N) \ ((N) * (sizeof (yytype_int16) + sizeof (YYSTYPE)) \ + YYSTACK_GAP_MAXIMUM) /* Copy COUNT objects from FROM to TO. The source and destination do not overlap. */ # ifndef YYCOPY # if defined __GNUC__ && 1 < __GNUC__ # define YYCOPY(To, From, Count) \ __builtin_memcpy (To, From, (Count) * sizeof (*(From))) # else # define YYCOPY(To, From, Count) \ do \ { \ YYSIZE_T yyi; \ for (yyi = 0; yyi < (Count); yyi++) \ (To)[yyi] = (From)[yyi]; \ } \ while (YYID (0)) # endif # endif /* Relocate STACK from its old location to the new one. The local variables YYSIZE and YYSTACKSIZE give the old and new number of elements in the stack, and YYPTR gives the new location of the stack. Advance YYPTR to a properly aligned location for the next stack. */ # define YYSTACK_RELOCATE(Stack) \ do \ { \ YYSIZE_T yynewbytes; \ YYCOPY (&yyptr->Stack, Stack, yysize); \ Stack = &yyptr->Stack; \ yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \ yyptr += yynewbytes / sizeof (*yyptr); \ } \ while (YYID (0)) #endif /* YYFINAL -- State number of the termination state. */ #define YYFINAL 3 /* YYLAST -- Last index in YYTABLE. */ #define YYLAST 10665 /* YYNTOKENS -- Number of terminals. */ #define YYNTOKENS 304 /* YYNNTS -- Number of nonterminals. */ #define YYNNTS 207 /* YYNRULES -- Number of rules. */ #define YYNRULES 836 /* YYNRULES -- Number of states. */ #define YYNSTATES 2402 /* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */ #define YYUNDEFTOK 2 #define YYMAXUTOK 534 #define YYTRANSLATE(YYX) \ ((unsigned int) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK) /* YYTRANSLATE[YYLEX] -- Bison symbol number corresponding to YYLEX. */ static const yytype_uint16 yytranslate[] = { 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 288, 2, 296, 297, 284, 287, 2, 291, 292, 282, 280, 301, 281, 295, 283, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 274, 2, 275, 268, 302, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 293, 2, 294, 290, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 299, 286, 300, 303, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 269, 270, 271, 272, 273, 276, 277, 278, 279, 285, 289, 298 }; #if YYDEBUG /* YYPRHS[YYN] -- Index of the first RHS symbol of rule number YYN in YYRHS. */ static const yytype_uint16 yyprhs[] = { 0, 0, 3, 4, 7, 8, 9, 13, 18, 23, 28, 33, 38, 43, 48, 53, 58, 63, 65, 67, 70, 71, 74, 79, 85, 86, 87, 103, 109, 111, 112, 119, 122, 124, 126, 128, 130, 132, 134, 135, 139, 143, 145, 147, 151, 152, 156, 161, 163, 167, 173, 175, 179, 183, 187, 188, 190, 192, 196, 200, 201, 205, 206, 218, 225, 226, 228, 229, 232, 238, 245, 253, 255, 256, 260, 267, 272, 277, 278, 281, 285, 286, 290, 292, 296, 297, 300, 302, 303, 304, 312, 316, 320, 327, 331, 335, 339, 343, 347, 351, 355, 359, 363, 367, 371, 375, 379, 383, 386, 389, 392, 393, 404, 408, 410, 414, 417, 419, 422, 423, 429, 430, 438, 439, 451, 461, 466, 471, 472, 480, 487, 490, 493, 496, 499, 503, 506, 510, 512, 514, 518, 521, 525, 527, 531, 532, 536, 543, 544, 549, 550, 553, 557, 562, 563, 568, 569, 572, 576, 580, 585, 586, 591, 592, 595, 599, 603, 608, 609, 614, 615, 618, 622, 626, 631, 632, 637, 638, 641, 645, 649, 653, 657, 661, 665, 666, 669, 673, 675, 676, 679, 683, 687, 692, 698, 699, 704, 707, 708, 711, 715, 719, 723, 727, 731, 739, 743, 751, 755, 759, 763, 767, 771, 779, 787, 795, 796, 799, 803, 805, 806, 809, 812, 816, 820, 825, 830, 835, 840, 841, 846, 849, 850, 853, 857, 861, 866, 874, 878, 882, 886, 890, 891, 912, 913, 918, 919, 922, 926, 930, 934, 936, 940, 941, 945, 947, 951, 952, 956, 957, 962, 965, 966, 969, 973, 977, 981, 982, 987, 990, 991, 994, 998, 1002, 1006, 1010, 1011, 1014, 1018, 1020, 1021, 1024, 1028, 1032, 1037, 1042, 1043, 1048, 1051, 1052, 1055, 1059, 1063, 1067, 1071, 1075, 1076, 1082, 1086, 1087, 1093, 1097, 1101, 1105, 1109, 1110, 1114, 1115, 1118, 1121, 1126, 1131, 1136, 1141, 1142, 1145, 1149, 1153, 1157, 1158, 1161, 1165, 1169, 1170, 1173, 1174, 1175, 1185, 1189, 1193, 1197, 1200, 1206, 1210, 1211, 1214, 1218, 1219, 1220, 1230, 1231, 1233, 1235, 1237, 1239, 1241, 1243, 1245, 1247, 1252, 1256, 1257, 1260, 1264, 1266, 1267, 1270, 1274, 1279, 1280, 1286, 1288, 1289, 1294, 1297, 1298, 1301, 1305, 1309, 1313, 1317, 1321, 1325, 1329, 1333, 1335, 1337, 1341, 1342, 1346, 1348, 1352, 1353, 1357, 1358, 1361, 1362, 1365, 1369, 1373, 1378, 1383, 1388, 1393, 1400, 1406, 1409, 1412, 1415, 1418, 1426, 1438, 1446, 1454, 1462, 1468, 1476, 1486, 1492, 1502, 1512, 1524, 1536, 1548, 1555, 1563, 1569, 1577, 1585, 1591, 1609, 1623, 1639, 1657, 1683, 1695, 1707, 1721, 1746, 1747, 1755, 1756, 1764, 1772, 1784, 1791, 1797, 1803, 1811, 1814, 1820, 1826, 1836, 1842, 1851, 1861, 1871, 1877, 1883, 1895, 1905, 1920, 1935, 1943, 1956, 1967, 1975, 1984, 1993, 2002, 2011, 2029, 2031, 2033, 2035, 2036, 2039, 2043, 2047, 2050, 2051, 2054, 2059, 2066, 2067, 2073, 2079, 2080, 2091, 2092, 2103, 2104, 2110, 2116, 2117, 2129, 2130, 2141, 2142, 2145, 2149, 2153, 2157, 2161, 2166, 2167, 2170, 2174, 2178, 2182, 2186, 2190, 2195, 2196, 2199, 2203, 2207, 2211, 2215, 2220, 2221, 2224, 2228, 2232, 2236, 2240, 2244, 2249, 2254, 2259, 2260, 2265, 2266, 2269, 2273, 2277, 2281, 2285, 2289, 2293, 2294, 2297, 2301, 2303, 2304, 2307, 2311, 2315, 2319, 2324, 2325, 2330, 2333, 2334, 2337, 2341, 2346, 2347, 2353, 2359, 2362, 2363, 2366, 2367, 2374, 2378, 2382, 2386, 2390, 2391, 2394, 2398, 2400, 2401, 2404, 2408, 2412, 2416, 2420, 2430, 2435, 2436, 2445, 2446, 2447, 2451, 2459, 2467, 2476, 2488, 2495, 2496, 2507, 2509, 2513, 2520, 2522, 2524, 2526, 2528, 2529, 2533, 2535, 2538, 2541, 2554, 2557, 2573, 2578, 2591, 2609, 2632, 2645, 2646, 2649, 2653, 2658, 2663, 2667, 2670, 2673, 2677, 2681, 2684, 2688, 2692, 2696, 2700, 2704, 2708, 2712, 2716, 2720, 2724, 2730, 2733, 2736, 2739, 2743, 2753, 2757, 2760, 2770, 2773, 2783, 2786, 2796, 2802, 2806, 2810, 2813, 2816, 2820, 2824, 2827, 2831, 2835, 2839, 2846, 2855, 2864, 2875, 2877, 2882, 2884, 2886, 2892, 2898, 2903, 2911, 2917, 2923, 2928, 2936, 2944, 2949, 2957, 2963, 2969, 2973, 2977, 2985, 2993, 2999, 3005, 3014, 3022, 3025, 3029, 3035, 3036, 3039, 3043, 3049, 3053, 3054, 3057, 3061, 3065, 3071, 3072, 3076, 3083, 3089, 3090, 3100, 3106, 3107, 3117, 3118, 3122, 3126, 3128, 3130, 3132, 3134, 3136, 3138, 3140, 3142, 3144, 3146, 3148, 3150, 3152, 3154, 3156, 3158, 3160, 3162, 3164, 3166, 3168, 3170, 3172, 3174, 3176, 3178, 3182, 3185, 3188, 3192, 3196, 3200, 3204, 3208, 3212, 3216, 3220, 3224, 3228, 3232, 3236, 3240, 3244, 3248, 3252, 3257, 3262, 3267, 3272, 3277, 3282, 3287, 3292, 3297, 3302, 3309, 3314, 3319, 3324, 3329, 3334, 3339, 3344, 3349, 3356, 3363, 3370, 3375, 3381, 3383, 3385, 3388, 3390, 3392, 3394, 3396, 3398, 3400, 3402, 3404, 3406, 3408, 3413, 3418, 3419, 3422, 3424, 3426, 3430, 3432, 3434, 3438, 3442, 3444, 3448, 3451, 3455, 3459, 3463, 3467, 3471, 3475, 3479, 3483, 3487, 3491, 3497, 3501, 3505, 3512, 3517, 3524, 3533, 3542, 3548, 3554, 3556, 3558, 3560, 3564, 3566, 3568, 3573, 3578, 3583, 3590, 3597, 3599, 3601, 3603, 3605, 3609, 3616, 3623, 3630 }; /* YYRHS -- A `-1'-separated list of the rules' RHS. */ static const yytype_int16 yyrhs[] = { 305, 0, -1, -1, 306, 307, -1, -1, -1, 307, 308, 309, -1, 69, 299, 310, 300, -1, 104, 299, 328, 300, -1, 75, 299, 364, 300, -1, 86, 299, 349, 300, -1, 89, 299, 355, 300, -1, 100, 299, 371, 300, -1, 116, 299, 392, 300, -1, 136, 299, 418, 300, -1, 209, 299, 456, 300, -1, 211, 299, 467, 300, -1, 471, -1, 483, -1, 22, 506, -1, -1, 310, 311, -1, 503, 267, 314, 7, -1, 503, 280, 267, 314, 7, -1, -1, -1, 503, 267, 73, 293, 323, 312, 301, 321, 313, 301, 321, 301, 496, 294, 7, -1, 70, 293, 325, 294, 7, -1, 483, -1, -1, 317, 293, 318, 315, 319, 294, -1, 296, 321, -1, 314, -1, 503, -1, 76, -1, 5, -1, 321, -1, 71, -1, -1, 327, 320, 321, -1, 327, 72, 503, -1, 5, -1, 323, -1, 299, 322, 300, -1, -1, 322, 327, 323, -1, 322, 327, 281, 323, -1, 3, -1, 3, 8, 3, -1, 3, 8, 3, 8, 3, -1, 503, -1, 291, 496, 292, -1, 291, 501, 292, -1, 302, 501, 302, -1, -1, 5, -1, 3, -1, 324, 301, 5, -1, 324, 301, 3, -1, -1, 325, 327, 503, -1, -1, 325, 327, 503, 267, 299, 326, 299, 324, 300, 488, 300, -1, 325, 327, 503, 299, 496, 300, -1, -1, 301, -1, -1, 328, 329, -1, 74, 293, 330, 294, 7, -1, 503, 293, 294, 267, 331, 7, -1, 503, 293, 316, 294, 267, 331, 7, -1, 483, -1, -1, 330, 327, 5, -1, 330, 327, 5, 299, 496, 300, -1, 23, 293, 496, 294, -1, 104, 293, 5, 294, -1, -1, 332, 335, -1, 282, 282, 282, -1, -1, 299, 334, 300, -1, 331, -1, 334, 301, 331, -1, -1, 336, 337, -1, 341, -1, -1, -1, 337, 268, 338, 337, 8, 339, 337, -1, 337, 282, 337, -1, 337, 285, 337, -1, 65, 293, 337, 301, 337, 294, -1, 337, 283, 337, -1, 337, 280, 337, -1, 337, 281, 337, -1, 337, 284, 337, -1, 337, 290, 337, -1, 337, 274, 337, -1, 337, 275, 337, -1, 337, 279, 337, -1, 337, 278, 337, -1, 337, 273, 337, -1, 337, 272, 337, -1, 337, 271, 337, -1, 337, 270, 337, -1, 337, 269, 337, -1, 281, 337, -1, 280, 337, -1, 288, 337, -1, -1, 274, 29, 293, 337, 294, 275, 340, 293, 337, 294, -1, 291, 337, 292, -1, 497, -1, 495, 346, 348, -1, 5, 417, -1, 417, -1, 417, 346, -1, -1, 125, 342, 293, 335, 294, -1, -1, 133, 343, 293, 335, 301, 3, 294, -1, -1, 67, 293, 5, 293, 344, 335, 294, 294, 299, 496, 300, -1, 68, 293, 5, 294, 299, 496, 301, 496, 300, -1, 62, 293, 417, 294, -1, 64, 293, 417, 294, -1, -1, 63, 345, 293, 335, 301, 316, 294, -1, 274, 5, 275, 293, 335, 294, -1, 297, 5, -1, 297, 236, -1, 297, 147, -1, 297, 3, -1, 341, 296, 3, -1, 296, 3, -1, 341, 298, 496, -1, 509, -1, 510, -1, 293, 295, 294, -1, 293, 294, -1, 293, 347, 294, -1, 337, -1, 347, 301, 337, -1, -1, 299, 499, 300, -1, 299, 76, 293, 316, 294, 300, -1, -1, 349, 299, 350, 300, -1, -1, 350, 351, -1, 101, 503, 7, -1, 87, 299, 352, 300, -1, -1, 352, 299, 353, 300, -1, -1, 353, 354, -1, 76, 316, 7, -1, 76, 71, 7, -1, 86, 503, 348, 7, -1, -1, 355, 299, 356, 300, -1, -1, 356, 357, -1, 101, 5, 7, -1, 93, 331, 7, -1, 87, 299, 358, 300, -1, -1, 358, 299, 359, 300, -1, -1, 359, 360, -1, 91, 5, 7, -1, 92, 5, 7, -1, 87, 299, 361, 300, -1, -1, 361, 299, 362, 300, -1, -1, 362, 363, -1, 94, 5, 7, -1, 95, 496, 7, -1, 96, 496, 7, -1, 97, 496, 7, -1, 98, 496, 7, -1, 99, 496, 7, -1, -1, 364, 365, -1, 299, 366, 300, -1, 483, -1, -1, 366, 367, -1, 101, 503, 7, -1, 91, 5, 7, -1, 87, 299, 368, 300, -1, 87, 5, 299, 368, 300, -1, -1, 368, 299, 369, 300, -1, 368, 483, -1, -1, 369, 370, -1, 91, 5, 7, -1, 76, 316, 7, -1, 77, 316, 7, -1, 83, 331, 7, -1, 82, 331, 7, -1, 82, 293, 331, 301, 331, 294, 7, -1, 85, 503, 7, -1, 84, 299, 497, 327, 497, 300, 7, -1, 78, 316, 7, -1, 79, 316, 7, -1, 104, 331, 7, -1, 81, 331, 7, -1, 80, 331, 7, -1, 104, 293, 331, 301, 331, 294, 7, -1, 81, 293, 331, 301, 331, 294, 7, -1, 80, 293, 331, 301, 331, 294, 7, -1, -1, 371, 372, -1, 299, 373, 300, -1, 483, -1, -1, 373, 374, -1, 373, 483, -1, 101, 503, 7, -1, 91, 5, 7, -1, 102, 299, 375, 300, -1, 110, 299, 379, 300, -1, 112, 299, 386, 300, -1, 75, 299, 389, 300, -1, -1, 375, 299, 376, 300, -1, 375, 483, -1, -1, 376, 377, -1, 101, 503, 7, -1, 103, 503, 7, -1, 104, 5, 378, 7, -1, 105, 299, 5, 327, 5, 300, 7, -1, 106, 333, 7, -1, 107, 333, 7, -1, 108, 316, 7, -1, 109, 316, 7, -1, -1, 299, 117, 5, 7, 116, 5, 299, 496, 300, 7, 69, 316, 7, 136, 5, 299, 496, 300, 7, 300, -1, -1, 379, 299, 380, 300, -1, -1, 380, 381, -1, 101, 5, 7, -1, 111, 382, 7, -1, 103, 384, 7, -1, 5, -1, 299, 383, 300, -1, -1, 383, 327, 5, -1, 5, -1, 299, 385, 300, -1, -1, 385, 327, 5, -1, -1, 386, 299, 387, 300, -1, 386, 483, -1, -1, 387, 388, -1, 101, 503, 7, -1, 91, 5, 7, -1, 103, 503, 7, -1, -1, 389, 299, 390, 300, -1, 389, 483, -1, -1, 390, 391, -1, 103, 503, 7, -1, 113, 317, 7, -1, 114, 320, 7, -1, 115, 503, 7, -1, -1, 392, 393, -1, 299, 394, 300, -1, 483, -1, -1, 394, 395, -1, 101, 503, 7, -1, 91, 5, 7, -1, 117, 299, 396, 300, -1, 5, 299, 402, 300, -1, -1, 396, 299, 397, 300, -1, 396, 483, -1, -1, 397, 398, -1, 101, 503, 7, -1, 91, 112, 7, -1, 91, 121, 7, -1, 91, 5, 7, -1, 208, 498, 7, -1, -1, 118, 503, 399, 401, 7, -1, 119, 496, 7, -1, -1, 293, 400, 335, 294, 7, -1, 134, 316, 7, -1, 89, 5, 7, -1, 86, 503, 7, -1, 120, 3, 7, -1, -1, 293, 503, 294, -1, -1, 402, 403, -1, 402, 483, -1, 121, 299, 408, 300, -1, 122, 299, 408, 300, -1, 123, 299, 412, 300, -1, 124, 299, 404, 300, -1, -1, 404, 405, -1, 91, 5, 7, -1, 115, 5, 7, -1, 299, 406, 300, -1, -1, 406, 407, -1, 5, 417, 7, -1, 134, 316, 7, -1, -1, 408, 409, -1, -1, -1, 416, 293, 410, 335, 411, 301, 335, 294, 7, -1, 134, 316, 7, -1, 86, 503, 7, -1, 89, 5, 7, -1, 135, 7, -1, 90, 293, 3, 294, 7, -1, 88, 331, 7, -1, -1, 412, 413, -1, 134, 316, 7, -1, -1, -1, 416, 293, 414, 335, 415, 301, 417, 294, 7, -1, -1, 125, -1, 126, -1, 127, -1, 128, -1, 129, -1, 130, -1, 131, -1, 132, -1, 299, 5, 503, 300, -1, 299, 503, 300, -1, -1, 418, 419, -1, 299, 420, 300, -1, 483, -1, -1, 420, 421, -1, 101, 503, 7, -1, 137, 299, 423, 300, -1, -1, 144, 422, 299, 430, 300, -1, 483, -1, -1, 423, 299, 424, 300, -1, 423, 483, -1, -1, 424, 425, -1, 101, 503, 7, -1, 91, 5, 7, -1, 138, 426, 7, -1, 139, 506, 7, -1, 142, 428, 7, -1, 143, 503, 7, -1, 140, 498, 7, -1, 141, 506, 7, -1, 483, -1, 503, -1, 299, 427, 300, -1, -1, 427, 327, 503, -1, 503, -1, 299, 429, 300, -1, -1, 429, 327, 503, -1, -1, 430, 432, -1, -1, 301, 496, -1, 5, 503, 7, -1, 146, 331, 7, -1, 164, 299, 445, 300, -1, 165, 299, 447, 300, -1, 173, 299, 449, 300, -1, 178, 299, 451, 300, -1, 5, 293, 503, 431, 294, 7, -1, 146, 293, 331, 294, 7, -1, 179, 7, -1, 180, 7, -1, 181, 7, -1, 157, 7, -1, 18, 293, 331, 294, 299, 430, 300, -1, 18, 293, 331, 294, 299, 430, 300, 19, 299, 430, 300, -1, 148, 293, 503, 301, 331, 294, 7, -1, 191, 293, 503, 301, 498, 294, 7, -1, 192, 293, 503, 301, 498, 294, 7, -1, 155, 293, 503, 294, 7, -1, 155, 293, 503, 301, 331, 294, 7, -1, 156, 293, 503, 301, 316, 301, 503, 294, 7, -1, 156, 293, 503, 294, 7, -1, 149, 293, 503, 301, 503, 301, 498, 294, 7, -1, 150, 293, 503, 301, 503, 301, 496, 294, 7, -1, 151, 293, 503, 301, 496, 301, 498, 301, 496, 294, 7, -1, 152, 293, 503, 301, 496, 301, 496, 301, 496, 294, 7, -1, 153, 293, 503, 301, 496, 301, 496, 301, 496, 294, 7, -1, 158, 293, 331, 431, 294, 7, -1, 159, 293, 503, 301, 496, 294, 7, -1, 160, 293, 503, 294, 7, -1, 160, 293, 503, 301, 496, 294, 7, -1, 161, 293, 503, 301, 496, 294, 7, -1, 162, 293, 503, 294, 7, -1, 154, 293, 503, 301, 503, 301, 503, 301, 496, 301, 498, 301, 496, 301, 496, 294, 7, -1, 164, 293, 496, 301, 496, 301, 331, 301, 331, 294, 299, 430, 300, -1, 165, 293, 496, 301, 496, 301, 331, 301, 496, 301, 496, 294, 299, 430, 300, -1, 166, 293, 503, 301, 496, 301, 496, 301, 331, 301, 498, 301, 498, 301, 498, 294, 7, -1, 167, 293, 496, 301, 496, 301, 496, 301, 496, 301, 496, 301, 506, 301, 498, 301, 439, 438, 294, 299, 430, 300, 299, 430, 300, -1, 174, 293, 496, 301, 331, 301, 442, 294, 299, 430, 300, -1, 173, 293, 496, 301, 496, 301, 331, 294, 299, 430, 300, -1, 173, 293, 496, 301, 496, 301, 331, 301, 496, 294, 299, 430, 300, -1, 175, 293, 506, 301, 506, 301, 496, 301, 496, 301, 496, 301, 498, 301, 498, 301, 498, 294, 299, 430, 300, 299, 430, 300, -1, -1, 217, 433, 293, 435, 436, 294, 7, -1, -1, 220, 434, 293, 435, 436, 294, 7, -1, 184, 293, 316, 301, 331, 294, 7, -1, 184, 293, 316, 301, 331, 301, 496, 301, 331, 294, 7, -1, 211, 293, 503, 431, 294, 7, -1, 186, 293, 506, 294, 7, -1, 187, 293, 506, 294, 7, -1, 187, 293, 506, 301, 496, 294, 7, -1, 188, 7, -1, 189, 293, 506, 294, 7, -1, 190, 293, 506, 294, 7, -1, 193, 293, 503, 301, 498, 301, 496, 294, 7, -1, 197, 293, 503, 294, 7, -1, 197, 293, 503, 301, 316, 431, 294, 7, -1, 195, 293, 503, 301, 496, 301, 506, 294, 7, -1, 196, 293, 503, 301, 498, 301, 506, 294, 7, -1, 198, 293, 503, 294, 7, -1, 199, 293, 503, 294, 7, -1, 206, 293, 503, 301, 316, 301, 506, 301, 331, 294, 7, -1, 206, 293, 503, 301, 316, 301, 506, 294, 7, -1, 200, 293, 503, 301, 503, 301, 496, 301, 496, 294, 299, 430, 300, 7, -1, 201, 293, 503, 301, 503, 301, 496, 301, 496, 294, 299, 430, 300, 7, -1, 202, 293, 503, 301, 496, 294, 7, -1, 207, 293, 5, 301, 5, 301, 139, 506, 301, 496, 294, 7, -1, 207, 293, 5, 301, 5, 301, 139, 506, 294, 7, -1, 207, 293, 5, 301, 5, 294, 7, -1, 203, 293, 503, 301, 503, 431, 294, 7, -1, 204, 293, 503, 301, 503, 431, 294, 7, -1, 205, 293, 503, 301, 316, 431, 294, 7, -1, 163, 293, 503, 301, 503, 431, 294, 7, -1, 194, 293, 299, 504, 300, 301, 299, 504, 300, 301, 498, 301, 299, 500, 300, 294, 7, -1, 483, -1, 333, -1, 503, -1, -1, 436, 437, -1, 301, 232, 506, -1, 301, 236, 498, -1, 301, 498, -1, -1, 301, 496, -1, 301, 496, 301, 496, -1, 301, 496, 301, 496, 301, 496, -1, -1, 439, 137, 299, 440, 300, -1, 439, 211, 299, 441, 300, -1, -1, 440, 299, 503, 301, 496, 301, 496, 301, 5, 300, -1, -1, 441, 299, 503, 301, 496, 301, 496, 301, 5, 300, -1, -1, 442, 137, 299, 443, 300, -1, 442, 211, 299, 444, 300, -1, -1, 443, 299, 503, 301, 496, 301, 496, 301, 5, 5, 300, -1, -1, 444, 299, 503, 301, 496, 301, 496, 301, 5, 300, -1, -1, 445, 446, -1, 168, 496, 7, -1, 169, 496, 7, -1, 147, 331, 7, -1, 170, 331, 7, -1, 144, 299, 430, 300, -1, -1, 447, 448, -1, 168, 496, 7, -1, 169, 496, 7, -1, 147, 331, 7, -1, 171, 496, 7, -1, 172, 496, 7, -1, 144, 299, 430, 300, -1, -1, 449, 450, -1, 176, 496, 7, -1, 93, 496, 7, -1, 177, 331, 7, -1, 21, 496, 7, -1, 144, 299, 430, 300, -1, -1, 451, 452, -1, 176, 496, 7, -1, 182, 496, 7, -1, 93, 496, 7, -1, 21, 496, 7, -1, 137, 503, 7, -1, 183, 299, 453, 300, -1, 144, 299, 430, 300, -1, 145, 299, 430, 300, -1, -1, 453, 299, 454, 300, -1, -1, 454, 455, -1, 91, 5, 7, -1, 117, 5, 7, -1, 134, 316, 7, -1, 93, 496, 7, -1, 104, 331, 7, -1, 21, 5, 7, -1, -1, 456, 457, -1, 299, 458, 300, -1, 483, -1, -1, 458, 459, -1, 101, 503, 7, -1, 138, 503, 7, -1, 210, 503, 7, -1, 117, 299, 460, 300, -1, -1, 460, 299, 461, 300, -1, 460, 483, -1, -1, 461, 462, -1, 101, 503, 7, -1, 82, 299, 463, 300, -1, -1, 463, 121, 299, 464, 300, -1, 463, 5, 299, 464, 300, -1, 463, 483, -1, -1, 464, 465, -1, -1, 416, 293, 466, 335, 294, 7, -1, 91, 5, 7, -1, 134, 316, 7, -1, 86, 503, 7, -1, 89, 5, 7, -1, -1, 467, 468, -1, 299, 469, 300, -1, 483, -1, -1, 469, 470, -1, 101, 503, 7, -1, 212, 503, 7, -1, 240, 5, 7, -1, 214, 506, 7, -1, 215, 293, 496, 301, 496, 301, 496, 294, 7, -1, 144, 299, 473, 300, -1, -1, 211, 503, 213, 503, 472, 299, 473, 300, -1, -1, -1, 473, 474, 475, -1, 216, 293, 477, 480, 481, 294, 7, -1, 217, 293, 477, 480, 481, 294, 7, -1, 217, 293, 6, 301, 331, 481, 294, 7, -1, 217, 293, 6, 301, 264, 293, 506, 294, 481, 294, 7, -1, 219, 293, 6, 481, 294, 7, -1, -1, 218, 293, 316, 476, 301, 134, 316, 481, 294, 7, -1, 483, -1, 503, 479, 301, -1, 503, 479, 478, 5, 479, 301, -1, 282, -1, 283, -1, 280, -1, 281, -1, -1, 293, 316, 294, -1, 222, -1, 223, 316, -1, 224, 316, -1, 226, 299, 299, 499, 300, 299, 499, 300, 299, 499, 300, 300, -1, 225, 316, -1, 225, 299, 331, 301, 331, 301, 331, 300, 299, 498, 301, 498, 301, 498, 300, -1, 227, 299, 499, 300, -1, 228, 299, 299, 499, 300, 299, 499, 300, 300, 299, 496, 300, -1, 229, 299, 299, 499, 300, 299, 499, 300, 299, 499, 300, 300, 299, 496, 301, 496, 300, -1, 230, 299, 299, 499, 300, 299, 499, 300, 299, 499, 300, 299, 499, 300, 300, 299, 496, 301, 496, 301, 496, 300, -1, 223, 316, 231, 5, 299, 496, 301, 496, 300, 299, 496, 300, -1, -1, 481, 482, -1, 301, 232, 506, -1, 301, 232, 275, 506, -1, 301, 232, 276, 506, -1, 301, 233, 496, -1, 301, 243, -1, 301, 244, -1, 301, 237, 496, -1, 301, 240, 5, -1, 301, 235, -1, 301, 238, 496, -1, 301, 239, 506, -1, 301, 101, 506, -1, 301, 234, 496, -1, 301, 236, 498, -1, 301, 221, 5, -1, 301, 246, 5, -1, 301, 245, 496, -1, 301, 82, 498, -1, 301, 247, 496, -1, 301, 247, 299, 499, 300, -1, 301, 248, -1, 301, 249, -1, 301, 250, -1, 301, 140, 498, -1, 301, 184, 299, 331, 301, 331, 301, 331, 300, -1, 301, 251, 333, -1, 301, 252, -1, 301, 252, 299, 496, 301, 496, 301, 496, 300, -1, 301, 253, -1, 301, 253, 299, 496, 301, 496, 301, 496, 300, -1, 301, 254, -1, 301, 254, 299, 496, 301, 496, 301, 496, 300, -1, 301, 255, 299, 499, 300, -1, 301, 256, 3, -1, 301, 257, 496, -1, 301, 258, -1, 301, 259, -1, 301, 259, 496, -1, 301, 260, 496, -1, 301, 261, -1, 301, 262, 506, -1, 301, 263, 506, -1, 301, 266, 506, -1, 16, 291, 496, 8, 496, 292, -1, 16, 291, 496, 8, 496, 8, 496, 292, -1, 16, 5, 134, 299, 496, 8, 496, 300, -1, 16, 5, 134, 299, 496, 8, 496, 8, 496, 300, -1, 17, -1, 18, 291, 496, 292, -1, 20, -1, 484, -1, 30, 293, 490, 294, 7, -1, 31, 293, 493, 294, 7, -1, 503, 267, 498, 7, -1, 503, 291, 499, 292, 267, 498, 7, -1, 503, 280, 267, 498, 7, -1, 503, 281, 267, 498, 7, -1, 503, 267, 6, 7, -1, 503, 267, 264, 293, 506, 294, 7, -1, 503, 267, 264, 291, 506, 292, 7, -1, 503, 267, 508, 7, -1, 503, 267, 28, 293, 506, 294, 7, -1, 11, 291, 6, 292, 7, -1, 11, 293, 6, 294, 7, -1, 11, 503, 7, -1, 11, 296, 7, -1, 11, 291, 6, 301, 499, 292, 7, -1, 11, 293, 6, 301, 499, 294, 7, -1, 12, 291, 503, 292, 7, -1, 12, 293, 503, 294, 7, -1, 12, 291, 503, 292, 293, 496, 294, 7, -1, 12, 293, 503, 301, 496, 300, 7, -1, 13, 7, -1, 496, 267, 506, -1, 485, 301, 496, 267, 506, -1, -1, 486, 487, -1, 301, 5, 498, -1, 301, 5, 299, 485, 300, -1, 301, 5, 505, -1, -1, 488, 489, -1, 301, 5, 496, -1, 301, 5, 505, -1, 301, 5, 299, 507, 300, -1, -1, 490, 327, 503, -1, 490, 327, 503, 299, 496, 300, -1, 490, 327, 503, 267, 496, -1, -1, 490, 327, 503, 267, 299, 496, 491, 486, 300, -1, 490, 327, 503, 267, 6, -1, -1, 490, 327, 503, 267, 299, 6, 492, 488, 300, -1, -1, 493, 327, 505, -1, 493, 327, 503, -1, 39, -1, 40, -1, 41, -1, 42, -1, 43, -1, 44, -1, 45, -1, 46, -1, 47, -1, 48, -1, 49, -1, 50, -1, 51, -1, 52, -1, 53, -1, 54, -1, 55, -1, 56, -1, 57, -1, 58, -1, 59, -1, 60, -1, 61, -1, 494, -1, 503, -1, 497, -1, 291, 496, 292, -1, 281, 496, -1, 288, 496, -1, 496, 281, 496, -1, 496, 280, 496, -1, 496, 282, 496, -1, 496, 286, 496, -1, 496, 287, 496, -1, 496, 283, 496, -1, 496, 284, 496, -1, 496, 290, 496, -1, 496, 274, 496, -1, 496, 275, 496, -1, 496, 279, 496, -1, 496, 278, 496, -1, 496, 273, 496, -1, 496, 272, 496, -1, 496, 270, 496, -1, 496, 269, 496, -1, 39, 293, 496, 294, -1, 40, 293, 496, 294, -1, 41, 293, 496, 294, -1, 42, 293, 496, 294, -1, 43, 293, 496, 294, -1, 44, 293, 496, 294, -1, 45, 293, 496, 294, -1, 46, 293, 496, 294, -1, 47, 293, 496, 294, -1, 48, 293, 496, 294, -1, 49, 293, 496, 301, 496, 294, -1, 50, 293, 496, 294, -1, 51, 293, 496, 294, -1, 52, 293, 496, 294, -1, 53, 293, 496, 294, -1, 54, 293, 496, 294, -1, 55, 293, 496, 294, -1, 56, 293, 496, 294, -1, 57, 293, 496, 294, -1, 58, 293, 496, 301, 496, 294, -1, 59, 293, 496, 301, 496, 294, -1, 60, 293, 496, 301, 496, 294, -1, 61, 293, 496, 294, -1, 496, 268, 496, 8, 496, -1, 509, -1, 510, -1, 496, 296, -1, 4, -1, 3, -1, 32, -1, 35, -1, 36, -1, 37, -1, 38, -1, 33, -1, 34, -1, 503, -1, 296, 5, 291, 292, -1, 5, 291, 496, 292, -1, -1, 299, 300, -1, 496, -1, 501, -1, 299, 499, 300, -1, 496, -1, 501, -1, 499, 301, 496, -1, 499, 301, 501, -1, 498, -1, 500, 301, 498, -1, 281, 501, -1, 496, 282, 501, -1, 501, 282, 496, -1, 496, 283, 501, -1, 501, 283, 496, -1, 501, 290, 496, -1, 501, 280, 501, -1, 501, 281, 501, -1, 501, 282, 501, -1, 501, 283, 501, -1, 496, 8, 496, -1, 496, 8, 496, 8, 496, -1, 5, 291, 292, -1, 5, 299, 300, -1, 5, 291, 299, 499, 300, 292, -1, 24, 293, 5, 294, -1, 25, 293, 5, 301, 5, 294, -1, 26, 293, 496, 301, 496, 301, 496, 294, -1, 27, 293, 496, 301, 496, 301, 496, 294, -1, 5, 303, 299, 496, 300, -1, 502, 303, 299, 496, 300, -1, 5, -1, 502, -1, 503, -1, 504, 301, 503, -1, 6, -1, 508, -1, 264, 293, 507, 294, -1, 10, 291, 506, 292, -1, 10, 293, 506, 294, -1, 10, 291, 506, 301, 499, 292, -1, 10, 293, 506, 301, 499, 294, -1, 265, -1, 505, -1, 503, -1, 506, -1, 507, 301, 506, -1, 9, 293, 506, 301, 506, 294, -1, 9, 291, 506, 301, 506, 292, -1, 14, 293, 506, 301, 506, 294, -1, 15, 293, 503, 294, -1 }; /* YYRLINE[YYN] -- source line where rule number YYN was defined. */ static const yytype_uint16 yyrline[] = { 0, 308, 308, 308, 318, 322, 321, 329, 330, 331, 332, 333, 334, 335, 336, 337, 338, 340, 342, 344, 356, 359, 365, 368, 372, 388, 371, 399, 401, 407, 406, 423, 434, 439, 457, 460, 473, 474, 481, 483, 486, 505, 517, 524, 531, 535, 542, 553, 558, 566, 578, 615, 622, 636, 651, 655, 661, 668, 674, 682, 686, 699, 698, 719, 738, 738, 745, 748, 753, 755, 776, 821, 825, 828, 839, 863, 869, 877, 877, 884, 892, 896, 902, 905, 912, 912, 925, 928, 941, 927, 969, 977, 985, 993, 1001, 1009, 1017, 1025, 1033, 1041, 1049, 1057, 1065, 1073, 1081, 1089, 1097, 1106, 1114, 1116, 1125, 1124, 1155, 1157, 1163, 1238, 1272, 1281, 1294, 1293, 1308, 1307, 1322, 1321, 1338, 1351, 1357, 1364, 1363, 1394, 1420, 1433, 1439, 1446, 1452, 1459, 1466, 1473, 1479, 1489, 1490, 1491, 1496, 1497, 1503, 1505, 1508, 1524, 1528, 1536, 1538, 1544, 1549, 1557, 1559, 1567, 1570, 1576, 1579, 1582, 1621, 1626, 1634, 1640, 1646, 1653, 1656, 1664, 1666, 1674, 1679, 1685, 1695, 1705, 1713, 1715, 1723, 1732, 1738, 1786, 1789, 1792, 1795, 1798, 1810, 1814, 1819, 1824, 1830, 1836, 1842, 1849, 1858, 1861, 1880, 1884, 1889, 1899, 1906, 1912, 1922, 1927, 1933, 1940, 1950, 1960, 1968, 1977, 1995, 2004, 2012, 2020, 2030, 2040, 2050, 2071, 2076, 2081, 2086, 2093, 2098, 2100, 2106, 2113, 2122, 2125, 2128, 2131, 2139, 2144, 2162, 2172, 2186, 2192, 2195, 2200, 2214, 2237, 2242, 2247, 2252, 2281, 2285, 2342, 2347, 2357, 2361, 2367, 2374, 2377, 2384, 2402, 2409, 2411, 2432, 2445, 2453, 2457, 2474, 2479, 2485, 2495, 2500, 2506, 2513, 2524, 2540, 2544, 2582, 2592, 2601, 2607, 2627, 2630, 2633, 2651, 2655, 2660, 2665, 2672, 2676, 2682, 2689, 2699, 2701, 2711, 2715, 2720, 2727, 2742, 2748, 2751, 2755, 2758, 2768, 2773, 2772, 2806, 2812, 2811, 3079, 3084, 3095, 3106, 3111, 3114, 3157, 3161, 3166, 3175, 3178, 3181, 3184, 3192, 3197, 3202, 3212, 3223, 3238, 3244, 3248, 3260, 3269, 3287, 3294, 3302, 3293, 3435, 3440, 3451, 3462, 3467, 3474, 3484, 3498, 3503, 3509, 3517, 3508, 3589, 3590, 3591, 3592, 3593, 3594, 3595, 3596, 3597, 3603, 3624, 3649, 3653, 3658, 3663, 3670, 3675, 3681, 3688, 3692, 3691, 3696, 3702, 3706, 3715, 3725, 3737, 3743, 3752, 3761, 3764, 3769, 3780, 3785, 3790, 3795, 3801, 3811, 3819, 3821, 3834, 3845, 3852, 3854, 3868, 3876, 3886, 3887, 3895, 3919, 3926, 3932, 3938, 3944, 3952, 3982, 3989, 3996, 4003, 4010, 4016, 4027, 4039, 4052, 4074, 4096, 4109, 4122, 4143, 4157, 4175, 4195, 4218, 4233, 4248, 4260, 4273, 4286, 4299, 4312, 4324, 4359, 4372, 4386, 4405, 4425, 4436, 4449, 4462, 4483, 4482, 4492, 4491, 4500, 4511, 4523, 4539, 4547, 4557, 4567, 4574, 4583, 4592, 4606, 4619, 4634, 4648, 4662, 4673, 4684, 4699, 4714, 4734, 4754, 4766, 4782, 4798, 4814, 4835, 4856, 4874, 4897, 4934, 4943, 4948, 4961, 4966, 4970, 4973, 4985, 5001, 5007, 5014, 5021, 5032, 5039, 5044, 5054, 5058, 5079, 5083, 5100, 5107, 5112, 5122, 5126, 5154, 5158, 5179, 5188, 5194, 5198, 5202, 5206, 5211, 5223, 5233, 5239, 5243, 5247, 5251, 5255, 5260, 5272, 5281, 5286, 5290, 5294, 5298, 5302, 5314, 5326, 5331, 5335, 5339, 5343, 5348, 5359, 5365, 5371, 5382, 5384, 5390, 5402, 5407, 5417, 5445, 5448, 5451, 5459, 5478, 5484, 5489, 5494, 5499, 5507, 5511, 5518, 5532, 5537, 5544, 5546, 5549, 5556, 5561, 5566, 5569, 5576, 5579, 5585, 5597, 5603, 5612, 5617, 5616, 5652, 5663, 5668, 5679, 5699, 5705, 5710, 5713, 5718, 5726, 5730, 5737, 5750, 5761, 5766, 5774, 5781, 5780, 5809, 5812, 5811, 5828, 5833, 5838, 5847, 5856, 5866, 5865, 5876, 5885, 5898, 5923, 5924, 5925, 5926, 5932, 5933, 5939, 5945, 5952, 5959, 5983, 5990, 6002, 6015, 6035, 6061, 6095, 6117, 6160, 6164, 6178, 6192, 6206, 6210, 6214, 6218, 6222, 6232, 6236, 6240, 6244, 6248, 6255, 6266, 6275, 6284, 6291, 6300, 6304, 6314, 6318, 6322, 6326, 6335, 6341, 6345, 6353, 6360, 6368, 6375, 6383, 6390, 6398, 6402, 6406, 6410, 6414, 6418, 6422, 6426, 6430, 6434, 6448, 6465, 6482, 6504, 6525, 6563, 6567, 6571, 6582, 6584, 6586, 6601, 6629, 6651, 6686, 6693, 6700, 6707, 6714, 6735, 6740, 6745, 6762, 6768, 6781, 6795, 6806, 6818, 6833, 6848, 6855, 6861, 6868, 6869, 6874, 6886, 6901, 6911, 6912, 6917, 6925, 6934, 6949, 6952, 6960, 6976, 6986, 6985, 6995, 7005, 7004, 7016, 7019, 7027, 7042, 7043, 7044, 7045, 7046, 7047, 7048, 7049, 7050, 7051, 7052, 7053, 7054, 7055, 7056, 7057, 7058, 7059, 7060, 7061, 7062, 7063, 7064, 7068, 7069, 7073, 7074, 7075, 7076, 7077, 7078, 7079, 7080, 7081, 7082, 7083, 7084, 7085, 7086, 7087, 7088, 7089, 7090, 7091, 7092, 7093, 7094, 7095, 7096, 7097, 7098, 7099, 7100, 7101, 7102, 7103, 7104, 7105, 7106, 7107, 7108, 7109, 7110, 7111, 7112, 7113, 7114, 7115, 7117, 7119, 7121, 7123, 7128, 7129, 7130, 7131, 7132, 7133, 7134, 7135, 7136, 7137, 7151, 7166, 7191, 7193, 7196, 7202, 7205, 7212, 7218, 7221, 7224, 7237, 7243, 7251, 7260, 7269, 7278, 7287, 7296, 7305, 7320, 7335, 7350, 7365, 7373, 7385, 7404, 7422, 7449, 7466, 7506, 7515, 7528, 7537, 7550, 7553, 7560, 7566, 7571, 7574, 7579, 7597, 7602, 7608, 7628, 7648, 7660, 7663, 7682, 7687, 7693, 7703, 7717, 7730 }; #endif #if YYDEBUG || YYERROR_VERBOSE || YYTOKEN_TABLE /* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM. First, the terminals, then, starting at YYNTOKENS, nonterminals. */ static const char *const yytname[] = { "$end", "error", "$undefined", "tINT", "tFLOAT", "tSTRING", "tBIGSTR", "tEND", "tDOTS", "tStrCat", "tSprintf", "tPrintf", "tRead", "tPrintConstants", "tStrCmp", "tNbrRegions", "tFor", "tEndFor", "tIf", "tElse", "tEndIf", "tFlag", "tInclude", "tConstant", "tList", "tListAlt", "tLinSpace", "tLogSpace", "tListFromFile", "tChangeCurrentPosition", "tDefineConstant", "tUndefineConstant", "tPi", "tMPI_Rank", "tMPI_Size", "t0D", "t1D", "t2D", "t3D", "tExp", "tLog", "tLog10", "tSqrt", "tSin", "tAsin", "tCos", "tAcos", "tTan", "tAtan", "tAtan2", "tSinh", "tCosh", "tTanh", "tFabs", "tFloor", "tCeil", "tRound", "tSign", "tFmod", "tModulo", "tHypot", "tRand", "tSolidAngle", "tTrace", "tOrder", "tCrossProduct", "tDofValue", "tMHTransform", "tMHJacNL", "tGroup", "tDefineGroup", "tAll", "tInSupport", "tMovingBand2D", "tDefineFunction", "tConstraint", "tRegion", "tSubRegion", "tRegionRef", "tSubRegionRef", "tFilter", "tCoefficient", "tValue", "tTimeFunction", "tBranch", "tNameOfResolution", "tJacobian", "tCase", "tMetricTensor", "tIntegration", "tMatrix", "tType", "tSubType", "tCriterion", "tGeoElement", "tNumberOfPoints", "tMaxNumberOfPoints", "tNumberOfDivisions", "tMaxNumberOfDivisions", "tStoppingCriterion", "tFunctionSpace", "tName", "tBasisFunction", "tNameOfCoef", "tFunction", "tdFunction", "tSubFunction", "tSubdFunction", "tSupport", "tEntity", "tSubSpace", "tNameOfBasisFunction", "tGlobalQuantity", "tEntityType", "tEntitySubType", "tNameOfConstraint", "tFormulation", "tQuantity", "tNameOfSpace", "tIndexOfSystem", "tSymmetry", "tGalerkin", "tdeRham", "tGlobalTerm", "tGlobalEquation", "tDt", "tDtDof", "tDtDt", "tDtDtDof", "tJacNL", "tDtDofJacNL", "tNeverDt", "tDtNL", "tAtAnteriorTimeStep", "tIn", "tFull_Matrix", "tResolution", "tDefineSystem", "tNameOfFormulation", "tNameOfMesh", "tFrequency", "tSolver", "tOriginSystem", "tDestinationSystem", "tOperation", "tOperationEnd", "tSetTime", "tDTime", "tSetFrequency", "tFourierTransform", "tFourierTransformJ", "tLanczos", "tEigenSolve", "tEigenSolveJac", "tPerturbation", "tUpdate", "tUpdateConstraint", "tBreak", "tEvaluate", "tSelectCorrection", "tAddCorrection", "tMultiplySolution", "tAddOppositeFullSolution", "tSolveAgainWithOther", "tTimeLoopTheta", "tTimeLoopNewmark", "tTimeLoopRungeKutta", "tTimeLoopAdaptive", "tTime0", "tTimeMax", "tTheta", "tBeta", "tGamma", "tIterativeLoop", "tIterativeLoopN", "tIterativeLinearSolver", "tNbrMaxIteration", "tRelaxationFactor", "tIterativeTimeReduction", "tSetCommSelf", "tSetCommWorld", "tBarrier", "tDivisionCoefficient", "tChangeOfState", "tChangeOfCoordinates", "tChangeOfCoordinates2", "tSystemCommand", "tGmshRead", "tGmshClearAll", "tDeleteFile", "tCreateDir", "tGenerateOnly", "tGenerateOnlyJac", "tSolveJac_AdaptRelax", "tTensorProductSolve", "tSaveSolutionExtendedMH", "tSaveSolutionMHtoTime", "tSaveSolutionWithEntityNum", "tInitMovingBand2D", "tMeshMovingBand2D", "tGenerate_MH_Moving", "tGenerate_MH_Moving_Separate", "tAdd_MH_Moving", "tGenerateGroup", "tGenerateJacGroup", "tGenerateRHSGroup", "tSaveMesh", "tDeformeMesh", "tDummyFrequency", "tPostProcessing", "tNameOfSystem", "tPostOperation", "tNameOfPostProcessing", "tUsingPost", "tAppend", "tResampleTime", "tPlot", "tPrint", "tPrintGroup", "tEcho", "tWrite", "tAdapt", "tOnGlobal", "tOnRegion", "tOnElementsOf", "tOnGrid", "tOnSection", "tOnPoint", "tOnLine", "tOnPlane", "tOnBox", "tWithArgument", "tFile", "tDepth", "tDimension", "tComma", "tTimeStep", "tHarmonicToTime", "tValueIndex", "tValueName", "tFormat", "tHeader", "tFooter", "tSkin", "tSmoothing", "tTarget", "tSort", "tIso", "tNoNewLine", "tNoTitle", "tDecomposeInSimplex", "tChangeOfValues", "tTimeLegend", "tFrequencyLegend", "tEigenvalueLegend", "tEvaluationPoints", "tStoreInRegister", "tStoreInField", "tLastTimeStepOnly", "tAppendTimeStepToFileName", "tOverrideTimeStepValue", "tNoMesh", "tSendToServer", "tColor", "tStr", "tDate", "tNewCoordinates", "tDEF", "'?'", "tOR", "tAND", "tAPPROXEQUAL", "tNOTEQUAL", "tEQUAL", "'<'", "'>'", "tGREATERGREATER", "tLESSLESS", "tGREATEROREQUAL", "tLESSOREQUAL", "'+'", "'-'", "'*'", "'/'", "'%'", "tCROSSPRODUCT", "'|'", "'&'", "'!'", "UNARYPREC", "'^'", "'('", "')'", "'['", "']'", "'.'", "'#'", "'$'", "tSHOW", "'{'", "'}'", "','", "'@'", "'~'", "$accept", "Stats", "@1", "ProblemDefinitions", "@2", "ProblemDefinition", "Groups", "Group", "@3", "@4", "ReducedGroupRHS", "@5", "GroupRHS", "FunctionForGroup", "ListOfRegionOrAll", "SuppListOfRegion", "SuppListTypeForGroup", "ListOfRegion", "RecursiveListOfRegion", "IRegion", "ListOfStringsForCharOptions", "DefineGroups", "@6", "Comma", "Functions", "Function", "DefineFunctions", "Expression", "@7", "ListOfExpression", "RecursiveListOfExpression", "WholeQuantityExpression", "@8", "WholeQuantity", "@9", "@10", "@11", "WholeQuantity_Single", "@12", "@13", "@14", "@15", "ArgumentsForFunction", "RecursiveListOfQuantity", "ParametersForFunction", "JacobianMethods", "JacobianMethod", "JacobianMethodTerm", "JacobianCases", "JacobianCase", "JacobianCaseTerm", "IntegrationMethods", "IntegrationMethod", "IntegrationMethodTerm", "IntegrationCases", "IntegrationCase", "IntegrationCaseTerm", "QuadratureCases", "QuadratureCase", "QuadratureCaseTerm", "Constraints", "BracedConstraint", "Constraint", "ConstraintTerm", "ConstraintCases", "ConstraintCase", "ConstraintCaseTerm", "FunctionSpaces", "BracedFunctionSpace", "FunctionSpace", "FunctionSpaceTerm", "BasisFunctions", "BasisFunction", "BasisFunctionTerm", "OptionalParametersForBasisFunction", "SubSpaces", "SubSpace", "SubSpaceTerm", "ListOfBasisFunction", "RecursiveListOfBasisFunction", "ListOfBasisFunctionCoef", "RecursiveListOfBasisFunctionCoef", "GlobalQuantities", "GlobalQuantity", "GlobalQuantityTerm", "ConstraintInFSs", "ConstraintInFS", "ConstraintInFSTerm", "Formulations", "BracedFormulation", "Formulation", "FormulationTerm", "DefineQuantities", "DefineQuantity", "DefineQuantityTerm", "@16", "@17", "IndexInFunctionSpace", "Equations", "EquationTerm", "GlobalEquation", "GlobalEquationTerm", "GlobalEquationTermTerm", "GlobalEquationTermTermTerm", "LocalTerm", "LocalTermTerm", "@18", "@19", "GlobalTerm", "GlobalTermTerm", "@20", "@21", "TermOperator", "Quantity_Def", "Resolutions", "BracedResolution", "Resolution", "ResolutionTerm", "@22", "DefineSystems", "DefineSystem", "DefineSystemTerm", "ListOfFormulation", "RecursiveListOfFormulation", "ListOfSystem", "RecursiveListOfSystem", "Operation", "CommaFExprOrNothing", "OperationTerm", "@23", "@24", "PrintOperation", "PrintOperationOptions", "PrintOperationOption", "TLAoptions", "LTEdefinitions", "TimeLoopAdaptiveSystems", "TimeLoopAdaptivePOs", "IterativeLoopDefinitions", "IterativeLoopSystems", "IterativeLoopPOs", "TimeLoopTheta", "TimeLoopThetaTerm", "TimeLoopNewmark", "TimeLoopNewmarkTerm", "IterativeLoop", "IterativeLoopTerm", "IterativeTimeReduction", "IterativeTimeReductionTerm", "ChangeOfStates", "ChangeOfState", "ChangeOfStateTerm", "PostProcessings", "BracedPostProcessing", "PostProcessing", "PostProcessingTerm", "PostQuantities", "PostQuantity", "PostQuantityTerm", "SubPostQuantities", "SubPostQuantity", "SubPostQuantityTerm", "@25", "PostOperations", "BracedPostOperation", "PostOperation", "PostOperationTerm", "SeparatePostOperation", "@26", "PostSubOperations", "@27", "PostSubOperation", "@28", "PostQuantitiesToPrint", "Combination", "PostQuantitySupport", "PrintSubType", "PrintOptions", "PrintOption", "Loop", "Affectation", "Enumeration", "FloatParameterOptions", "FloatParameterOption", "CharParameterOptions", "CharParameterOption", "DefineConstants", "@29", "@30", "UndefineConstants", "NameForMathFunction", "NameForFunction", "FExpr", "OneFExpr", "ListOfFExpr", "RecursiveListOfFExpr", "RecursiveListOfListOfFExpr", "MultiFExpr", "StringIndex", "String__Index", "RecursiveListOfString__Index", "CharExprNoVar", "CharExpr", "RecursiveListOfCharExpr", "StrCat", "StrCmp", "NbrRegions", 0 }; #endif # ifdef YYPRINT /* YYTOKNUM[YYLEX-NUM] -- Internal token number corresponding to token YYLEX-NUM. */ static const yytype_uint16 yytoknum[] = { 0, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, 308, 309, 310, 311, 312, 313, 314, 315, 316, 317, 318, 319, 320, 321, 322, 323, 324, 325, 326, 327, 328, 329, 330, 331, 332, 333, 334, 335, 336, 337, 338, 339, 340, 341, 342, 343, 344, 345, 346, 347, 348, 349, 350, 351, 352, 353, 354, 355, 356, 357, 358, 359, 360, 361, 362, 363, 364, 365, 366, 367, 368, 369, 370, 371, 372, 373, 374, 375, 376, 377, 378, 379, 380, 381, 382, 383, 384, 385, 386, 387, 388, 389, 390, 391, 392, 393, 394, 395, 396, 397, 398, 399, 400, 401, 402, 403, 404, 405, 406, 407, 408, 409, 410, 411, 412, 413, 414, 415, 416, 417, 418, 419, 420, 421, 422, 423, 424, 425, 426, 427, 428, 429, 430, 431, 432, 433, 434, 435, 436, 437, 438, 439, 440, 441, 442, 443, 444, 445, 446, 447, 448, 449, 450, 451, 452, 453, 454, 455, 456, 457, 458, 459, 460, 461, 462, 463, 464, 465, 466, 467, 468, 469, 470, 471, 472, 473, 474, 475, 476, 477, 478, 479, 480, 481, 482, 483, 484, 485, 486, 487, 488, 489, 490, 491, 492, 493, 494, 495, 496, 497, 498, 499, 500, 501, 502, 503, 504, 505, 506, 507, 508, 509, 510, 511, 512, 513, 514, 515, 516, 517, 518, 519, 520, 521, 522, 63, 523, 524, 525, 526, 527, 60, 62, 528, 529, 530, 531, 43, 45, 42, 47, 37, 532, 124, 38, 33, 533, 94, 40, 41, 91, 93, 46, 35, 36, 534, 123, 125, 44, 64, 126 }; # endif /* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ static const yytype_uint16 yyr1[] = { 0, 304, 306, 305, 307, 308, 307, 309, 309, 309, 309, 309, 309, 309, 309, 309, 309, 309, 309, 309, 310, 310, 311, 311, 312, 313, 311, 311, 311, 315, 314, 314, 316, 316, 317, 317, 318, 318, 319, 319, 319, 320, 321, 321, 322, 322, 322, 323, 323, 323, 323, 323, 323, 323, 324, 324, 324, 324, 324, 325, 325, 326, 325, 325, 327, 327, 328, 328, 329, 329, 329, 329, 330, 330, 330, 331, 331, 332, 331, 331, 333, 333, 334, 334, 336, 335, 337, 338, 339, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 340, 337, 341, 341, 341, 341, 341, 341, 342, 341, 343, 341, 344, 341, 341, 341, 341, 345, 341, 341, 341, 341, 341, 341, 341, 341, 341, 341, 341, 346, 346, 346, 347, 347, 348, 348, 348, 349, 349, 350, 350, 351, 351, 352, 352, 353, 353, 354, 354, 354, 355, 355, 356, 356, 357, 357, 357, 358, 358, 359, 359, 360, 360, 360, 361, 361, 362, 362, 363, 363, 363, 363, 363, 363, 364, 364, 365, 365, 366, 366, 367, 367, 367, 367, 368, 368, 368, 369, 369, 370, 370, 370, 370, 370, 370, 370, 370, 370, 370, 370, 370, 370, 370, 370, 370, 371, 371, 372, 372, 373, 373, 373, 374, 374, 374, 374, 374, 374, 375, 375, 375, 376, 376, 377, 377, 377, 377, 377, 377, 377, 377, 378, 378, 379, 379, 380, 380, 381, 381, 381, 382, 382, 383, 383, 384, 384, 385, 385, 386, 386, 386, 387, 387, 388, 388, 388, 389, 389, 389, 390, 390, 391, 391, 391, 391, 392, 392, 393, 393, 394, 394, 395, 395, 395, 395, 396, 396, 396, 397, 397, 398, 398, 398, 398, 398, 399, 398, 398, 400, 398, 398, 398, 398, 398, 401, 401, 402, 402, 402, 403, 403, 403, 403, 404, 404, 405, 405, 405, 406, 406, 407, 407, 408, 408, 410, 411, 409, 409, 409, 409, 409, 409, 409, 412, 412, 413, 414, 415, 413, 416, 416, 416, 416, 416, 416, 416, 416, 416, 417, 417, 418, 418, 419, 419, 420, 420, 421, 421, 422, 421, 421, 423, 423, 423, 424, 424, 425, 425, 425, 425, 425, 425, 425, 425, 425, 426, 426, 427, 427, 428, 428, 429, 429, 430, 430, 431, 431, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 433, 432, 434, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 432, 435, 435, 436, 436, 437, 437, 437, 438, 438, 438, 438, 439, 439, 439, 440, 440, 441, 441, 442, 442, 442, 443, 443, 444, 444, 445, 445, 446, 446, 446, 446, 446, 447, 447, 448, 448, 448, 448, 448, 448, 449, 449, 450, 450, 450, 450, 450, 451, 451, 452, 452, 452, 452, 452, 452, 452, 452, 453, 453, 454, 454, 455, 455, 455, 455, 455, 455, 456, 456, 457, 457, 458, 458, 459, 459, 459, 459, 460, 460, 460, 461, 461, 462, 462, 463, 463, 463, 463, 464, 464, 466, 465, 465, 465, 465, 465, 467, 467, 468, 468, 469, 469, 470, 470, 470, 470, 470, 470, 472, 471, 473, 474, 473, 475, 475, 475, 475, 475, 476, 475, 475, 477, 477, 478, 478, 478, 478, 479, 479, 480, 480, 480, 480, 480, 480, 480, 480, 480, 480, 480, 481, 481, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 483, 483, 483, 483, 483, 483, 483, 483, 484, 484, 484, 484, 484, 484, 484, 484, 484, 484, 484, 484, 484, 484, 484, 484, 484, 484, 484, 484, 484, 484, 485, 485, 486, 486, 487, 487, 487, 488, 488, 489, 489, 489, 490, 490, 490, 490, 491, 490, 490, 492, 490, 493, 493, 493, 494, 494, 494, 494, 494, 494, 494, 494, 494, 494, 494, 494, 494, 494, 494, 494, 494, 494, 494, 494, 494, 494, 494, 495, 495, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 497, 497, 497, 497, 497, 497, 497, 497, 497, 497, 497, 497, 498, 498, 498, 498, 498, 499, 499, 499, 499, 500, 500, 501, 501, 501, 501, 501, 501, 501, 501, 501, 501, 501, 501, 501, 501, 501, 501, 501, 501, 501, 502, 502, 503, 503, 504, 504, 505, 505, 505, 505, 505, 505, 505, 505, 506, 506, 507, 507, 508, 508, 509, 510 }; /* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */ static const yytype_uint8 yyr2[] = { 0, 2, 0, 2, 0, 0, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 1, 1, 2, 0, 2, 4, 5, 0, 0, 15, 5, 1, 0, 6, 2, 1, 1, 1, 1, 1, 1, 0, 3, 3, 1, 1, 3, 0, 3, 4, 1, 3, 5, 1, 3, 3, 3, 0, 1, 1, 3, 3, 0, 3, 0, 11, 6, 0, 1, 0, 2, 5, 6, 7, 1, 0, 3, 6, 4, 4, 0, 2, 3, 0, 3, 1, 3, 0, 2, 1, 0, 0, 7, 3, 3, 6, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, 2, 0, 10, 3, 1, 3, 2, 1, 2, 0, 5, 0, 7, 0, 11, 9, 4, 4, 0, 7, 6, 2, 2, 2, 2, 3, 2, 3, 1, 1, 3, 2, 3, 1, 3, 0, 3, 6, 0, 4, 0, 2, 3, 4, 0, 4, 0, 2, 3, 3, 4, 0, 4, 0, 2, 3, 3, 4, 0, 4, 0, 2, 3, 3, 4, 0, 4, 0, 2, 3, 3, 3, 3, 3, 3, 0, 2, 3, 1, 0, 2, 3, 3, 4, 5, 0, 4, 2, 0, 2, 3, 3, 3, 3, 3, 7, 3, 7, 3, 3, 3, 3, 3, 7, 7, 7, 0, 2, 3, 1, 0, 2, 2, 3, 3, 4, 4, 4, 4, 0, 4, 2, 0, 2, 3, 3, 4, 7, 3, 3, 3, 3, 0, 20, 0, 4, 0, 2, 3, 3, 3, 1, 3, 0, 3, 1, 3, 0, 3, 0, 4, 2, 0, 2, 3, 3, 3, 0, 4, 2, 0, 2, 3, 3, 3, 3, 0, 2, 3, 1, 0, 2, 3, 3, 4, 4, 0, 4, 2, 0, 2, 3, 3, 3, 3, 3, 0, 5, 3, 0, 5, 3, 3, 3, 3, 0, 3, 0, 2, 2, 4, 4, 4, 4, 0, 2, 3, 3, 3, 0, 2, 3, 3, 0, 2, 0, 0, 9, 3, 3, 3, 2, 5, 3, 0, 2, 3, 0, 0, 9, 0, 1, 1, 1, 1, 1, 1, 1, 1, 4, 3, 0, 2, 3, 1, 0, 2, 3, 4, 0, 5, 1, 0, 4, 2, 0, 2, 3, 3, 3, 3, 3, 3, 3, 3, 1, 1, 3, 0, 3, 1, 3, 0, 3, 0, 2, 0, 2, 3, 3, 4, 4, 4, 4, 6, 5, 2, 2, 2, 2, 7, 11, 7, 7, 7, 5, 7, 9, 5, 9, 9, 11, 11, 11, 6, 7, 5, 7, 7, 5, 17, 13, 15, 17, 25, 11, 11, 13, 24, 0, 7, 0, 7, 7, 11, 6, 5, 5, 7, 2, 5, 5, 9, 5, 8, 9, 9, 5, 5, 11, 9, 14, 14, 7, 12, 10, 7, 8, 8, 8, 8, 17, 1, 1, 1, 0, 2, 3, 3, 2, 0, 2, 4, 6, 0, 5, 5, 0, 10, 0, 10, 0, 5, 5, 0, 11, 0, 10, 0, 2, 3, 3, 3, 3, 4, 0, 2, 3, 3, 3, 3, 3, 4, 0, 2, 3, 3, 3, 3, 4, 0, 2, 3, 3, 3, 3, 3, 4, 4, 4, 0, 4, 0, 2, 3, 3, 3, 3, 3, 3, 0, 2, 3, 1, 0, 2, 3, 3, 3, 4, 0, 4, 2, 0, 2, 3, 4, 0, 5, 5, 2, 0, 2, 0, 6, 3, 3, 3, 3, 0, 2, 3, 1, 0, 2, 3, 3, 3, 3, 9, 4, 0, 8, 0, 0, 3, 7, 7, 8, 11, 6, 0, 10, 1, 3, 6, 1, 1, 1, 1, 0, 3, 1, 2, 2, 12, 2, 15, 4, 12, 17, 22, 12, 0, 2, 3, 4, 4, 3, 2, 2, 3, 3, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 5, 2, 2, 2, 3, 9, 3, 2, 9, 2, 9, 2, 9, 5, 3, 3, 2, 2, 3, 3, 2, 3, 3, 3, 6, 8, 8, 10, 1, 4, 1, 1, 5, 5, 4, 7, 5, 5, 4, 7, 7, 4, 7, 5, 5, 3, 3, 7, 7, 5, 5, 8, 7, 2, 3, 5, 0, 2, 3, 5, 3, 0, 2, 3, 3, 5, 0, 3, 6, 5, 0, 9, 5, 0, 9, 0, 3, 3, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 3, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 6, 4, 4, 4, 4, 4, 4, 4, 4, 6, 6, 6, 4, 5, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 4, 4, 0, 2, 1, 1, 3, 1, 1, 3, 3, 1, 3, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 5, 3, 3, 6, 4, 6, 8, 8, 5, 5, 1, 1, 1, 3, 1, 1, 4, 4, 4, 6, 6, 1, 1, 1, 1, 3, 6, 6, 6, 4 }; /* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state STATE-NUM when YYTABLE doesn't specify something else to do. Zero means the default is an error. */ static const yytype_uint16 yydefact[] = { 2, 0, 4, 1, 5, 0, 817, 0, 0, 0, 0, 651, 0, 653, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 6, 17, 18, 654, 818, 0, 0, 0, 0, 0, 0, 0, 0, 676, 0, 0, 0, 821, 0, 0, 0, 828, 830, 829, 19, 822, 689, 698, 20, 184, 147, 160, 215, 66, 275, 350, 529, 558, 0, 0, 785, 0, 0, 0, 0, 0, 0, 669, 668, 0, 0, 0, 774, 773, 817, 0, 0, 775, 780, 781, 776, 777, 778, 779, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 726, 782, 770, 771, 0, 0, 0, 0, 0, 0, 64, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 817, 0, 0, 0, 0, 0, 0, 0, 0, 0, 787, 0, 788, 0, 785, 785, 790, 0, 791, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 728, 729, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 772, 652, 0, 0, 0, 0, 831, 0, 0, 65, 0, 0, 0, 0, 7, 21, 28, 0, 188, 9, 185, 187, 149, 10, 162, 11, 219, 12, 216, 218, 0, 8, 67, 71, 0, 279, 13, 276, 278, 354, 14, 351, 353, 533, 15, 530, 532, 562, 16, 559, 561, 570, 0, 0, 0, 661, 0, 0, 0, 0, 0, 0, 0, 728, 796, 786, 0, 0, 0, 0, 657, 0, 0, 0, 0, 0, 664, 0, 0, 0, 0, 815, 666, 0, 667, 0, 672, 0, 673, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 727, 0, 0, 0, 745, 744, 743, 742, 738, 739, 741, 740, 731, 730, 732, 735, 736, 733, 734, 737, 0, 0, 824, 0, 825, 0, 823, 0, 655, 690, 656, 700, 699, 59, 785, 0, 0, 0, 0, 0, 72, 0, 0, 0, 0, 0, 0, 816, 808, 0, 809, 0, 0, 0, 0, 0, 0, 0, 789, 806, 732, 797, 735, 799, 0, 802, 803, 798, 804, 800, 805, 801, 659, 660, 785, 792, 793, 0, 0, 0, 0, 0, 784, 0, 836, 746, 747, 748, 749, 750, 751, 752, 753, 754, 755, 0, 757, 758, 759, 760, 761, 762, 763, 764, 0, 0, 0, 768, 783, 0, 647, 0, 0, 0, 0, 0, 832, 0, 0, 64, 817, 0, 34, 0, 0, 0, 785, 0, 0, 0, 186, 189, 0, 0, 148, 150, 0, 77, 0, 161, 163, 0, 0, 0, 0, 0, 0, 217, 220, 221, 64, 817, 0, 0, 32, 0, 33, 0, 0, 0, 0, 277, 280, 0, 0, 358, 352, 355, 360, 0, 0, 0, 0, 531, 534, 0, 0, 0, 0, 0, 0, 560, 563, 572, 0, 811, 0, 0, 0, 0, 0, 0, 0, 0, 670, 671, 0, 675, 0, 0, 0, 0, 0, 0, 0, 769, 834, 833, 826, 827, 695, 0, 692, 0, 0, 0, 0, 47, 817, 0, 44, 0, 31, 42, 50, 22, 0, 0, 0, 194, 0, 0, 153, 0, 167, 0, 0, 0, 0, 84, 0, 266, 0, 0, 228, 243, 258, 0, 0, 77, 0, 306, 0, 0, 285, 0, 361, 0, 0, 539, 0, 0, 0, 572, 0, 0, 0, 0, 573, 0, 0, 0, 0, 665, 663, 662, 807, 658, 674, 0, 649, 835, 756, 765, 766, 767, 648, 696, 693, 691, 27, 60, 24, 0, 0, 0, 64, 0, 37, 29, 36, 23, 194, 0, 191, 190, 0, 151, 0, 0, 0, 0, 165, 78, 0, 164, 0, 223, 222, 0, 0, 0, 68, 73, 0, 77, 0, 282, 281, 0, 356, 0, 383, 535, 0, 536, 537, 564, 573, 565, 567, 0, 566, 571, 0, 810, 812, 0, 0, 0, 684, 679, 0, 0, 0, 48, 51, 52, 43, 0, 53, 64, 0, 197, 192, 196, 155, 152, 169, 166, 0, 0, 79, 817, 701, 702, 703, 704, 705, 706, 707, 708, 709, 710, 711, 712, 713, 714, 715, 716, 717, 718, 719, 720, 721, 722, 723, 0, 127, 0, 0, 0, 0, 118, 120, 0, 0, 0, 0, 0, 0, 0, 0, 85, 86, 116, 724, 0, 113, 782, 137, 138, 269, 227, 268, 231, 224, 230, 245, 225, 261, 226, 260, 0, 69, 0, 0, 0, 0, 0, 284, 307, 308, 288, 283, 287, 364, 357, 363, 0, 542, 538, 541, 569, 0, 0, 0, 0, 0, 574, 582, 0, 0, 650, 0, 0, 61, 0, 0, 0, 0, 45, 0, 0, 193, 0, 0, 0, 75, 76, 115, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 108, 107, 109, 0, 135, 133, 130, 132, 131, 817, 0, 87, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 117, 144, 0, 0, 0, 0, 0, 70, 322, 322, 333, 313, 0, 0, 817, 0, 77, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 428, 430, 359, 384, 461, 0, 0, 0, 0, 0, 0, 813, 814, 697, 0, 685, 694, 0, 680, 0, 63, 25, 49, 46, 30, 41, 0, 0, 0, 0, 0, 0, 77, 77, 77, 77, 0, 0, 0, 77, 195, 198, 0, 0, 154, 156, 0, 0, 0, 168, 170, 0, 84, 0, 0, 0, 0, 84, 84, 0, 0, 112, 0, 349, 0, 106, 105, 104, 103, 102, 98, 99, 101, 100, 94, 95, 90, 93, 96, 91, 97, 134, 136, 140, 0, 142, 0, 0, 114, 0, 0, 0, 0, 267, 270, 0, 0, 0, 0, 80, 80, 0, 0, 229, 232, 0, 0, 0, 244, 246, 0, 0, 0, 259, 262, 74, 339, 339, 339, 0, 0, 0, 0, 0, 0, 0, 0, 0, 785, 298, 286, 289, 0, 0, 0, 0, 785, 0, 0, 0, 362, 365, 374, 0, 0, 77, 77, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 398, 77, 0, 0, 0, 0, 0, 0, 487, 0, 494, 0, 0, 0, 502, 0, 0, 509, 395, 396, 397, 0, 0, 0, 438, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 540, 543, 0, 0, 589, 0, 0, 580, 602, 0, 785, 54, 0, 40, 39, 0, 0, 0, 0, 77, 0, 77, 0, 77, 0, 0, 0, 0, 0, 77, 0, 0, 0, 144, 174, 0, 0, 125, 0, 126, 0, 122, 0, 0, 0, 84, 0, 348, 0, 139, 141, 0, 0, 0, 0, 35, 0, 0, 0, 0, 0, 241, 0, 77, 0, 0, 0, 0, 0, 254, 256, 0, 250, 252, 0, 0, 0, 0, 0, 77, 0, 0, 340, 341, 342, 343, 344, 345, 346, 347, 0, 0, 309, 323, 0, 310, 0, 311, 334, 0, 0, 0, 318, 312, 314, 0, 0, 0, 0, 0, 0, 295, 0, 0, 0, 0, 84, 0, 0, 377, 0, 375, 0, 0, 0, 381, 0, 379, 0, 385, 387, 0, 0, 388, 0, 0, 0, 0, 0, 0, 0, 0, 0, 385, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 385, 80, 80, 546, 0, 0, 591, 0, 0, 0, 0, 0, 0, 0, 0, 602, 0, 0, 77, 602, 0, 0, 0, 686, 687, 0, 681, 683, 56, 55, 0, 0, 200, 201, 207, 208, 0, 211, 0, 210, 0, 203, 202, 64, 205, 199, 0, 209, 158, 157, 0, 0, 171, 172, 0, 0, 84, 0, 119, 0, 0, 0, 88, 143, 0, 145, 271, 272, 273, 274, 233, 234, 0, 0, 64, 82, 0, 237, 238, 239, 240, 247, 64, 249, 64, 248, 264, 263, 265, 0, 0, 0, 0, 0, 330, 324, 0, 336, 0, 0, 0, 302, 301, 293, 291, 292, 290, 304, 297, 303, 300, 294, 0, 367, 366, 64, 368, 369, 372, 373, 64, 370, 371, 0, 0, 0, 0, 77, 0, 0, 0, 0, 0, 0, 0, 77, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 77, 0, 0, 77, 389, 488, 0, 0, 77, 0, 0, 0, 0, 390, 495, 0, 0, 0, 0, 0, 0, 0, 77, 391, 503, 77, 0, 0, 0, 0, 0, 0, 0, 0, 0, 392, 510, 77, 0, 0, 0, 0, 0, 785, 785, 785, 819, 0, 0, 785, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 462, 464, 463, 464, 0, 544, 0, 592, 593, 77, 595, 0, 0, 0, 0, 0, 0, 0, 587, 588, 585, 586, 583, 0, 0, 602, 0, 0, 0, 0, 603, 0, 0, 790, 684, 0, 0, 77, 77, 77, 0, 77, 159, 176, 173, 0, 92, 0, 0, 0, 129, 110, 0, 0, 0, 235, 0, 81, 77, 255, 0, 251, 0, 328, 332, 329, 0, 327, 84, 335, 84, 315, 316, 0, 0, 317, 319, 0, 0, 0, 376, 0, 380, 0, 386, 0, 383, 394, 0, 0, 0, 0, 0, 0, 0, 404, 0, 407, 0, 0, 0, 415, 0, 0, 418, 385, 0, 383, 0, 0, 0, 0, 0, 383, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 383, 0, 0, 0, 0, 0, 0, 0, 383, 383, 0, 0, 519, 0, 435, 436, 0, 439, 440, 0, 0, 0, 0, 0, 0, 0, 442, 385, 446, 447, 0, 0, 0, 385, 385, 385, 0, 0, 0, 0, 0, 817, 0, 545, 549, 568, 0, 0, 0, 0, 0, 0, 0, 0, 590, 589, 0, 0, 0, 0, 579, 785, 0, 785, 0, 0, 0, 0, 0, 612, 785, 0, 0, 0, 0, 608, 609, 0, 0, 0, 624, 625, 626, 80, 630, 632, 634, 0, 0, 0, 639, 640, 0, 643, 0, 0, 0, 688, 682, 0, 0, 0, 58, 57, 0, 0, 0, 0, 0, 0, 0, 128, 0, 0, 121, 0, 89, 0, 0, 0, 83, 257, 253, 0, 325, 337, 0, 0, 0, 296, 299, 378, 382, 393, 0, 0, 785, 0, 785, 0, 0, 0, 0, 0, 413, 0, 0, 0, 0, 77, 0, 491, 489, 490, 492, 77, 0, 498, 496, 497, 499, 500, 0, 0, 77, 507, 505, 0, 504, 506, 480, 0, 514, 513, 515, 0, 0, 511, 512, 0, 0, 0, 0, 0, 0, 0, 0, 820, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 434, 0, 785, 465, 0, 550, 550, 0, 77, 0, 597, 0, 0, 0, 575, 0, 0, 0, 576, 602, 621, 615, 627, 77, 618, 0, 0, 604, 607, 616, 617, 610, 613, 614, 611, 620, 619, 0, 622, 629, 0, 0, 0, 0, 637, 638, 641, 642, 644, 645, 646, 0, 677, 62, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 175, 177, 0, 0, 0, 146, 0, 0, 331, 0, 0, 320, 321, 305, 399, 401, 0, 0, 0, 0, 0, 0, 405, 0, 414, 416, 417, 0, 0, 493, 0, 501, 0, 0, 0, 508, 0, 0, 517, 518, 521, 516, 432, 0, 437, 402, 403, 0, 0, 0, 0, 0, 0, 0, 452, 0, 0, 0, 0, 455, 0, 429, 0, 785, 468, 431, 339, 339, 0, 0, 0, 0, 0, 0, 584, 602, 577, 0, 0, 605, 606, 0, 0, 0, 0, 0, 0, 0, 214, 213, 204, 206, 212, 0, 0, 0, 0, 0, 0, 0, 124, 0, 0, 236, 84, 0, 0, 0, 0, 0, 0, 0, 0, 0, 459, 77, 0, 77, 0, 0, 0, 0, 0, 0, 0, 0, 77, 0, 0, 0, 0, 443, 0, 0, 456, 457, 458, 0, 77, 0, 466, 467, 0, 0, 0, 0, 548, 0, 551, 547, 0, 77, 0, 0, 0, 0, 0, 0, 77, 623, 0, 0, 0, 636, 678, 26, 178, 179, 180, 181, 182, 183, 0, 111, 0, 0, 0, 383, 408, 409, 0, 0, 0, 0, 406, 0, 0, 0, 0, 383, 0, 483, 485, 383, 0, 0, 0, 0, 77, 0, 0, 520, 522, 0, 441, 0, 444, 445, 0, 0, 449, 0, 0, 0, 0, 0, 0, 0, 552, 0, 0, 0, 0, 0, 0, 0, 581, 0, 0, 0, 0, 123, 0, 0, 0, 0, 0, 0, 0, 785, 0, 0, 785, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 785, 0, 0, 0, 454, 0, 556, 557, 554, 555, 84, 0, 0, 0, 0, 0, 0, 578, 77, 0, 0, 0, 0, 326, 338, 400, 410, 411, 412, 0, 383, 0, 0, 0, 425, 383, 0, 481, 0, 482, 424, 0, 528, 523, 526, 527, 524, 525, 433, 0, 383, 383, 448, 0, 0, 0, 785, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 785, 0, 0, 0, 0, 785, 0, 0, 0, 453, 0, 0, 0, 0, 0, 0, 0, 628, 631, 633, 635, 0, 0, 420, 383, 0, 0, 426, 0, 0, 0, 785, 0, 0, 553, 0, 785, 0, 0, 0, 0, 0, 0, 0, 785, 785, 0, 0, 785, 794, 0, 450, 451, 601, 0, 594, 598, 0, 0, 0, 0, 421, 0, 0, 0, 0, 0, 0, 785, 785, 0, 0, 0, 0, 0, 473, 0, 0, 785, 0, 795, 0, 0, 0, 0, 419, 422, 469, 0, 0, 0, 460, 596, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 476, 478, 470, 0, 0, 486, 383, 599, 0, 0, 0, 0, 0, 383, 484, 0, 0, 0, 0, 474, 0, 475, 471, 0, 0, 0, 0, 0, 0, 0, 0, 383, 0, 242, 0, 0, 472, 383, 0, 0, 0, 0, 0, 427, 600, 0, 0, 423, 0, 0, 0, 0, 0, 0, 477, 479 }; /* YYDEFGOTO[NTERM-NUM]. */ static const yytype_int16 yydefgoto[] = { -1, 1, 2, 4, 5, 27, 131, 234, 690, 1144, 490, 697, 491, 461, 635, 808, 953, 558, 632, 559, 1344, 455, 945, 229, 136, 251, 486, 574, 575, 1524, 1390, 649, 650, 749, 990, 1576, 1763, 750, 823, 824, 1370, 818, 858, 1012, 1014, 133, 373, 471, 642, 812, 971, 134, 374, 476, 644, 813, 976, 1365, 1758, 1915, 132, 239, 372, 467, 639, 811, 967, 135, 247, 375, 484, 655, 861, 1030, 1387, 656, 862, 1035, 1206, 1398, 1203, 1396, 657, 863, 1040, 652, 860, 1020, 137, 256, 378, 498, 665, 870, 1057, 1421, 1248, 1602, 662, 777, 1045, 1236, 1414, 1600, 1042, 1225, 1592, 1923, 1044, 1230, 1594, 1924, 1226, 751, 138, 260, 379, 503, 593, 667, 871, 1067, 1252, 1429, 1258, 1434, 785, 1438, 929, 1128, 1129, 1525, 1687, 1851, 2339, 2327, 2356, 2357, 1950, 2160, 2161, 1282, 1466, 1284, 1475, 1288, 1485, 1291, 1497, 1827, 2039, 2116, 139, 264, 380, 510, 670, 931, 1133, 1528, 1980, 2062, 2181, 140, 268, 381, 518, 28, 382, 604, 680, 795, 1334, 1135, 1547, 1331, 1329, 1335, 1554, 930, 30, 1556, 801, 944, 800, 941, 129, 687, 686, 130, 752, 753, 153, 119, 154, 285, 2290, 155, 31, 120, 1508, 50, 225, 226, 52, 121, 122 }; /* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing STATE-NUM. */ #define YYPACT_NINF -1581 static const yytype_int16 yypact[] = { -1581, 81, -1581, -1581, 86, 3123, -189, 80, -176, 188, 30, -1581, -137, -1581, 234, -78, -62, -33, -30, -18, 57, 69, 78, 174, 184, 198, 32, -1581, -1581, -1581, -1581, -9, 191, 202, 313, 336, 436, 458, 482, 482, -1581, 376, 6094, 6094, -1581, -138, -99, 227, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 316, 250, 3848, 287, 334, 5524, 6094, -191, -103, -1581, -1581, 279, -49, 297, -1581, -1581, -247, 322, 347, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 353, 356, 361, 389, 399, 416, 437, 451, 456, 466, 472, 480, 489, 497, 503, 505, 513, 516, 558, 562, 566, 575, 585, 6094, 6094, 6094, 672, 5620, -1581, -1581, -1581, -1581, 8937, 234, 234, 234, 234, 234, 119, 144, 740, 845, -129, 157, 872, 895, 1135, 1157, 1191, 1234, 482, 6094, -8, 727, 606, 608, 617, 644, 650, -42, 5524, 2547, 5905, 739, 652, 912, 4211, 4211, 5905, -164, 652, 8356, 938, 5524, 955, 5524, 46, 958, 6094, 6094, 6094, 234, 482, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, -25, -25, 8962, 698, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, 6094, -1581, -1581, 705, 708, -132, 175, -1581, 265, 1005, -1581, 482, 1008, 234, 728, -1581, -1581, -1581, 421, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 731, -1581, -1581, -1581, 344, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 8385, 4270, 504, -1581, 1026, 1042, 6094, 6094, 234, 234, 234, -25, 763, -1581, 244, 6094, 5524, 5524, -1581, 5524, 5524, 5524, 5524, 6094, -1581, 1056, 1095, 841, 5524, -1581, -1581, -76, -1581, 276, -1581, 6094, -1581, 8414, 6149, 8987, 820, 860, 9012, 9041, 9070, 9099, 9128, 9157, 9186, 9215, 9244, 9273, 3703, 9302, 9331, 9360, 9389, 9418, 9447, 9476, 9505, 4985, 6429, 6475, 9534, -1581, 837, 5050, 6190, 2476, 2702, 3172, 3172, 692, 692, 692, 692, 997, 997, 446, 446, 446, -25, -25, -25, 234, 234, -1581, 5524, -1581, 5524, -1581, 234, -1581, -193, -1581, -1581, -1581, -1581, 3670, 891, 87, 95, 303, 450, -1581, 66, 147, 49, 378, 441, 877, -1581, -1581, 5524, -1581, 885, 879, 6685, 6719, 887, 890, 889, -1581, 6400, 446, 763, 446, 763, 5905, 20, 20, 1311, 763, 1311, 763, 2038, -1581, -1581, 4211, 5905, 652, 1177, 1179, 9563, 1182, 6094, -1581, 234, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 6094, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 6094, 6094, 6094, -1581, -1581, 6094, -1581, 6094, 899, 900, -65, 288, -1581, 4384, 6094, 296, 392, 904, -1581, 33, 1186, 905, 3368, 37, 1194, 482, -1581, -1581, 901, 482, -1581, -1581, 902, 116, 1201, -1581, -1581, 911, 1207, 482, 914, 915, 916, -1581, -1581, -1581, 329, -211, 949, 42, -1581, 926, -1581, 937, 1235, 482, 942, -1581, -1581, 482, 943, -1581, -1581, -1581, -1581, 482, 954, 482, 482, -1581, -1581, 482, 956, 482, 234, 963, 1253, -1581, -1581, -1581, 331, -1581, 1257, 6094, 6094, 1259, 1260, 1261, 6094, 1262, -1581, -1581, 1263, -1581, 1738, 978, 9592, 9621, 9650, 9679, 9708, 10342, -1581, -1581, -1581, -1581, -1581, 2817, 10342, 8443, 1267, 482, 43, 1274, -195, 5524, -1581, 5524, -1581, -1581, -1581, -1581, 38, 1268, 986, -1581, 1281, 1282, -1581, 1283, -1581, 998, 999, 1012, 1301, -1581, 1305, -1581, 1307, 1308, -1581, -1581, -1581, 1317, 1321, 116, 1060, -1581, 1322, 1326, -1581, 1328, -1581, 1029, 1332, -1581, 1337, 1339, 1340, -1581, 1342, 1343, 6094, 1344, 1032, 1061, 1065, 6760, 6966, -1581, -1581, -1581, 10342, -1581, -1581, 6094, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 10342, -1581, -1581, -192, -1581, 1351, 5335, 589, 358, 512, -1581, -1581, -1581, -1581, -1581, 1325, -1581, -1581, 368, -1581, 387, 6094, 1356, 1080, -1581, -1581, 3568, -1581, 1457, -1581, -1581, 1530, 477, 1557, -1581, 1066, 1357, 116, 582, -1581, -1581, 1673, -1581, 1784, -1581, -1581, 1880, -1581, -1581, -1581, 1067, -1581, -1581, 6996, -1581, -1581, 1213, -1581, -1581, 6094, 6094, 8472, -1581, -1581, 1069, 6094, 1068, 1358, -1581, -1581, -1581, 15, -1581, 335, 1922, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 9733, 1077, -1581, 262, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 1081, -1581, 1085, 1086, 1110, 1111, -1581, -1581, 26, 3568, 3568, 3568, 3568, 397, 295, 1400, 5555, 412, 1113, -1581, 1113, -1581, 1132, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 6094, -1581, 1419, 1128, 1129, 1134, 1137, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 4441, -1581, -1581, -1581, -1581, 6094, 1146, 1147, 1148, 1150, -1581, -1581, 9762, 9791, -1581, 524, 526, -1581, 8501, 42, 1441, 43, -1581, 1151, 53, -1581, 1994, -54, 448, -1581, -1581, -1581, 1149, 1154, 1149, 3568, 1444, 1446, 1159, 1161, 1180, 1165, 1169, 1169, 1169, 3075, -1581, -1581, -1581, -1581, -1581, 35, 1160, -1581, 3568, 3568, 3568, 3568, 3568, 3568, 3568, 3568, 3568, 3568, 3568, 3568, 3568, 3568, 3568, 3568, 1458, 6094, 3017, -1581, 1164, 338, 680, 304, 435, 8530, -1581, -1581, -1581, -1581, -1581, 1520, 146, 12, 237, 93, 1172, 1173, 1183, 1187, 1188, 1193, 1196, 1202, 1209, 1465, 1210, 1211, 1215, 1216, 1229, 1239, 55, 275, 1245, 1247, 321, 1251, 1252, 1240, 1472, 1499, 1542, 1258, 1265, 1266, 1545, 1270, 1271, 1273, 1279, 1285, 1289, 1299, 1306, 1310, 1312, 1315, 1319, 1320, 1324, 1327, 1329, 1333, 1335, 1341, 1348, -1581, -1581, -1581, -1581, -1581, -23, 7021, 482, 848, 89, 1547, -1581, -1581, -1581, 1459, -1581, -1581, 1549, -1581, 1256, -1581, -1581, -1581, -1581, -1581, -1581, 482, 42, 89, 89, 89, 89, 166, 274, 340, 116, 1277, 482, 1589, 346, -1581, -1581, 85, 482, -1581, -1581, 1316, 1599, 1605, -1581, -1581, 1349, -1581, 1350, 2116, 1352, 1355, -1581, -1581, 1359, 3568, -1581, 1314, -1581, 3568, 2285, 1246, 538, 538, 538, 745, 745, 745, 745, 479, 479, 1169, 1169, 1169, 1169, 1169, -1581, 587, -1581, 1361, 5555, 350, 4954, -1581, 482, 24, 1613, 482, -1581, -1581, 482, 482, 1614, 1334, 1336, 1336, 89, 89, -1581, -1581, 1631, 44, 58, -1581, -1581, 1637, 482, 482, -1581, -1581, -1581, 1171, 2081, 1641, 264, 482, 1645, 384, 482, 482, 6094, 1653, 89, 4211, -1581, -1581, -1581, 1652, 482, 65, 234, 4211, 234, 67, 482, -1581, -1581, -1581, 482, 1651, 116, 116, 1654, 482, 482, 482, 482, 482, 482, 482, 482, 482, -1581, 116, 482, 482, 482, 482, 482, 6094, -1581, 6094, -1581, 482, 6094, 6094, -1581, 6094, 234, -1581, -1581, -1581, -1581, 89, 234, 234, -1581, 234, 234, 482, 482, 482, 1363, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 482, 1658, 482, 1371, 1372, 1368, 482, -1581, -1581, 6094, 1636, 1375, 1373, 1636, -1581, -1581, 4116, 3730, 581, 1376, -1581, -1581, 1665, 1666, 1669, 1672, 116, 1674, 116, 1675, 116, 1676, 1680, 225, 1681, 1685, 116, 1687, 1688, 1689, 1164, -1581, 1690, 1691, -1581, 1379, -1581, 3568, -1581, 1401, 1407, 1405, -1581, 4195, -1581, 1915, -1581, -1581, 3568, 1414, 586, 1701, -1581, 1703, 1704, 1705, 1706, 1707, 1416, 1713, 116, 1715, 1716, 1717, 1718, 1719, -1581, -1581, 1724, -1581, -1581, 1725, 1726, 1728, 1729, 482, 116, 1735, 1448, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 89, 1737, -1581, -1581, 1449, -1581, 89, -1581, -1581, 1452, 1742, 1743, -1581, -1581, -1581, 1744, 1745, 1747, 1748, 1751, 1752, -1581, 2207, 1753, 1755, 1757, -1581, 1758, 1767, -1581, 1769, -1581, 1771, 1772, 1773, -1581, 1774, -1581, 1775, 1482, -1581, 1455, 1456, -1581, 1484, 1486, 1487, 1489, 1490, 1493, 1497, 369, 379, 1482, 1502, 453, 1504, 1512, 1506, 7051, 411, 7131, 661, 1508, 7156, 7181, 91, 7206, 1510, 97, 1511, 1523, 473, 1529, 1531, 1525, 1526, 1527, 482, 1533, 1534, 474, 1543, 1544, 1535, 1540, 1541, 1546, 1548, 1551, 1552, 1553, 1482, 68, 68, -1581, 1817, 9820, -1581, 89, 89, 8, 1556, 1568, 1571, 1576, 1579, -1581, 89, 232, 255, -1581, 1578, 506, 234, 10342, -1581, 2547, -1581, -1581, -1581, -1581, 622, 42, -1581, -1581, -1581, -1581, 1580, -1581, 1581, -1581, 1583, -1581, -1581, 1585, -1581, -1581, 1586, -1581, -1581, -1581, 1837, 655, -1581, -1581, 89, 4417, -1581, 6094, -1581, 1843, 1554, 1619, -1581, 5555, 89, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 1763, 1881, 1585, -1581, 656, -1581, -1581, -1581, -1581, -1581, 667, -1581, 683, -1581, -1581, -1581, -1581, 1892, 1894, 1895, 1900, 1897, -1581, -1581, 1898, -1581, 1901, 1902, 47, -1581, -1581, -1581, -1581, -1581, -1581, 1621, -1581, -1581, -1581, -1581, 1622, -1581, -1581, 686, -1581, -1581, -1581, -1581, 719, -1581, -1581, 6094, 1623, 1608, 1908, 116, 482, 482, 6094, 6094, 6094, 482, 1911, 116, 1912, 89, 1626, 6094, 1914, 6094, 6094, 1917, 482, 6094, 1627, 116, 6094, 6094, 116, -1581, -1581, 6094, 1629, 116, 6094, 6094, 6094, 6094, -1581, -1581, 6094, 6094, 6094, 6094, 6094, 1638, 6094, 116, -1581, -1581, 116, 234, 6094, 6094, 482, 1644, 1646, 6094, 6094, 1647, -1581, -1581, 116, 1918, 1937, 6094, 1940, 1941, 4211, 4211, 4211, -1581, 736, 6094, 4211, 1943, 89, 1947, 1948, 482, 482, 6094, 482, 482, 89, 89, 1951, 1628, -1581, -1581, -1581, -1581, 1974, -1581, 1952, 1727, -1581, 116, -1581, 1661, 5524, 1662, 1663, 1664, 603, 1670, -1581, -1581, -1581, -1581, -1581, 1962, 1677, -1581, 604, 1834, 1969, 7132, -1581, 738, 742, 5579, -1581, 693, 1679, 116, 116, 116, 225, 116, -1581, -1581, -1581, 1683, -1581, 1684, 7231, 1694, -1581, -1581, 3568, 1695, 1976, -1581, 1977, -1581, 116, -1581, 1978, -1581, 1979, -1581, -1581, -1581, 1699, -1581, -1581, -1581, -1581, -1581, -1581, 1149, 89, -1581, -1581, 482, 2002, 2007, -1581, 482, -1581, 482, 10342, 2016, -1581, -1581, 1732, 1700, 1730, 7256, 7281, 7306, 1731, -1581, 1733, -1581, 1734, 2022, 9849, -1581, 9878, 9907, -1581, 1482, 7331, -1581, 2023, 2239, 2341, 2026, 7356, -1581, 2029, 2457, 2517, 2611, 2682, 7381, 7406, 7431, 2889, 2921, -1581, 3211, 2030, 1739, 1740, 3250, 3528, 2032, -1581, -1581, 3643, 3792, -1581, 615, -1581, -1581, 9936, -1581, -1581, 1750, 1754, 1746, 1749, 482, 7456, 1756, -1581, 1482, -1581, -1581, 1759, 1760, 9965, 1482, 1482, 1482, 1762, 620, 2039, 626, 637, 113, 1765, -1581, -1581, -1581, 2040, 1764, 5524, 749, 5524, 5524, 5524, 2042, -1581, 1375, 234, 645, 2045, 89, -1581, 4211, 234, 4211, 1768, 2048, 213, 6094, 6094, -1581, 4211, 6094, 6094, 234, 2051, -1581, -1581, 6094, 2053, 4479, -1581, -1581, -1581, 1336, 1781, 1782, 1783, 1787, 2056, 6094, -1581, 6094, 6094, -1581, 234, 234, 234, -1581, -1581, 6094, 234, 751, -1581, -1581, 6094, 1797, 1798, 1799, 1766, 1800, 511, -1581, 1802, 6094, -1581, 1804, 5555, 1801, 2061, 1806, -1581, -1581, -1581, 2092, -1581, -1581, 2093, 2095, 1810, -1581, -1581, -1581, -1581, -1581, 4651, 2100, 4211, 6094, 4211, 6094, 6094, 482, 2101, 482, -1581, 2103, 2104, 2105, 1819, 116, 4726, -1581, -1581, -1581, -1581, 116, 4936, -1581, -1581, -1581, -1581, -1581, 6094, 6094, 116, -1581, -1581, 5011, -1581, -1581, -1581, 6094, -1581, -1581, -1581, 5221, 5296, -1581, -1581, 762, 2107, 6094, 2108, 2109, 2110, 6094, 1820, -1581, 234, 234, 1824, 6094, 6094, 2113, 1827, 1829, 1831, 234, 2120, 1989, -1581, 2123, 3998, -1581, 2124, -1581, -1581, 1835, 116, 765, -1581, 767, 778, 785, -1581, 1832, 1841, 2129, -1581, -1581, -1581, -1581, -1581, 116, -1581, 234, 234, -1581, 10342, 10342, -1581, 10342, 10342, -1581, -1581, 10342, -1581, 5524, 10342, -1581, 6094, 6094, 6094, 5524, -1581, 10342, 10342, 10342, -1581, -1581, -1581, 8912, -1581, -1581, 9994, 2130, 2131, 2132, 2133, 2136, 2140, 6094, 6094, 6094, 6094, 6094, -1581, -1581, 1842, 8559, 3568, -1581, 2031, 2139, -1581, 1847, 1848, -1581, -1581, -1581, 2135, -1581, 1856, 10023, 1850, 7481, 7506, 1851, -1581, 1861, -1581, -1581, -1581, 2149, 1857, -1581, 1859, -1581, 7531, 7556, 659, -1581, -73, 7581, -1581, -1581, -1581, -1581, -1581, 7606, -1581, -1581, -1581, 10052, 482, 1869, 1870, 2158, 7631, 7656, -1581, 2161, 2165, 2166, 665, -1581, 234, -1581, 234, 4211, -1581, -1581, 2134, 2159, 6094, 1873, 1876, 1877, 1878, 1879, -1581, -1581, -1581, 676, 1890, -1581, -1581, 787, 7681, 7706, 7731, 790, 234, 2174, -1581, -1581, -1581, -1581, -1581, 2185, 3821, 3912, 4070, 4440, 4765, 6094, -1581, 10371, 2196, -1581, -1581, 1149, 1904, 2210, 2211, 6094, 6094, 6094, 6094, 2217, -1581, 116, 6094, 116, 6094, 1927, 6094, 1928, 1929, 1931, 6094, 400, 116, 2224, 792, 2225, 2227, -1581, 6094, 6094, -1581, -1581, -1581, 2228, 116, 713, -1581, -1581, 482, 2233, 2234, 89, -1581, 1954, -1581, -1581, 7756, 116, 5524, 5524, 5524, 5524, 717, 2237, 116, -1581, 6094, 6094, 6094, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 8588, -1581, 1942, 1946, 1959, -1581, -1581, -1581, 10081, 10110, 10139, 7781, -1581, 1960, 7806, 1955, 7831, -1581, 10168, -1581, -1581, -1581, 7856, 2250, 2253, 6094, 116, 2262, 89, -1581, -1581, 1975, -1581, 1970, -1581, -1581, 10197, 10226, -1581, 1981, 2263, 6094, 2265, 2266, 2270, 2272, -1581, 6094, 1980, 795, 797, 824, 827, 2274, -1581, 1982, 7881, 7906, 7931, -1581, 6094, 2275, 2288, 5506, 2290, 2292, 2293, 4211, 1993, 6094, 4211, 6094, 5581, 2006, 832, 834, 5791, 6094, 2302, 2307, 5010, 2308, 2313, 2316, 2319, 4211, 2028, 2033, 2322, -1581, 10255, -1581, -1581, -1581, -1581, -1581, 8617, 2034, 2036, 2037, 2043, 2044, -1581, 116, 6094, 6094, 6094, 8646, -1581, -1581, -1581, -1581, -1581, -1581, 2049, -1581, 10284, 2050, 7956, -1581, -1581, 482, -1581, 482, -1581, -1581, 7981, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 2052, -1581, -1581, -1581, 2323, 2047, 2046, 4211, 5524, 2055, 5524, 5524, 2057, 8675, 8704, 8733, 2324, 6094, 5866, 2059, 4211, 234, 6076, 2054, 2062, 4211, 2063, 6151, 6361, -1581, 2331, 6094, 2064, 835, 6094, 838, 842, -1581, -1581, -1581, -1581, 2277, 8006, -1581, -1581, 2065, 2066, -1581, 6094, 6094, 2067, 4211, 2332, 2337, -1581, 8762, 4211, 2060, 8791, 2069, 2072, 89, 6094, 6436, 4211, 4211, 8031, 8056, 4211, -1581, 849, -1581, -1581, -1581, 2071, -1581, -1581, 2074, 5524, 2342, 10313, -1581, 2058, 2073, 6094, 6094, 2075, 2083, 4211, 4211, 6094, 856, 2242, 2368, 2373, -1581, 8081, 8106, 4211, 2375, -1581, 2102, 8131, 2111, 2388, -1581, -1581, -118, 2398, 2399, 2114, -1581, -1581, 6094, 2115, 2117, 2119, 2122, 6094, 2121, 2402, 2125, 2127, 8820, 6094, 6094, -1581, -1581, 8156, 2128, 2137, -1581, -1581, -1581, 8181, 8849, 861, 864, 6094, -1581, -1581, 6646, 6094, 2406, 482, -1581, 482, -1581, 8206, 6721, 2143, 8231, 2138, 2118, 2142, 6094, 2145, -1581, 6094, -1581, 6094, 6094, 10342, -1581, 6931, 8878, 8256, 8281, 7006, -1581, -1581, 6094, 6094, -1581, 8306, 8331, 2404, 2417, 2146, 2147, -1581, -1581 }; /* YYPGOTO[NTERM-NUM]. */ static const yytype_int16 yypgoto[] = { -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -283, -1581, -929, 1408, -1581, -1581, 1406, -554, -1581, -423, -1581, -1581, -1581, -125, -1581, -1581, -1581, 971, -1581, -1002, -1581, -895, -1581, 151, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 1678, -1581, 1264, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 1790, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 1563, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1040, -706, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1580, -1264, -1581, -1581, -1581, 1117, 918, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 594, -1581, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 1840, -1581, -1581, -1581, 1517, -1581, 752, 1318, -1317, -1581, 9, -1581, -1581, -1581, -1581, 894, -1581, -1581, -1581, -1581, -1581, -1581, -1581, 1206, -640, 165, -69, -1581, 21, -1581, -5, 496, -224, 129, 1124, -52, -417, -126 }; /* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If positive, shift that token. If negative, reduce the rule which number is the opposite. If zero, do what YYDEFACT says. If YYTABLE_NINF, syntax error. */ #define YYTABLE_NINF -726 static const yytype_int16 yytable[] = { 32, 160, 37, 816, 1231, 231, 1139, 368, 636, 49, 754, 1452, 1540, 487, 29, 156, 1550, 6, 553, 2336, 6, 65, 968, 1196, 1197, 1147, 1148, 1149, 1150, 1187, 1782, 825, 969, 76, 77, 41, 553, 6, 554, 1164, 6, 553, 564, 6, 171, 553, 553, 6, 6, 1201, 1523, 1798, 1597, 305, 6, 826, 33, 1804, 951, 1130, 7, 8, 9, 1204, 2035, 10, 11, 12, 1815, 13, 6, 487, 6, 6, 453, 688, 1823, 1824, 1131, 15, 16, 3, -35, 1170, 458, 6, -3, 460, 1175, 1176, 487, 161, 33, 2337, 487, 302, 337, 304, 1198, 1199, 458, 163, 754, 754, 754, 754, 454, 689, 33, 634, 164, 977, 1479, 979, 33, 38, 571, 39, 1488, 49, 49, 49, 49, 49, 1246, 952, 236, 32, 298, 628, 32, 253, 32, 32, 32, 32, 270, 299, 2036, 571, 235, 240, 458, 51, 248, 252, 257, 261, 265, 269, 499, 6, 493, 124, 43, 125, 1163, 7, 8, 9, 358, 458, 10, 11, 12, 458, 13, 49, 312, 359, 241, 242, 283, 161, 463, 1292, 15, 16, 464, 563, 754, 1598, 468, 2338, 1480, 161, 500, 161, 465, 571, 1489, 165, 126, 501, 127, 40, 469, 572, 166, 754, 754, 754, 754, 754, 754, 754, 754, 754, 754, 754, 754, 754, 754, 754, 754, 53, 413, 754, 6, 44, 572, 2037, 45, 46, 365, 299, 367, 544, 79, 80, 81, 54, 1705, 756, 1490, 1481, 299, 1058, 494, 6, 44, 1491, 1492, 45, 46, 168, 970, 1059, 495, 280, 947, 281, 169, 221, 222, 223, 224, 84, 85, 86, 87, 88, 89, 90, 496, 218, 55, 1482, 1483, 56, 572, 219, 807, 1493, 49, 49, 49, 1132, 571, 1494, 1495, 57, 1374, 272, 1060, 1061, 1062, 1063, 1064, 1065, 450, 273, 451, 1407, 66, 33, 806, 571, 832, 1410, 833, 311, 292, 293, 489, 1069, 555, 1533, 397, 399, 294, 401, 402, 404, 406, 33, 520, 557, 156, 72, 412, 42, 296, 297, 555, 756, 756, 756, 756, 555, 551, 64, 556, 555, 555, 557, 565, 556, 33, 306, 557, 556, 73, 1202, 557, 557, 754, 1599, 1090, 502, 754, 49, 49, 1426, 1091, 1232, 58, 1205, 49, 572, 488, 584, 489, 571, 1251, 1796, 1257, 1195, 59, 571, 32, 34, 492, 35, 32, 573, 36, 60, 572, 1233, 161, 489, 161, 949, 485, 489, 1072, 466, 504, 1239, 472, 1484, 1531, 1532, 1534, 470, 473, 1496, 573, 1146, 831, 1541, 200, 756, 474, 1031, 161, 1032, 391, 392, 393, 1838, 1853, 227, 49, 1033, 33, 1842, 1843, 1844, 228, 2109, 756, 756, 756, 756, 756, 756, 756, 756, 756, 756, 756, 756, 756, 756, 756, 756, 230, 1569, 756, 1015, 834, 74, 572, 228, 1066, 497, 573, 1577, 572, 1016, 1017, 1018, 560, 6, 243, 244, 67, 1151, 567, 7, 8, 9, 569, 75, 10, 11, 12, 360, 13, 68, 69, 61, 579, 1571, 361, 47, 48, 505, 15, 16, 70, 62, 560, 448, 449, 6, 1873, 1874, 589, 2110, 452, 2111, 591, 506, 1240, 63, 47, 48, 594, 71, 596, 597, 2112, 1241, 598, 695, 600, 49, 78, 2149, 1542, 1543, 1544, 1545, 507, 2113, 1357, 1548, 128, 117, 1622, 2158, 757, 477, 1036, 2162, 43, 141, 1071, 835, 754, 1546, 2114, 972, 1037, 573, 1038, 973, 974, 478, 511, 754, 394, 299, 627, 560, 535, 142, 1991, 479, 480, 171, 157, 1460, 573, 560, 1461, 362, 481, 748, 482, 1234, 1235, 33, 363, 1153, 1092, 756, 414, 167, 809, 756, 1093, 529, 631, 299, 633, 1462, 1463, 1464, 545, 1675, 1342, 512, 1343, 6, 508, 299, 550, 1683, 1684, 7, 8, 9, 170, 228, 10, 11, 12, 158, 13, 475, 1034, 1908, 1909, 1910, 1911, 1912, 1913, 67, 15, 16, 1096, 172, 757, 757, 757, 757, 1097, 2238, 573, 583, 68, 69, 2242, 296, 573, -38, 228, 605, 299, 1155, 32, 70, 228, 377, 1019, 1161, 173, 2247, 2248, 601, 1182, 755, 174, 32, 701, 175, 32, 1183, 32, 513, 176, 514, 515, 32, 694, 228, 32, 760, 32, 1448, 763, 32, 768, 702, 703, 1775, 1449, 778, 2070, 1450, 781, 32, 784, 200, 509, 788, 1451, 516, 177, 272, 2283, -35, 704, 705, 370, 796, 560, 273, 178, 32, 757, 33, 1750, 1772, 1751, 1773, 2115, 371, 69, 772, 773, 774, 775, 701, 855, 179, 856, 1465, 70, 757, 757, 757, 757, 757, 757, 757, 757, 757, 757, 757, 757, 757, 757, 757, 757, 1887, 180, 757, 216, 217, 274, 1039, 218, 755, 755, 755, 755, 517, 219, 837, 181, 6, 289, 1454, 975, 182, 483, 7, 8, 9, 1455, 756, 10, 11, 12, 183, 13, 850, 851, 852, 853, 184, 756, 1500, 1511, 854, 15, 16, 2361, 185, 1501, 1512, 764, 765, 1867, 2369, 32, 1021, 186, 1022, 1023, 1024, 1025, 1026, 1027, 1028, 187, 1560, 290, 291, 292, 293, 188, 2384, 189, 560, 1552, 560, 294, 2388, 386, 1468, 190, 1553, 1469, 191, 232, 1914, 844, 845, 696, 755, 846, 847, 848, 849, 850, 851, 852, 853, 939, 940, 942, 943, 854, 1470, 1471, 988, 1472, 1473, 755, 755, 755, 755, 755, 755, 755, 755, 755, 755, 755, 755, 755, 755, 755, 755, 6, 192, 755, 6, 1137, 193, 7, 8, 9, 194, 757, 10, 11, 12, 757, 13, 32, 1070, 195, 290, 291, 292, 293, 216, 217, 15, 16, 6, 196, 294, 1068, 693, 776, 7, 8, 9, 1379, 299, 10, 11, 12, 1774, 13, 827, 828, 829, 830, 1701, 1706, 275, 6, 276, 15, 16, 1553, 1553, 7, 8, 9, 1828, 277, 10, 11, 12, 1846, 13, 1829, 1338, 1341, 295, 1849, 1847, 1558, 1559, 1756, 15, 16, 1850, 1136, 1136, 492, 1852, 290, 291, 292, 293, 754, 278, 1850, 1865, 2061, 2061, 294, 279, 1185, 301, 1553, 1145, 560, 492, 492, 492, 492, 2033, 1567, 1568, 1581, 1582, 1159, 2051, 2034, 1474, 303, 492, 1165, 307, 2052, 1583, 228, 249, 2071, 980, 211, 212, 213, 214, 215, 1553, 216, 217, 1029, 755, 218, 1585, 228, 755, 1604, 228, 219, 337, 991, 992, 993, 994, 995, 996, 997, 998, 999, 1000, 1001, 1002, 1003, 1004, 1005, 1006, 356, 2126, 1011, 357, 1186, 2139, 364, 1190, 2127, 366, 1191, 1192, 1553, 1606, 228, 369, 492, 492, 376, 848, 849, 850, 851, 852, 853, 387, 1208, 1209, 161, 854, 1670, 1671, 1745, 363, 233, 1237, 1746, 1747, 1242, 1243, 757, 388, 492, 1858, 299, 1901, 940, 294, 1250, 1253, 49, 757, 49, 1259, 1260, 1954, 1955, 408, 1261, 1984, 299, 1985, 299, 1266, 1267, 1268, 1269, 1270, 1271, 1272, 1273, 1274, 1986, 299, 1276, 1277, 1278, 1279, 1280, 1987, 299, 2073, 299, 1285, 2077, 299, 2119, 1671, 49, 2184, 299, 2185, 299, 492, 49, 49, 409, 49, 49, 1297, 1298, 1299, 410, 1301, 1302, 1303, 1304, 1305, 1306, 1307, 1308, 1309, 1310, 1311, 1312, 419, 1314, 2089, 2186, 299, 1318, 2187, 299, 444, 2131, 2207, 2208, 2209, 2210, 2277, 299, 1178, 2279, 299, 6, 1180, 2280, 299, 237, 238, 7, 8, 9, 2307, 2308, 10, 11, 12, 420, 13, 2323, 299, 462, 756, 2364, 2365, 6, 2366, 2367, 15, 16, 755, 7, 8, 9, 245, 246, 10, 11, 12, 519, 13, 755, 521, 522, 525, 526, 527, 530, 2169, 531, 15, 16, 533, 1254, 542, 1256, 561, 543, 250, 6, 552, 562, 566, 568, 570, 7, 8, 9, 1403, 576, 10, 11, 12, 577, 13, 578, 580, 581, 582, 585, 492, 6, 1247, 586, 15, 16, 492, 7, 8, 9, 1255, 1290, 10, 11, 12, 1564, 13, 1293, 1294, 587, 1295, 1296, 6, 588, 590, 592, 15, 16, 7, 8, 9, 118, 123, 10, 11, 12, 595, 13, 599, 602, 1210, 603, 1211, 1212, 1213, 606, 1580, 15, 16, 609, 610, 611, 613, 614, 1584, 617, 1586, 626, 637, 159, 162, 754, 213, 214, 215, 629, 216, 217, 638, 2225, 218, 640, 641, 643, 645, 646, 219, 647, 1507, 1214, 1215, 1216, 1217, 1218, 1219, 1220, 1221, 1605, 1222, 1223, 1340, 648, 1607, 1526, 1526, 651, 2090, 653, 654, 492, 492, 492, 286, 197, 198, 199, 1369, 658, 492, 659, 661, 668, 663, 6, 49, 679, 664, 1377, 666, 7, 8, 9, 669, 560, 10, 11, 12, 671, 13, 672, 673, 271, 675, 676, 678, 2299, 681, 691, 15, 16, 282, 159, 682, 161, 707, 708, 492, 770, 769, 805, 789, 802, 804, 159, 815, 159, 492, 817, 308, 309, 310, 819, 820, 313, 314, 315, 316, 317, 318, 319, 320, 321, 322, 323, 324, 325, 326, 327, 328, 329, 330, 331, 332, 333, 334, 335, 821, 822, 836, 857, 338, 339, 340, 341, 342, 343, 344, 345, 346, 347, 348, 349, 350, 351, 352, 353, 354, 355, -725, 865, 866, 867, 791, 792, 793, 794, 868, 254, 255, 869, 1613, 1614, 933, 934, 935, 1618, 936, 948, 950, 492, 978, 748, 981, 757, 982, 983, 1629, 984, 985, 258, 259, 986, 854, 989, 1007, 6, 1013, 1141, 1074, 1075, 1697, 7, 8, 9, 1224, 1083, 10, 11, 12, 1076, 13, 310, 1101, 1077, 1078, 49, 389, 390, 1655, 1079, 15, 16, 1080, 262, 263, 395, 396, 398, 1081, 400, 400, 403, 405, 407, 756, 1082, 1084, 1085, 411, 1102, 492, 1086, 1087, 1678, 1679, 415, 1681, 1682, 492, 492, 841, 842, 843, 844, 845, 1088, 32, 846, 847, 848, 849, 850, 851, 852, 853, 1089, 266, 267, 6, 854, 1692, 1094, 1100, 1095, 7, 8, 9, 1098, 1099, 10, 11, 12, 1103, 13, 1104, 1107, 1140, 1142, 1143, 660, 161, 1105, 1106, 15, 16, 6, 1108, 1109, 159, 1110, 159, 7, 8, 9, 755, 1111, 10, 11, 12, 1158, 13, 1112, 202, 203, 204, 1113, 205, 206, 207, 208, 15, 16, 209, 210, 159, 1114, 492, 1160, 215, 1776, 216, 217, 1115, 1779, 218, 1780, 1116, 1167, 1117, 1046, 219, 1118, 1047, 1168, 1048, 1119, 1120, 1179, 1166, 1652, 1121, 951, 1193, 1122, 1049, 1123, 534, 699, 700, 1124, 1857, 1125, 1859, 1860, 1861, 771, 1194, 1126, 1195, 1200, 536, 1050, 1051, 1052, 1127, 1207, 1169, 1171, 1173, 537, 538, 539, 1174, 1238, 540, 1177, 541, 1053, 1181, 1245, 1249, 1262, 548, 549, 1265, 1300, 1313, 1315, 1316, 1835, 1317, 1330, 1667, 1668, 1669, 1346, 1347, 1332, 1673, 1348, 1345, 6, 1349, 1368, 1351, 1353, 1355, 7, 8, 9, 1356, 1358, 10, 11, 12, 1359, 13, 1361, 1362, 1363, 1366, 1367, 49, 1371, 1372, 492, 15, 16, 49, 1373, 1378, 1380, 49, 1381, 1382, 1383, 1384, 1385, 1386, 49, 161, 1388, 161, 161, 161, 1391, 1392, 1393, 1394, 1395, 1764, 1054, 607, 608, 1397, 1399, 1400, 612, 1401, 1402, 49, 49, 49, 1405, 1406, 1409, 49, 1408, 1411, 615, 1412, 1413, 1439, 1440, 1415, 1416, 624, 1417, 1418, 758, 759, 1419, 1420, 1423, 630, 1424, 400, 1425, 1427, 1214, 1215, 1216, 1217, 1218, 1219, 1220, 1221, 1428, 1228, 1430, 32, 1431, 1432, 1433, 1435, 1436, 1437, 1935, 1441, 1937, 1442, 1443, 6, 1444, 1445, 757, 32, 1446, 7, 8, 9, 1447, 32, 10, 11, 12, 1453, 13, 1456, 1457, 1458, 677, 1476, 32, 1487, 1498, 1055, 15, 16, 1995, 1499, 32, 32, 1056, 685, 1999, 1502, 1529, 1503, 1504, 1505, 1506, 761, 762, 49, 49, 1864, 1509, 1510, 1515, 1513, 1514, 1869, 49, 1516, 1517, 1875, 1566, 1073, 1573, 1518, 1574, 1519, 1881, 706, 1520, 1521, 1522, 1535, 766, 767, 1320, 1321, 1322, 1323, 1324, 1325, 1326, 1327, 1328, 1536, 49, 49, 1537, 1896, 1897, 1898, 1868, 1538, 1870, 1900, 1539, 1551, 1578, 1561, 1562, 1878, 1563, 6, 228, 1565, 1579, 797, 798, 7, 8, 9, 1575, 803, 10, 11, 12, 1587, 13, 1588, 1589, 1590, 1591, 1593, 161, 1610, 1595, 1596, 15, 16, 161, 755, 1601, 1611, 1603, 1609, 1619, 1621, 1623, 1625, 1686, 1376, 1628, 1662, 1631, 6, 1637, 1152, 1154, 1156, 1157, 7, 8, 9, 1162, 1648, 10, 11, 12, 1229, 13, 1656, 1663, 1657, 1660, 1665, 1666, 1930, 1674, 1932, 15, 16, 1676, 1677, 1685, 1507, 1694, 1693, 1696, 1698, 1699, 1700, 1702, 1963, 1964, 1703, 1707, 49, 1704, 49, 779, 780, 1972, 864, 1708, 1759, 1760, 1689, 1752, 1766, 1767, 1769, 1770, 7, 8, 9, 1762, 1765, 10, 11, 12, 1771, 13, 49, 932, 2135, 2136, 2137, 2138, 1784, 1993, 1994, 15, 16, 202, 203, 204, 1777, 205, 206, 207, 208, 1778, 1978, 209, 210, 211, 212, 213, 214, 215, 1781, 216, 217, 1783, 1790, 218, 1792, 1799, 1785, 1789, 1802, 219, 1791, 1805, 1817, 616, 1822, 1818, 1819, 1263, 1264, 1831, 1855, 1848, 1833, 1832, 1862, 1834, 2128, 1866, 1872, 492, 1275, 1882, 1837, 1884, 1892, 1839, 1840, 1008, 1845, 1854, 1856, 1906, 1871, 1920, 2015, 954, 955, 956, 957, 958, 959, 960, 961, 962, 963, 1888, 1889, 1890, 782, 783, 964, 1891, 161, 161, 161, 161, 1903, 1904, 1905, 1907, 1690, 1916, 1918, 965, 1922, 1925, 1919, 1926, 2053, 1927, 2054, 1921, 1929, 1936, 492, 1938, 1939, 1940, 1941, 1956, 1958, 1959, 1960, 1965, 1962, 1968, 1969, 1350, 1970, 1352, 1971, 1354, 1973, 1974, 2078, 1975, 1979, 1360, 1988, 1982, 1989, 1990, 2002, 2003, 2004, 2005, 2013, 2055, 2006, 32, 2007, 2017, 2016, 2018, 2019, 2021, 2023, 2026, 32, 2020, 2027, 2028, 32, 2029, 2253, 2030, 2255, 2256, 2043, 2044, 2045, 1389, 1210, 2048, 1211, 1212, 1213, 2049, 2050, 2065, 2066, 2067, 2068, 2069, 786, 787, 2079, 1404, 838, 839, 840, 841, 842, 843, 844, 845, 2072, 2080, 846, 847, 848, 849, 850, 851, 852, 853, 2088, 2243, 2091, 2244, 854, 1214, 1215, 1216, 1217, 1218, 1219, 1220, 1221, 1422, 1222, 1223, 2092, 2093, 159, 2056, 699, 810, 2057, 2098, 2058, 2103, 2105, 2106, 2311, 2107, 2118, 2120, 32, 2121, 2124, 49, 32, 2129, 2130, 2147, 2146, 32, 32, 2140, 2056, 1800, 2132, 2057, 161, 2058, 161, 161, 2148, 2154, 2164, 2156, 1244, 2165, 1214, 1215, 1216, 1217, 1218, 1219, 1220, 1221, 2168, 2059, 2170, 2175, 2171, 2177, 2178, 1691, 2174, 492, 2179, 32, 2180, 2183, 2188, 2194, 2189, 1214, 1215, 1216, 1217, 1218, 1219, 1220, 1221, 2201, 2059, 966, 2195, 1281, 2197, 1283, 2198, 2199, 1286, 1287, 1549, 1289, 2206, 202, 203, 204, 2213, 205, 206, 207, 208, 2214, 2216, 209, 210, 2200, 161, 2217, 2203, 215, 2218, 216, 217, 2219, 2221, 218, 2223, 2249, 2261, 2222, 2227, 219, 2228, 2220, 2229, 2274, 2291, 1319, 2250, 2230, 2231, 2292, 2251, 2281, 1337, 1801, 2312, 2237, 2240, 2314, 2246, 2254, 2268, 32, 2257, 2264, 2373, 2295, 2374, 2271, 2269, 32, 2276, 2284, 2285, 2288, 2297, 2266, 2298, 2309, 2310, 2315, 2325, 2318, 2319, 2324, 32, 2326, 1227, 2331, 32, 838, 839, 840, 841, 842, 843, 844, 845, 2252, 2335, 846, 847, 848, 849, 850, 851, 852, 853, 2332, 2340, 2341, 2265, 854, 2350, 2342, 2398, 2270, 2334, 1612, 2372, 2344, 2349, 2345, 1172, 2346, 2380, 1620, 2347, 2399, 1189, 1188, 2351, 2352, 2359, 698, 1364, 1043, 859, 1632, 1527, 2060, 1635, 2289, 2360, 2379, 674, 1638, 2294, 2377, 2381, 2383, 1688, 2400, 2401, 1981, 2302, 2303, 1138, 1749, 2306, 1650, 1863, 1333, 1651, 2042, 2063, 1555, 0, 0, 0, 1806, 0, 0, 0, 0, 1661, 0, 0, 0, 2320, 2321, 202, 203, 204, 0, 205, 206, 207, 208, 2330, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 1695, 0, 0, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 1807, 216, 217, 0, 0, 218, 0, 0, 1753, 1754, 1755, 219, 1757, 0, 0, 0, 0, 0, 0, 0, 0, 1557, 0, 0, 0, 0, 79, 80, 143, 1768, 0, 840, 841, 842, 843, 844, 845, 82, 83, 846, 847, 848, 849, 850, 851, 852, 853, 145, 146, 147, 148, 854, 0, 1572, 0, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 202, 203, 204, 0, 205, 206, 207, 208, 0, 1808, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 0, 0, 0, 0, 0, 1608, 0, 0, 0, 0, 0, 0, 1615, 1616, 1617, 0, 0, 0, 0, 0, 0, 1624, 0, 1626, 1627, 0, 0, 1630, 0, 0, 1633, 1634, 0, 0, 0, 1636, 0, 0, 1639, 1640, 1641, 1642, 0, 0, 1643, 1644, 1645, 1646, 1647, 0, 1649, 1809, 0, 0, 0, 0, 1653, 1654, 0, 0, 0, 1658, 1659, 0, 0, 0, 0, 0, 0, 1664, 0, 0, 0, 0, 0, 0, 0, 1672, 0, 0, 0, 0, 0, 0, 0, 1680, 0, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 159, 216, 217, 0, 204, 218, 205, 206, 207, 208, 0, 219, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 1942, 0, 0, 0, 219, 0, 1944, 0, 0, 0, 0, 0, 0, 0, 0, 1948, 0, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 0, 0, 0, 0, 0, 0, 79, 80, 81, 623, 0, 0, 0, 1983, 151, 0, 0, 82, 83, 0, 0, 115, 0, 0, 116, 0, 0, 0, 1992, 117, 0, 0, 0, 284, 0, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 1813, 216, 217, 0, 0, 218, 159, 0, 159, 159, 159, 219, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1876, 1877, 0, 0, 1879, 1880, 0, 1814, 0, 0, 1883, 0, 1886, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1893, 0, 1894, 1895, 0, 0, 0, 202, 203, 204, 1899, 205, 206, 207, 208, 1902, 0, 209, 210, 211, 212, 213, 214, 215, 1917, 216, 217, 0, 0, 218, 0, 205, 206, 207, 208, 219, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 1931, 218, 1933, 1934, 0, 0, 0, 219, 0, 2099, 0, 2101, 0, 0, 0, 0, 0, 0, 0, 0, 2117, 0, 0, 0, 0, 1946, 1947, 0, 0, 79, 80, 709, 2125, 0, 1951, 0, 0, 0, 0, 0, 82, 83, 0, 0, 1957, 2134, 0, 0, 1961, 0, 0, 0, 2141, 0, 1966, 1967, 0, 0, 84, 85, 86, 87, 88, 89, 90, 710, 711, 712, 713, 714, 715, 716, 717, 718, 719, 720, 721, 722, 723, 724, 725, 726, 727, 728, 729, 730, 731, 732, 733, 734, 735, 736, 2167, 737, 738, 0, 0, 0, 0, 0, 159, 0, 0, 1996, 1997, 1998, 159, 114, 0, 0, 0, 0, 0, 0, 115, 0, 0, 116, 0, 0, 0, 0, 117, 0, 2008, 2009, 2010, 2011, 2012, 0, 0, 0, 0, 0, 0, 0, 0, 6, 0, 0, 0, 0, 0, 7, 8, 9, 0, 0, 10, 11, 12, 739, 13, 0, 14, 0, 0, 0, 0, 740, 0, 0, 15, 16, 0, 0, 202, 203, 204, 2232, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 0, 0, 2064, 202, 203, 204, 17, 205, 206, 207, 208, 0, 18, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 19, 0, 218, 20, 0, 0, 0, 0, 219, 1816, 2086, 0, 0, 0, 21, 0, 0, 0, 22, 0, 2094, 2095, 2096, 2097, 0, 0, 0, 2100, 0, 2102, 23, 2104, 0, 0, 0, 2108, 0, 0, 0, 0, 0, 0, 0, 2122, 2123, 0, 0, 0, 1820, 0, 24, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 159, 159, 159, 159, 0, 0, 0, 0, 2142, 2143, 2144, 0, 0, 0, 0, 0, 0, 0, 0, 741, 0, 0, 0, 0, 0, 742, 743, 0, 0, 0, 0, 0, 0, 744, 0, 0, 745, 0, 0, 1009, 1010, 746, 747, 0, 748, 2166, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 25, 2176, 26, 0, 0, 0, 0, 2182, 0, 0, 0, 838, 839, 840, 841, 842, 843, 844, 845, 0, 2193, 846, 847, 848, 849, 850, 851, 852, 853, 2202, 0, 2204, 0, 854, 0, 987, 0, 2212, 0, 79, 80, 456, 0, 0, 0, 0, 0, 0, 0, 0, 82, 83, 0, 0, 0, 0, 0, 0, 0, 0, 145, 146, 147, 148, 2233, 2234, 2235, 0, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 0, 0, 0, 0, 159, 0, 159, 159, 0, 0, 0, 0, 0, 2262, 458, 0, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 2275, 216, 217, 2278, 0, 218, 0, 0, 0, 0, 0, 219, 0, 0, 0, 0, 0, 2286, 2287, 0, 0, 0, 202, 203, 204, 0, 205, 206, 207, 208, 0, 2300, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 159, 0, 0, 219, 0, 0, 2316, 2317, 0, 0, 0, 0, 2322, 0, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 1821, 216, 217, 0, 2343, 218, 0, 0, 0, 2348, 0, 219, 0, 0, 0, 2354, 2355, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2368, 0, 0, 0, 2371, 0, 0, 79, 80, 709, 0, 0, 0, 0, 0, 0, 0, 2382, 82, 83, 2385, 0, 2386, 2387, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2394, 2395, 0, 84, 85, 86, 87, 88, 89, 90, 710, 711, 712, 713, 714, 715, 716, 717, 718, 719, 720, 721, 722, 723, 724, 725, 726, 727, 728, 729, 730, 731, 732, 733, 734, 735, 736, 0, 737, 738, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 151, 1825, 0, 0, 0, 0, 0, 115, 0, 0, 116, 0, 0, 0, 0, 459, 0, 0, 152, 0, 0, 0, 0, 0, 79, 80, 456, 144, 0, 0, 45, 0, 0, 0, 0, 82, 83, 0, 0, 0, 0, 0, 0, 0, 739, 145, 146, 147, 148, 149, 0, 0, 740, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 0, 79, 80, 143, 44, 0, 0, 45, 46, 0, 0, 457, 82, 83, 458, 0, 0, 0, 0, 0, 0, 0, 145, 146, 147, 148, 0, 0, 0, 0, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 0, 0, 0, 0, 202, 203, 204, 1826, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 0, 0, 0, 2081, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 741, 0, 0, 0, 0, 0, 742, 743, 0, 79, 80, 143, 144, 0, 744, 45, 0, 745, 0, 0, 82, 83, 746, 747, 0, 748, 0, 0, 0, 0, 145, 146, 147, 148, 149, 0, 0, 0, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 0, 202, 203, 204, 0, 205, 206, 207, 208, 2082, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 150, 0, 0, 0, 0, 219, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 151, 0, 0, 0, 0, 0, 0, 115, 0, 0, 116, 0, 0, 0, 0, 459, 0, 0, 152, 0, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 47, 48, 0, 0, 0, 219, 0, 79, 80, 143, 431, 0, 0, 0, 0, 0, 0, 151, 82, 83, 0, 0, 0, 0, 115, 0, 0, 116, 145, 146, 147, 148, 117, 0, 0, 1339, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 2083, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 150, 0, 0, 0, 0, 219, 0, 79, 80, 81, 44, 0, 0, 45, 46, 0, 0, 151, 82, 83, 0, 0, 0, 0, 115, 0, 0, 116, 0, 0, 0, 0, 117, 0, 0, 152, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 0, 0, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 0, 0, 0, 0, 0, 79, 80, 143, 0, 0, 0, 0, 0, 0, 0, 0, 82, 83, 0, 0, 0, 1976, 0, 0, 0, 1977, 145, 146, 147, 148, 0, 0, 0, 0, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 79, 80, 81, 0, 0, 0, 151, 0, 0, 0, 0, 82, 83, 115, 0, 0, 116, 0, 0, 0, 0, 117, 0, 0, 152, 0, 0, 0, 0, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 0, 0, 0, 0, 0, 0, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 47, 48, 0, 0, 0, 0, 0, 79, 80, 81, 546, 0, 0, 0, 0, 0, 0, 114, 82, 83, 0, 0, 0, 0, 115, 0, 0, 116, 0, 0, 0, 0, 117, 0, 0, 1336, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 872, 2084, 0, 0, 0, 0, 7, 8, 9, 0, 0, 10, 11, 873, 0, 13, 0, 838, 839, 840, 841, 842, 843, 844, 845, 15, 16, 846, 847, 848, 849, 850, 851, 852, 853, 0, 79, 80, 81, 854, 0, 0, 0, 1375, 0, 0, 151, 82, 83, 0, 0, 0, 0, 115, 0, 0, 116, 0, 0, 0, 0, 117, 0, 0, 152, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 114, 0, 0, 0, 0, 0, 0, 115, 0, 0, 116, 384, 0, 0, 0, 117, 0, 0, 385, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 872, 0, 926, 0, 0, 927, 7, 8, 9, 114, 0, 10, 11, 873, 0, 13, 115, 0, 0, 116, 0, 0, 0, 0, 117, 15, 16, 547, 0, 838, 839, 840, 841, 842, 843, 844, 845, 0, 0, 846, 847, 848, 849, 850, 851, 852, 853, 0, 0, 0, 0, 854, 202, 203, 204, 1570, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 872, 0, 0, 0, 0, 219, 7, 8, 9, 0, 928, 10, 11, 873, 0, 13, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 16, 0, 0, 114, 0, 0, 0, 0, 0, 0, 115, 0, 0, 116, 0, 2085, 0, 0, 117, 0, 0, 1885, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 0, 0, 926, 0, 0, 927, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 872, 0, 926, 0, 0, 927, 7, 8, 9, 0, 1928, 10, 11, 873, 0, 13, 79, 80, 143, 0, 0, 0, 0, 0, 0, 15, 16, 82, 83, 0, 0, 0, 0, 0, 0, 0, 0, 145, 146, 147, 148, 0, 0, 0, 0, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 872, 2215, 0, 0, 0, 0, 7, 8, 9, 0, 1943, 10, 11, 873, 1184, 13, 0, 202, 203, 204, 0, 205, 206, 207, 208, 15, 16, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 445, 0, 0, 219, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 0, 0, 926, 0, 0, 927, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 872, 0, 926, 0, 0, 927, 7, 8, 9, 151, 1945, 10, 11, 873, 0, 13, 115, 0, 0, 116, 0, 0, 0, 0, 117, 15, 16, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 440, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 872, 0, 0, 0, 0, 219, 7, 8, 9, 0, 1949, 10, 11, 873, 0, 13, 0, 202, 203, 204, 0, 205, 206, 207, 208, 15, 16, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 446, 286, 0, 0, 219, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 0, 0, 926, 0, 0, 927, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 872, 0, 926, 0, 0, 927, 7, 8, 9, 0, 1952, 10, 11, 873, 0, 13, 79, 80, 143, 0, 0, 0, 0, 0, 0, 15, 16, 82, 83, 0, 0, 0, 0, 0, 0, 0, 0, 145, 146, 147, 148, 0, 0, 0, 0, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 872, 286, 0, 0, 0, 0, 7, 8, 9, 0, 1953, 10, 11, 873, 0, 13, 0, 202, 203, 204, 0, 205, 206, 207, 208, 15, 16, 209, 210, 211, 212, 287, 288, 215, 0, 216, 217, 0, 0, 218, 0, 692, 201, 0, 0, 219, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 0, 0, 926, 0, 0, 927, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 872, 0, 926, 0, 0, 927, 7, 8, 9, 151, 2196, 10, 11, 873, 0, 13, 115, 0, 0, 116, 0, 0, 0, 0, 117, 15, 16, 838, 839, 840, 841, 842, 843, 844, 845, 0, 0, 846, 847, 848, 849, 850, 851, 852, 853, 0, 0, 0, 0, 854, 1748, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 287, 288, 215, 0, 216, 217, 0, 0, 218, 0, 872, 0, 0, 0, 219, 0, 7, 8, 9, 0, 2205, 10, 11, 873, 0, 13, 0, 202, 203, 204, 0, 205, 206, 207, 208, 15, 16, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 286, 0, 0, 219, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 0, 0, 926, 0, 0, 927, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 872, 0, 926, 0, 0, 927, 7, 8, 9, 0, 2211, 10, 11, 873, 0, 13, 79, 80, 81, 0, 0, 0, 0, 0, 0, 15, 16, 82, 83, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 872, 417, 0, 0, 0, 0, 7, 8, 9, 0, 2263, 10, 11, 873, 0, 13, 0, 202, 203, 204, 0, 205, 206, 207, 208, 15, 16, 209, 210, 211, 212, 287, 288, 215, 0, 216, 217, 0, 0, 218, 0, 0, 447, 0, 0, 219, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 0, 0, 926, 0, 0, 927, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 872, 0, 926, 0, 0, 927, 7, 8, 9, 114, 2267, 10, 11, 873, 0, 13, 115, 0, 0, 116, 0, 0, 0, 0, 117, 15, 16, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 528, 0, 0, 0, 0, 0, 0, 0, 0, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 872, 0, 0, 0, 219, 0, 7, 8, 9, 0, 2272, 10, 11, 873, 0, 13, 0, 202, 203, 204, 0, 205, 206, 207, 208, 15, 16, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 0, 0, 926, 0, 0, 927, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 872, 0, 926, 0, 0, 927, 7, 8, 9, 0, 2273, 10, 11, 873, 0, 13, 0, 202, 203, 204, 0, 205, 206, 207, 208, 15, 16, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 872, 0, 0, 0, 441, 0, 7, 8, 9, 0, 2301, 10, 11, 873, 0, 13, 0, 202, 203, 204, 0, 205, 206, 207, 208, 15, 16, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 0, 0, 0, 0, 442, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 0, 0, 926, 0, 0, 927, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 872, 0, 926, 0, 0, 927, 7, 8, 9, 0, 2370, 10, 11, 873, 0, 13, 0, 202, 203, 204, 0, 205, 206, 207, 208, 15, 16, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 0, 0, 0, 0, 523, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 872, 0, 0, 0, 219, 0, 7, 8, 9, 524, 2376, 10, 11, 873, 0, 13, 0, 202, 203, 204, 0, 205, 206, 207, 208, 15, 16, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 0, 0, 0, 0, 683, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 0, 0, 0, 925, 0, 0, 0, 0, 0, 926, 0, 0, 927, 874, 0, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 0, 0, 0, 0, 0, 895, 896, 897, 0, 0, 898, 899, 900, 901, 0, 0, 902, 0, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 1709, 0, 0, 925, 0, 0, 0, 0, 0, 926, 0, 0, 927, 0, 0, 0, 0, 2389, 0, 1710, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 0, 202, 203, 204, 684, 205, 206, 207, 208, 1711, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 790, 0, 209, 210, 211, 212, 213, 214, 215, 2393, 216, 217, 0, 0, 218, 0, 0, 0, 0, 1712, 219, 0, 202, 203, 204, 1134, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 0, 0, 0, 0, 1459, 1713, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1714, 1715, 1716, 1717, 1718, 1719, 1720, 1721, 1722, 0, 0, 1723, 1724, 1725, 1726, 1727, 1728, 1729, 1730, 1731, 1732, 1733, 1734, 1735, 1736, 1737, 1738, 1739, 1740, 1741, 1742, 1743, 0, 0, 1744, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 1467, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 1477, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 1478, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 1486, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 1761, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 1786, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 1787, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 1788, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 1797, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 1803, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 1810, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 1811, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 1812, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 1836, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2024, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2025, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2031, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2032, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2038, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2040, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2046, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2047, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2074, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2075, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2076, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2133, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2153, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2155, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2157, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2163, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2190, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2191, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2192, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2241, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2245, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2282, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2304, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2305, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2328, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2329, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2333, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2358, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2362, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2375, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2378, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2391, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2392, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2396, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 2397, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 300, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 383, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 416, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 625, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 799, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 946, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 1041, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 2014, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 2145, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 2226, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 2236, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 2258, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 2259, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 2260, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 2293, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 2296, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 2353, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 202, 203, 204, 2363, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 0, 0, 0, 2390, 2000, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 202, 203, 204, 219, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 220, 202, 203, 204, 219, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 336, 202, 203, 204, 219, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 418, 202, 203, 204, 219, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 421, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 422, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 423, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 424, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 425, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 426, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 427, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 428, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 429, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 430, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 432, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 433, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 434, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 435, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 436, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 437, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 438, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 439, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 443, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 532, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 618, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 619, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 620, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 621, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 622, 202, 203, 204, 219, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 814, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 937, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 938, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 1530, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 1793, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 1794, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 1795, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 1830, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 1841, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 2001, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 2022, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 2041, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 2150, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 2151, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 2152, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 2159, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 2172, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 2173, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 2224, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 2239, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 2313, 0, 219, 202, 203, 204, 0, 205, 206, 207, 208, 0, 0, 209, 210, 211, 212, 213, 214, 215, 0, 216, 217, 0, 0, 218, 0, 0, 0, 0, 0, 219, 838, 839, 840, 841, 842, 843, 844, 845, 0, 0, 846, 847, 848, 849, 850, 851, 852, 853, 0, 0, 0, 0, 854, 0, 0, 0, 2087 }; static const yytype_int16 yycheck[] = { 5, 70, 7, 709, 1044, 130, 935, 231, 562, 14, 650, 1275, 1329, 5, 5, 67, 1333, 5, 3, 137, 5, 26, 76, 1025, 1026, 954, 955, 956, 957, 5, 1610, 5, 86, 38, 39, 5, 3, 5, 5, 968, 5, 3, 5, 5, 291, 3, 3, 5, 5, 5, 1314, 1631, 5, 7, 5, 29, 303, 1637, 5, 82, 11, 12, 13, 5, 137, 16, 17, 18, 1648, 20, 5, 5, 5, 5, 267, 267, 1656, 1657, 101, 30, 31, 0, 293, 978, 76, 5, 0, 370, 983, 984, 5, 70, 303, 211, 5, 164, 291, 166, 1027, 1028, 76, 292, 742, 743, 744, 745, 299, 299, 303, 71, 301, 817, 21, 819, 303, 291, 23, 293, 21, 124, 125, 126, 127, 128, 1053, 72, 131, 132, 292, 552, 135, 136, 137, 138, 139, 140, 141, 301, 211, 23, 131, 132, 76, 14, 135, 136, 137, 138, 139, 140, 101, 5, 5, 291, 291, 293, 71, 11, 12, 13, 292, 76, 16, 17, 18, 76, 20, 172, 173, 301, 299, 300, 151, 152, 87, 1104, 30, 31, 91, 462, 820, 134, 87, 301, 93, 164, 137, 166, 101, 23, 93, 294, 291, 144, 293, 7, 101, 104, 301, 839, 840, 841, 842, 843, 844, 845, 846, 847, 848, 849, 850, 851, 852, 853, 854, 293, 292, 857, 5, 6, 104, 294, 9, 10, 229, 301, 231, 292, 3, 4, 5, 293, 1549, 650, 137, 144, 301, 91, 91, 5, 6, 144, 145, 9, 10, 294, 300, 101, 101, 291, 804, 293, 301, 124, 125, 126, 127, 32, 33, 34, 35, 36, 37, 38, 117, 290, 299, 176, 177, 299, 104, 296, 695, 176, 279, 280, 281, 300, 23, 182, 183, 299, 1177, 291, 138, 139, 140, 141, 142, 143, 359, 299, 361, 1222, 303, 303, 281, 23, 3, 1228, 5, 172, 282, 283, 296, 293, 291, 299, 287, 288, 290, 290, 291, 292, 293, 303, 385, 302, 370, 6, 299, 291, 157, 158, 291, 742, 743, 744, 745, 291, 455, 299, 299, 291, 291, 302, 299, 299, 303, 293, 302, 299, 6, 299, 302, 302, 986, 300, 293, 300, 990, 356, 357, 1248, 299, 91, 299, 299, 363, 104, 294, 486, 296, 23, 299, 1629, 299, 299, 299, 23, 375, 291, 377, 293, 379, 282, 296, 299, 104, 115, 359, 296, 361, 806, 375, 296, 293, 300, 379, 5, 87, 300, 1321, 1322, 1323, 300, 93, 300, 282, 953, 3, 1330, 5, 820, 101, 101, 385, 103, 279, 280, 281, 1675, 299, 294, 419, 111, 303, 1681, 1682, 1683, 301, 21, 839, 840, 841, 842, 843, 844, 845, 846, 847, 848, 849, 850, 851, 852, 853, 854, 294, 1368, 857, 103, 147, 7, 104, 301, 300, 300, 282, 1378, 104, 113, 114, 115, 459, 5, 299, 300, 267, 293, 465, 11, 12, 13, 469, 7, 16, 17, 18, 294, 20, 280, 281, 299, 479, 1370, 301, 264, 265, 101, 30, 31, 291, 299, 489, 356, 357, 5, 275, 276, 495, 91, 363, 93, 499, 117, 112, 299, 264, 265, 505, 299, 507, 508, 104, 121, 511, 632, 513, 514, 134, 2091, 280, 281, 282, 283, 138, 117, 1158, 264, 293, 296, 1451, 2103, 650, 75, 91, 2107, 291, 213, 293, 236, 1172, 301, 134, 87, 101, 282, 103, 91, 92, 91, 101, 1183, 300, 301, 551, 552, 419, 299, 1867, 101, 102, 291, 267, 144, 282, 562, 147, 294, 110, 299, 112, 299, 300, 303, 301, 293, 293, 986, 294, 292, 697, 990, 299, 410, 555, 301, 557, 168, 169, 170, 294, 1512, 3, 144, 5, 5, 210, 301, 294, 1520, 1521, 11, 12, 13, 299, 301, 16, 17, 18, 267, 20, 300, 300, 94, 95, 96, 97, 98, 99, 267, 30, 31, 293, 293, 742, 743, 744, 745, 299, 2201, 282, 294, 280, 281, 2206, 462, 282, 294, 301, 300, 301, 293, 639, 291, 301, 293, 300, 293, 293, 2221, 2222, 514, 294, 650, 293, 652, 639, 293, 655, 301, 657, 212, 293, 214, 215, 662, 300, 301, 665, 652, 667, 294, 655, 670, 657, 299, 300, 1598, 301, 662, 1989, 294, 665, 680, 667, 5, 300, 670, 301, 240, 293, 291, 2264, 293, 299, 300, 267, 680, 695, 299, 293, 698, 820, 303, 3, 1592, 5, 1594, 300, 280, 281, 121, 122, 123, 124, 698, 296, 293, 298, 300, 291, 839, 840, 841, 842, 843, 844, 845, 846, 847, 848, 849, 850, 851, 852, 853, 854, 1731, 293, 857, 286, 287, 7, 300, 290, 742, 743, 744, 745, 300, 296, 748, 293, 5, 7, 294, 300, 293, 300, 11, 12, 13, 301, 1172, 16, 17, 18, 293, 20, 282, 283, 284, 285, 293, 1183, 294, 294, 290, 30, 31, 2352, 293, 301, 301, 299, 300, 1707, 2359, 785, 101, 293, 103, 104, 105, 106, 107, 108, 109, 293, 1345, 280, 281, 282, 283, 293, 2377, 293, 804, 294, 806, 290, 2383, 300, 144, 293, 301, 147, 293, 70, 300, 274, 275, 302, 820, 278, 279, 280, 281, 282, 283, 284, 285, 300, 301, 300, 301, 290, 168, 169, 836, 171, 172, 839, 840, 841, 842, 843, 844, 845, 846, 847, 848, 849, 850, 851, 852, 853, 854, 5, 293, 857, 5, 6, 293, 11, 12, 13, 293, 986, 16, 17, 18, 990, 20, 871, 872, 293, 280, 281, 282, 283, 286, 287, 30, 31, 5, 293, 290, 871, 292, 300, 11, 12, 13, 300, 301, 16, 17, 18, 1597, 20, 742, 743, 744, 745, 294, 294, 293, 5, 293, 30, 31, 301, 301, 11, 12, 13, 294, 293, 16, 17, 18, 294, 20, 301, 1141, 1142, 7, 294, 301, 300, 301, 1564, 30, 31, 301, 933, 934, 935, 294, 280, 281, 282, 283, 1576, 293, 301, 294, 1980, 1981, 290, 293, 1013, 7, 301, 952, 953, 954, 955, 956, 957, 294, 299, 300, 300, 301, 963, 294, 301, 300, 7, 968, 969, 7, 301, 300, 301, 74, 294, 820, 280, 281, 282, 283, 284, 301, 286, 287, 300, 986, 290, 300, 301, 990, 300, 301, 296, 291, 839, 840, 841, 842, 843, 844, 845, 846, 847, 848, 849, 850, 851, 852, 853, 854, 301, 294, 857, 301, 1015, 294, 7, 1018, 301, 7, 1021, 1022, 301, 300, 301, 293, 1027, 1028, 293, 280, 281, 282, 283, 284, 285, 5, 1037, 1038, 1013, 290, 300, 301, 300, 301, 300, 1046, 300, 301, 1049, 1050, 1172, 5, 1053, 300, 301, 300, 301, 290, 1059, 1060, 1061, 1183, 1063, 1064, 1065, 299, 300, 7, 1069, 300, 301, 300, 301, 1074, 1075, 1076, 1077, 1078, 1079, 1080, 1081, 1082, 300, 301, 1085, 1086, 1087, 1088, 1089, 300, 301, 300, 301, 1094, 300, 301, 300, 301, 1099, 300, 301, 300, 301, 1104, 1105, 1106, 7, 1108, 1109, 1110, 1111, 1112, 267, 1114, 1115, 1116, 1117, 1118, 1119, 1120, 1121, 1122, 1123, 1124, 1125, 301, 1127, 2018, 300, 301, 1131, 300, 301, 292, 2059, 299, 300, 299, 300, 300, 301, 986, 300, 301, 5, 990, 300, 301, 299, 300, 11, 12, 13, 300, 301, 16, 17, 18, 294, 20, 300, 301, 267, 1576, 299, 300, 5, 299, 300, 30, 31, 1172, 11, 12, 13, 299, 300, 16, 17, 18, 299, 20, 1183, 294, 301, 294, 292, 294, 7, 2114, 7, 30, 31, 7, 1061, 292, 1063, 7, 294, 300, 5, 293, 293, 5, 299, 299, 11, 12, 13, 1210, 5, 16, 17, 18, 299, 20, 5, 299, 299, 299, 267, 1222, 5, 1054, 294, 30, 31, 1228, 11, 12, 13, 1062, 1099, 16, 17, 18, 1357, 20, 1105, 1106, 299, 1108, 1109, 5, 5, 299, 299, 30, 31, 11, 12, 13, 42, 43, 16, 17, 18, 299, 20, 299, 293, 86, 5, 88, 89, 90, 5, 1388, 30, 31, 7, 7, 7, 7, 7, 1396, 294, 1398, 7, 7, 70, 71, 1918, 282, 283, 284, 8, 286, 287, 299, 2181, 290, 7, 7, 7, 293, 293, 296, 282, 1300, 125, 126, 127, 128, 129, 130, 131, 132, 1429, 134, 135, 1142, 7, 1434, 1315, 1316, 7, 2019, 7, 7, 1321, 1322, 1323, 8, 114, 115, 116, 1172, 7, 1330, 5, 267, 299, 7, 5, 1336, 300, 7, 1183, 7, 11, 12, 13, 7, 1345, 16, 17, 18, 7, 20, 7, 7, 142, 7, 7, 7, 2281, 292, 3, 30, 31, 151, 152, 294, 1339, 5, 282, 1368, 7, 299, 8, 300, 299, 301, 164, 294, 166, 1378, 293, 169, 170, 171, 293, 293, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 293, 293, 5, 293, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 293, 7, 299, 299, 216, 217, 218, 219, 299, 299, 300, 299, 1442, 1443, 293, 293, 293, 1447, 293, 3, 294, 1451, 293, 299, 5, 1576, 5, 293, 1458, 293, 275, 299, 300, 293, 290, 300, 3, 5, 299, 5, 293, 293, 1536, 11, 12, 13, 300, 7, 16, 17, 18, 293, 20, 272, 7, 293, 293, 1487, 277, 278, 1490, 293, 30, 31, 293, 299, 300, 286, 287, 288, 293, 290, 291, 292, 293, 294, 1918, 293, 293, 293, 299, 7, 1512, 293, 293, 1515, 1516, 306, 1518, 1519, 1520, 1521, 271, 272, 273, 274, 275, 293, 1528, 278, 279, 280, 281, 282, 283, 284, 285, 293, 299, 300, 5, 290, 1528, 293, 299, 293, 11, 12, 13, 293, 293, 16, 17, 18, 7, 20, 293, 7, 6, 5, 299, 585, 1536, 293, 293, 30, 31, 5, 293, 293, 359, 293, 361, 11, 12, 13, 1576, 293, 16, 17, 18, 299, 20, 293, 268, 269, 270, 293, 272, 273, 274, 275, 30, 31, 278, 279, 385, 293, 1598, 5, 284, 1601, 286, 287, 293, 1605, 290, 1607, 293, 5, 293, 86, 296, 293, 89, 5, 91, 293, 293, 300, 299, 1487, 293, 5, 5, 293, 101, 293, 417, 299, 300, 293, 1696, 293, 1698, 1699, 1700, 661, 299, 293, 299, 5, 431, 118, 119, 120, 293, 5, 294, 294, 293, 440, 441, 442, 294, 5, 445, 293, 447, 134, 294, 3, 5, 7, 453, 454, 7, 299, 5, 293, 293, 1671, 299, 293, 1504, 1505, 1506, 7, 7, 301, 1510, 7, 301, 5, 7, 301, 7, 7, 7, 11, 12, 13, 7, 7, 16, 17, 18, 7, 20, 7, 7, 7, 7, 7, 1704, 299, 294, 1707, 30, 31, 1710, 301, 293, 7, 1714, 7, 7, 7, 7, 7, 299, 1721, 1696, 5, 1698, 1699, 1700, 7, 7, 7, 7, 7, 1576, 208, 523, 524, 7, 7, 7, 528, 7, 7, 1742, 1743, 1744, 5, 293, 293, 1748, 7, 293, 8, 5, 5, 294, 294, 7, 7, 547, 7, 7, 299, 300, 7, 7, 7, 555, 7, 557, 7, 7, 125, 126, 127, 128, 129, 130, 131, 132, 7, 134, 7, 1782, 7, 7, 7, 7, 7, 301, 1789, 301, 1791, 301, 301, 5, 301, 301, 1918, 1798, 301, 11, 12, 13, 301, 1804, 16, 17, 18, 301, 20, 301, 294, 301, 602, 301, 1815, 301, 301, 293, 30, 31, 1885, 294, 1823, 1824, 300, 615, 1891, 294, 7, 294, 301, 301, 301, 299, 300, 1836, 1837, 1704, 301, 301, 301, 294, 294, 1710, 1845, 301, 301, 1714, 7, 874, 3, 301, 294, 301, 1721, 645, 301, 301, 301, 299, 299, 300, 222, 223, 224, 225, 226, 227, 228, 229, 230, 299, 1873, 1874, 299, 1742, 1743, 1744, 1709, 299, 1711, 1748, 299, 301, 117, 301, 301, 1718, 301, 5, 301, 301, 7, 683, 684, 11, 12, 13, 275, 689, 16, 17, 18, 7, 20, 7, 7, 3, 7, 7, 1885, 299, 7, 7, 30, 31, 1891, 1918, 293, 7, 294, 294, 7, 7, 294, 7, 294, 8, 7, 7, 299, 5, 299, 958, 959, 960, 961, 11, 12, 13, 965, 299, 16, 17, 18, 300, 20, 299, 7, 299, 299, 7, 7, 1784, 7, 1786, 30, 31, 7, 7, 5, 1962, 231, 7, 299, 299, 299, 299, 294, 1836, 1837, 5, 134, 1974, 293, 1976, 299, 300, 1845, 769, 7, 294, 294, 5, 301, 5, 5, 5, 5, 11, 12, 13, 294, 294, 16, 17, 18, 294, 20, 2000, 790, 2066, 2067, 2068, 2069, 301, 1873, 1874, 30, 31, 268, 269, 270, 7, 272, 273, 274, 275, 7, 1850, 278, 279, 280, 281, 282, 283, 284, 7, 286, 287, 294, 294, 290, 7, 7, 301, 301, 7, 296, 301, 7, 7, 300, 7, 301, 301, 1071, 1072, 294, 5, 7, 301, 294, 7, 301, 2056, 7, 5, 2059, 1084, 5, 301, 5, 3, 301, 301, 856, 301, 299, 301, 300, 299, 7, 1918, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 299, 299, 299, 299, 300, 91, 299, 2066, 2067, 2068, 2069, 294, 294, 294, 294, 121, 294, 293, 104, 7, 7, 300, 7, 1974, 294, 1976, 300, 7, 7, 2114, 7, 7, 7, 294, 7, 7, 7, 7, 294, 299, 7, 294, 1151, 294, 1153, 294, 1155, 7, 139, 2000, 7, 7, 1161, 301, 299, 294, 7, 7, 7, 7, 7, 299, 1977, 7, 2149, 5, 7, 116, 301, 301, 294, 301, 301, 2158, 19, 294, 7, 2162, 301, 2228, 301, 2230, 2231, 294, 294, 7, 1195, 86, 7, 88, 89, 90, 7, 7, 301, 299, 299, 299, 299, 299, 300, 7, 1211, 268, 269, 270, 271, 272, 273, 274, 275, 301, 7, 278, 279, 280, 281, 282, 283, 284, 285, 5, 2207, 299, 2209, 290, 125, 126, 127, 128, 129, 130, 131, 132, 7, 134, 135, 7, 7, 1013, 86, 299, 300, 89, 7, 91, 299, 299, 299, 2298, 299, 7, 7, 2238, 7, 7, 2241, 2242, 5, 5, 294, 299, 2247, 2248, 7, 86, 7, 293, 89, 2228, 91, 2230, 2231, 294, 294, 5, 301, 1051, 5, 125, 126, 127, 128, 129, 130, 131, 132, 5, 134, 294, 7, 301, 7, 7, 300, 294, 2281, 7, 2283, 7, 300, 7, 7, 301, 125, 126, 127, 128, 129, 130, 131, 132, 299, 134, 300, 7, 1090, 7, 1092, 7, 7, 1095, 1096, 1332, 1098, 299, 268, 269, 270, 7, 272, 273, 274, 275, 7, 7, 278, 279, 2153, 2298, 7, 2156, 284, 7, 286, 287, 7, 299, 290, 7, 7, 7, 299, 299, 296, 299, 2171, 300, 7, 7, 1134, 294, 299, 299, 7, 299, 69, 1141, 7, 7, 301, 301, 294, 301, 299, 301, 2361, 300, 299, 2364, 300, 2366, 299, 301, 2369, 301, 301, 301, 301, 300, 2241, 299, 301, 299, 301, 7, 301, 294, 136, 2384, 7, 300, 7, 2388, 268, 269, 270, 271, 272, 273, 274, 275, 2227, 5, 278, 279, 280, 281, 282, 283, 284, 285, 300, 5, 5, 2240, 290, 5, 294, 5, 2245, 300, 1441, 7, 299, 294, 299, 301, 299, 301, 1449, 299, 5, 1017, 1016, 300, 299, 299, 638, 1165, 867, 753, 1461, 1316, 300, 1464, 2271, 300, 300, 599, 1469, 2276, 299, 301, 299, 1527, 300, 300, 1854, 2284, 2285, 934, 1558, 2288, 1483, 1703, 1138, 1486, 1962, 300, 1336, -1, -1, -1, 7, -1, -1, -1, -1, 1498, -1, -1, -1, 2308, 2309, 268, 269, 270, -1, 272, 273, 274, 275, 2318, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 1533, -1, -1, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, 7, 286, 287, -1, -1, 290, -1, -1, 1561, 1562, 1563, 296, 1565, -1, -1, -1, -1, -1, -1, -1, -1, 1339, -1, -1, -1, -1, 3, 4, 5, 1582, -1, 270, 271, 272, 273, 274, 275, 14, 15, 278, 279, 280, 281, 282, 283, 284, 285, 24, 25, 26, 27, 290, -1, 1371, -1, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 268, 269, 270, -1, 272, 273, 274, 275, -1, 7, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, -1, -1, -1, -1, -1, 1437, -1, -1, -1, -1, -1, -1, 1444, 1445, 1446, -1, -1, -1, -1, -1, -1, 1453, -1, 1455, 1456, -1, -1, 1459, -1, -1, 1462, 1463, -1, -1, -1, 1467, -1, -1, 1470, 1471, 1472, 1473, -1, -1, 1476, 1477, 1478, 1479, 1480, -1, 1482, 7, -1, -1, -1, -1, 1488, 1489, -1, -1, -1, 1493, 1494, -1, -1, -1, -1, -1, -1, 1501, -1, -1, -1, -1, -1, -1, -1, 1509, -1, -1, -1, -1, -1, -1, -1, 1517, -1, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, 1536, 286, 287, -1, 270, 290, 272, 273, 274, 275, -1, 296, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, 1797, -1, -1, -1, 296, -1, 1803, -1, -1, -1, -1, -1, -1, -1, -1, 1812, -1, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, -1, -1, -1, -1, -1, -1, 3, 4, 5, 6, -1, -1, -1, 1856, 281, -1, -1, 14, 15, -1, -1, 288, -1, -1, 291, -1, -1, -1, 1871, 296, -1, -1, -1, 300, -1, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, 7, 286, 287, -1, -1, 290, 1696, -1, 1698, 1699, 1700, 296, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1715, 1716, -1, -1, 1719, 1720, -1, 7, -1, -1, 1725, -1, 1727, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1737, -1, 1739, 1740, -1, -1, -1, 268, 269, 270, 1747, 272, 273, 274, 275, 1752, -1, 278, 279, 280, 281, 282, 283, 284, 1761, 286, 287, -1, -1, 290, -1, 272, 273, 274, 275, 296, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, 1785, 290, 1787, 1788, -1, -1, -1, 296, -1, 2029, -1, 2031, -1, -1, -1, -1, -1, -1, -1, -1, 2040, -1, -1, -1, -1, 1810, 1811, -1, -1, 3, 4, 5, 2052, -1, 1819, -1, -1, -1, -1, -1, 14, 15, -1, -1, 1829, 2065, -1, -1, 1833, -1, -1, -1, 2072, -1, 1839, 1840, -1, -1, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 2112, 67, 68, -1, -1, -1, -1, -1, 1885, -1, -1, 1888, 1889, 1890, 1891, 281, -1, -1, -1, -1, -1, -1, 288, -1, -1, 291, -1, -1, -1, -1, 296, -1, 1909, 1910, 1911, 1912, 1913, -1, -1, -1, -1, -1, -1, -1, -1, 5, -1, -1, -1, -1, -1, 11, 12, 13, -1, -1, 16, 17, 18, 125, 20, -1, 22, -1, -1, -1, -1, 133, -1, -1, 30, 31, -1, -1, 268, 269, 270, 2189, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, -1, -1, 1982, 268, 269, 270, 69, 272, 273, 274, 275, -1, 75, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, 86, -1, 290, 89, -1, -1, -1, -1, 296, 7, 2013, -1, -1, -1, 100, -1, -1, -1, 104, -1, 2023, 2024, 2025, 2026, -1, -1, -1, 2030, -1, 2032, 116, 2034, -1, -1, -1, 2038, -1, -1, -1, -1, -1, -1, -1, 2046, 2047, -1, -1, -1, 7, -1, 136, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 2066, 2067, 2068, 2069, -1, -1, -1, -1, 2074, 2075, 2076, -1, -1, -1, -1, -1, -1, -1, -1, 274, -1, -1, -1, -1, -1, 280, 281, -1, -1, -1, -1, -1, -1, 288, -1, -1, 291, -1, -1, 294, 295, 296, 297, -1, 299, 2111, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 209, 2127, 211, -1, -1, -1, -1, 2133, -1, -1, -1, 268, 269, 270, 271, 272, 273, 274, 275, -1, 2146, 278, 279, 280, 281, 282, 283, 284, 285, 2155, -1, 2157, -1, 290, -1, 292, -1, 2163, -1, 3, 4, 5, -1, -1, -1, -1, -1, -1, -1, -1, 14, 15, -1, -1, -1, -1, -1, -1, -1, -1, 24, 25, 26, 27, 2190, 2191, 2192, -1, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, -1, -1, 2228, -1, 2230, 2231, -1, -1, -1, -1, -1, 2237, 76, -1, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, 2251, 286, 287, 2254, -1, 290, -1, -1, -1, -1, -1, 296, -1, -1, -1, -1, -1, 2268, 2269, -1, -1, -1, 268, 269, 270, -1, 272, 273, 274, 275, -1, 2282, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 2298, -1, -1, 296, -1, -1, 2304, 2305, -1, -1, -1, -1, 2310, -1, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, 7, 286, 287, -1, 2333, 290, -1, -1, -1, 2338, -1, 296, -1, -1, -1, 2344, 2345, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 2358, -1, -1, -1, 2362, -1, -1, 3, 4, 5, -1, -1, -1, -1, -1, -1, -1, 2375, 14, 15, 2378, -1, 2380, 2381, -1, -1, -1, -1, -1, -1, -1, -1, -1, 2391, 2392, -1, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, -1, 67, 68, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 281, 7, -1, -1, -1, -1, -1, 288, -1, -1, 291, -1, -1, -1, -1, 296, -1, -1, 299, -1, -1, -1, -1, -1, 3, 4, 5, 6, -1, -1, 9, -1, -1, -1, -1, 14, 15, -1, -1, -1, -1, -1, -1, -1, 125, 24, 25, 26, 27, 28, -1, -1, 133, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, -1, 3, 4, 5, 6, -1, -1, 9, 10, -1, -1, 73, 14, 15, 76, -1, -1, -1, -1, -1, -1, -1, 24, 25, 26, 27, -1, -1, -1, -1, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, -1, -1, 268, 269, 270, 7, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, -1, -1, -1, 7, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 274, -1, -1, -1, -1, -1, 280, 281, -1, 3, 4, 5, 6, -1, 288, 9, -1, 291, -1, -1, 14, 15, 296, 297, -1, 299, -1, -1, -1, -1, 24, 25, 26, 27, 28, -1, -1, -1, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, -1, 268, 269, 270, -1, 272, 273, 274, 275, 7, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, 264, -1, -1, -1, -1, 296, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 281, -1, -1, -1, -1, -1, -1, 288, -1, -1, 291, -1, -1, -1, -1, 296, -1, -1, 299, -1, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, 264, 265, -1, -1, -1, 296, -1, 3, 4, 5, 301, -1, -1, -1, -1, -1, -1, 281, 14, 15, -1, -1, -1, -1, 288, -1, -1, 291, 24, 25, 26, 27, 296, -1, -1, 299, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, 7, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, 264, -1, -1, -1, -1, 296, -1, 3, 4, 5, 6, -1, -1, 9, 10, -1, -1, 281, 14, 15, -1, -1, -1, -1, 288, -1, -1, 291, -1, -1, -1, -1, 296, -1, -1, 299, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, -1, -1, -1, -1, -1, 3, 4, 5, -1, -1, -1, -1, -1, -1, -1, -1, 14, 15, -1, -1, -1, 232, -1, -1, -1, 236, 24, 25, 26, 27, -1, -1, -1, -1, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 3, 4, 5, -1, -1, -1, 281, -1, -1, -1, -1, 14, 15, 288, -1, -1, 291, -1, -1, -1, -1, 296, -1, -1, 299, -1, -1, -1, -1, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, -1, -1, -1, -1, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 264, 265, -1, -1, -1, -1, -1, 3, 4, 5, 6, -1, -1, -1, -1, -1, -1, 281, 14, 15, -1, -1, -1, -1, 288, -1, -1, 291, -1, -1, -1, -1, 296, -1, -1, 299, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 5, 7, -1, -1, -1, -1, 11, 12, 13, -1, -1, 16, 17, 18, -1, 20, -1, 268, 269, 270, 271, 272, 273, 274, 275, 30, 31, 278, 279, 280, 281, 282, 283, 284, 285, -1, 3, 4, 5, 290, -1, -1, -1, 294, -1, -1, 281, 14, 15, -1, -1, -1, -1, 288, -1, -1, 291, -1, -1, -1, -1, 296, -1, -1, 299, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 281, -1, -1, -1, -1, -1, -1, 288, -1, -1, 291, 292, -1, -1, -1, 296, -1, -1, 299, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, 5, -1, 217, -1, -1, 220, 11, 12, 13, 281, -1, 16, 17, 18, -1, 20, 288, -1, -1, 291, -1, -1, -1, -1, 296, 30, 31, 299, -1, 268, 269, 270, 271, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, 285, -1, -1, -1, -1, 290, 268, 269, 270, 294, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, 5, -1, -1, -1, -1, 296, 11, 12, 13, -1, 300, 16, 17, 18, -1, 20, -1, -1, -1, -1, -1, -1, -1, -1, -1, 30, 31, -1, -1, 281, -1, -1, -1, -1, -1, -1, 288, -1, -1, 291, -1, 7, -1, -1, 296, -1, -1, 299, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, -1, -1, 217, -1, -1, 220, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, 5, -1, 217, -1, -1, 220, 11, 12, 13, -1, 300, 16, 17, 18, -1, 20, 3, 4, 5, -1, -1, -1, -1, -1, -1, 30, 31, 14, 15, -1, -1, -1, -1, -1, -1, -1, -1, 24, 25, 26, 27, -1, -1, -1, -1, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 5, 7, -1, -1, -1, -1, 11, 12, 13, -1, 300, 16, 17, 18, 76, 20, -1, 268, 269, 270, -1, 272, 273, 274, 275, 30, 31, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 8, -1, -1, 296, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, -1, -1, 217, -1, -1, 220, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, 5, -1, 217, -1, -1, 220, 11, 12, 13, 281, 300, 16, 17, 18, -1, 20, 288, -1, -1, 291, -1, -1, -1, -1, 296, 30, 31, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, 5, -1, -1, -1, -1, 296, 11, 12, 13, -1, 300, 16, 17, 18, -1, 20, -1, 268, 269, 270, -1, 272, 273, 274, 275, 30, 31, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, 292, 8, -1, -1, 296, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, -1, -1, 217, -1, -1, 220, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, 5, -1, 217, -1, -1, 220, 11, 12, 13, -1, 300, 16, 17, 18, -1, 20, 3, 4, 5, -1, -1, -1, -1, -1, -1, 30, 31, 14, 15, -1, -1, -1, -1, -1, -1, -1, -1, 24, 25, 26, 27, -1, -1, -1, -1, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 5, 8, -1, -1, -1, -1, 11, 12, 13, -1, 300, 16, 17, 18, -1, 20, -1, 268, 269, 270, -1, 272, 273, 274, 275, 30, 31, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, 292, 8, -1, -1, 296, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, -1, -1, 217, -1, -1, 220, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, 5, -1, 217, -1, -1, 220, 11, 12, 13, 281, 300, 16, 17, 18, -1, 20, 288, -1, -1, 291, -1, -1, -1, -1, 296, 30, 31, 268, 269, 270, 271, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, 285, -1, -1, -1, -1, 290, 267, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, 5, -1, -1, -1, 296, -1, 11, 12, 13, -1, 300, 16, 17, 18, -1, 20, -1, 268, 269, 270, -1, 272, 273, 274, 275, 30, 31, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 8, -1, -1, 296, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, -1, -1, 217, -1, -1, 220, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, 5, -1, 217, -1, -1, 220, 11, 12, 13, -1, 300, 16, 17, 18, -1, 20, 3, 4, 5, -1, -1, -1, -1, -1, -1, 30, 31, 14, 15, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 5, 8, -1, -1, -1, -1, 11, 12, 13, -1, 300, 16, 17, 18, -1, 20, -1, 268, 269, 270, -1, 272, 273, 274, 275, 30, 31, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 8, -1, -1, 296, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, -1, -1, 217, -1, -1, 220, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, 5, -1, 217, -1, -1, 220, 11, 12, 13, 281, 300, 16, 17, 18, -1, 20, 288, -1, -1, 291, -1, -1, -1, -1, 296, 30, 31, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 8, -1, -1, -1, -1, -1, -1, -1, -1, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, 5, -1, -1, -1, 296, -1, 11, 12, 13, -1, 300, 16, 17, 18, -1, 20, -1, 268, 269, 270, -1, 272, 273, 274, 275, 30, 31, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, -1, -1, 217, -1, -1, 220, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, 5, -1, 217, -1, -1, 220, 11, 12, 13, -1, 300, 16, 17, 18, -1, 20, -1, 268, 269, 270, -1, 272, 273, 274, 275, 30, 31, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 5, -1, -1, -1, 301, -1, 11, 12, 13, -1, 300, 16, 17, 18, -1, 20, -1, 268, 269, 270, -1, 272, 273, 274, 275, 30, 31, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, -1, -1, -1, -1, 301, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, -1, -1, 217, -1, -1, 220, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, 5, -1, 217, -1, -1, 220, 11, 12, 13, -1, 300, 16, 17, 18, -1, 20, -1, 268, 269, 270, -1, 272, 273, 274, 275, 30, 31, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, -1, -1, -1, -1, 301, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, 5, -1, -1, -1, 296, -1, 11, 12, 13, 301, 300, 16, 17, 18, -1, 20, -1, 268, 269, 270, -1, 272, 273, 274, 275, 30, 31, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, -1, -1, -1, -1, 301, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, -1, -1, -1, 211, -1, -1, -1, -1, -1, 217, -1, -1, 220, 146, -1, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, -1, -1, -1, -1, -1, 173, 174, 175, -1, -1, 178, 179, 180, 181, -1, -1, 184, -1, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 82, -1, -1, 211, -1, -1, -1, -1, -1, 217, -1, -1, 220, -1, -1, -1, -1, 300, -1, 101, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, -1, 268, 269, 270, 301, 272, 273, 274, 275, 140, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, 300, 286, 287, -1, -1, 290, -1, -1, -1, -1, 184, 296, -1, 268, 269, 270, 301, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, -1, -1, -1, -1, 301, 221, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 232, 233, 234, 235, 236, 237, 238, 239, 240, -1, -1, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, 257, 258, 259, 260, 261, 262, 263, -1, -1, 266, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, 301, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 300, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, -1, -1, -1, 300, 267, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, 268, 269, 270, 296, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, 292, 268, 269, 270, 296, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, 292, 268, 269, 270, 296, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, 292, 268, 269, 270, 296, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, 292, 268, 269, 270, 296, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, 294, -1, 296, 268, 269, 270, -1, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, -1, 286, 287, -1, -1, 290, -1, -1, -1, -1, -1, 296, 268, 269, 270, 271, 272, 273, 274, 275, -1, -1, 278, 279, 280, 281, 282, 283, 284, 285, -1, -1, -1, -1, 290, -1, -1, -1, 294 }; /* YYSTOS[STATE-NUM] -- The (internal number of the) accessing symbol of state STATE-NUM. */ static const yytype_uint16 yystos[] = { 0, 305, 306, 0, 307, 308, 5, 11, 12, 13, 16, 17, 18, 20, 22, 30, 31, 69, 75, 86, 89, 100, 104, 116, 136, 209, 211, 309, 471, 483, 484, 502, 503, 303, 291, 293, 296, 503, 291, 293, 7, 5, 291, 291, 6, 9, 10, 264, 265, 503, 505, 506, 508, 293, 293, 299, 299, 299, 299, 299, 299, 299, 299, 299, 299, 503, 303, 267, 280, 281, 291, 299, 6, 6, 7, 7, 503, 503, 134, 3, 4, 5, 14, 15, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 281, 288, 291, 296, 496, 497, 503, 509, 510, 496, 291, 293, 291, 293, 293, 490, 493, 310, 364, 349, 355, 371, 328, 392, 418, 456, 467, 213, 299, 5, 6, 24, 25, 26, 27, 28, 264, 281, 299, 496, 498, 501, 508, 267, 267, 496, 499, 501, 496, 292, 301, 294, 301, 292, 294, 301, 299, 291, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 496, 496, 496, 5, 8, 268, 269, 270, 272, 273, 274, 275, 278, 279, 280, 281, 282, 283, 284, 286, 287, 290, 296, 292, 506, 506, 506, 506, 506, 507, 294, 301, 327, 294, 327, 70, 300, 311, 483, 503, 299, 300, 365, 483, 299, 300, 299, 300, 299, 300, 372, 483, 74, 300, 329, 483, 503, 299, 300, 393, 483, 299, 300, 419, 483, 299, 300, 457, 483, 299, 300, 468, 483, 503, 496, 291, 299, 7, 293, 293, 293, 293, 293, 291, 293, 496, 501, 300, 499, 8, 282, 283, 7, 280, 281, 282, 283, 290, 7, 498, 498, 292, 301, 300, 7, 499, 7, 499, 7, 293, 7, 496, 496, 496, 506, 503, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 292, 291, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 496, 301, 301, 292, 301, 294, 301, 294, 301, 7, 503, 7, 503, 505, 293, 267, 280, 366, 350, 356, 373, 293, 293, 394, 420, 458, 469, 472, 300, 292, 299, 300, 5, 5, 496, 496, 506, 506, 506, 300, 496, 496, 501, 496, 501, 496, 501, 501, 496, 501, 496, 501, 496, 7, 7, 267, 496, 501, 292, 294, 496, 300, 8, 292, 301, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, 301, 294, 294, 294, 294, 294, 294, 294, 294, 301, 301, 301, 294, 292, 8, 292, 8, 506, 506, 499, 499, 506, 267, 299, 325, 5, 73, 76, 296, 314, 317, 267, 87, 91, 101, 300, 367, 87, 101, 300, 351, 87, 93, 101, 300, 357, 75, 91, 101, 102, 110, 112, 300, 374, 483, 330, 5, 294, 296, 314, 316, 503, 5, 91, 101, 117, 300, 395, 101, 137, 144, 300, 421, 483, 101, 117, 138, 210, 300, 459, 101, 144, 212, 214, 215, 240, 300, 470, 299, 499, 294, 301, 301, 301, 294, 292, 294, 8, 498, 7, 7, 294, 7, 496, 506, 496, 496, 496, 496, 496, 496, 292, 294, 292, 294, 6, 299, 496, 496, 294, 327, 293, 3, 5, 291, 299, 302, 321, 323, 503, 7, 293, 314, 5, 299, 5, 503, 299, 503, 299, 23, 104, 282, 331, 332, 5, 299, 5, 503, 299, 299, 299, 294, 327, 267, 294, 299, 5, 503, 299, 503, 299, 422, 503, 299, 503, 503, 503, 299, 503, 506, 293, 5, 473, 300, 5, 496, 496, 7, 7, 7, 496, 7, 7, 8, 300, 294, 294, 294, 294, 294, 292, 6, 496, 300, 7, 503, 323, 8, 496, 501, 322, 501, 71, 318, 321, 7, 299, 368, 7, 7, 352, 7, 358, 293, 293, 282, 7, 335, 336, 7, 389, 7, 7, 375, 379, 386, 7, 5, 331, 267, 402, 7, 7, 396, 7, 423, 299, 7, 460, 7, 7, 7, 473, 7, 7, 496, 7, 300, 474, 292, 294, 301, 301, 496, 492, 491, 267, 299, 312, 3, 292, 292, 300, 327, 302, 315, 368, 299, 300, 483, 299, 300, 299, 300, 496, 5, 282, 5, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 67, 68, 125, 133, 274, 280, 281, 288, 291, 296, 297, 299, 337, 341, 417, 494, 495, 497, 503, 509, 510, 299, 300, 483, 299, 300, 483, 299, 300, 299, 300, 483, 299, 7, 331, 121, 122, 123, 124, 300, 403, 483, 299, 300, 483, 299, 300, 483, 430, 299, 300, 483, 300, 301, 216, 217, 218, 219, 475, 483, 496, 496, 300, 488, 486, 299, 496, 301, 8, 281, 323, 319, 327, 300, 369, 353, 359, 294, 294, 417, 293, 345, 293, 293, 293, 293, 342, 343, 5, 29, 337, 337, 337, 337, 3, 3, 5, 147, 236, 5, 503, 268, 269, 270, 271, 272, 273, 274, 275, 278, 279, 280, 281, 282, 283, 284, 285, 290, 296, 298, 293, 346, 346, 390, 376, 380, 387, 496, 7, 299, 299, 299, 299, 397, 424, 5, 18, 146, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 173, 174, 175, 178, 179, 180, 181, 184, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 211, 217, 220, 300, 432, 483, 461, 496, 293, 293, 293, 293, 294, 294, 300, 301, 489, 300, 301, 487, 326, 300, 321, 3, 323, 294, 5, 72, 320, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 91, 104, 300, 370, 76, 86, 300, 354, 87, 91, 92, 300, 360, 417, 293, 417, 337, 5, 5, 293, 293, 275, 293, 292, 503, 300, 338, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 337, 3, 496, 294, 295, 337, 347, 299, 348, 103, 113, 114, 115, 300, 391, 101, 103, 104, 105, 106, 107, 108, 109, 300, 377, 101, 103, 111, 300, 381, 91, 101, 103, 300, 388, 300, 408, 408, 412, 404, 86, 89, 91, 101, 118, 119, 120, 134, 208, 293, 300, 398, 91, 101, 138, 139, 140, 141, 142, 143, 300, 425, 483, 293, 503, 293, 293, 331, 293, 293, 293, 293, 293, 293, 293, 293, 293, 7, 293, 293, 293, 293, 293, 293, 293, 299, 293, 299, 293, 293, 293, 299, 293, 293, 299, 7, 7, 7, 293, 293, 293, 7, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 293, 433, 434, 82, 101, 300, 462, 301, 477, 503, 6, 477, 316, 6, 5, 5, 299, 313, 503, 321, 316, 316, 316, 316, 293, 331, 293, 331, 293, 331, 331, 299, 503, 5, 293, 331, 71, 316, 503, 299, 5, 5, 294, 335, 294, 301, 293, 294, 335, 335, 293, 337, 300, 337, 294, 294, 301, 76, 499, 503, 5, 317, 320, 503, 503, 503, 5, 299, 299, 333, 333, 316, 316, 5, 5, 299, 384, 5, 299, 382, 5, 503, 503, 86, 88, 89, 90, 125, 126, 127, 128, 129, 130, 131, 132, 134, 135, 300, 409, 416, 300, 134, 300, 413, 416, 91, 115, 299, 300, 405, 503, 5, 5, 112, 121, 503, 503, 496, 3, 316, 498, 400, 5, 503, 299, 426, 503, 506, 498, 506, 299, 428, 503, 503, 503, 7, 331, 331, 7, 503, 503, 503, 503, 503, 503, 503, 503, 503, 331, 503, 503, 503, 503, 503, 496, 445, 496, 447, 503, 496, 496, 449, 496, 506, 451, 316, 506, 506, 506, 506, 503, 503, 503, 299, 503, 503, 503, 503, 503, 503, 503, 503, 503, 503, 503, 503, 5, 503, 293, 293, 299, 503, 496, 222, 223, 224, 225, 226, 227, 228, 229, 230, 480, 293, 479, 301, 480, 476, 481, 299, 496, 505, 299, 498, 505, 3, 5, 324, 301, 7, 7, 7, 7, 331, 7, 331, 7, 331, 7, 7, 497, 7, 7, 331, 7, 7, 7, 348, 361, 7, 7, 301, 337, 344, 299, 294, 301, 335, 294, 8, 337, 293, 300, 7, 7, 7, 7, 7, 7, 299, 378, 5, 331, 334, 7, 7, 7, 7, 7, 385, 7, 383, 7, 7, 7, 7, 503, 331, 5, 293, 316, 7, 293, 316, 293, 5, 5, 406, 7, 7, 7, 7, 7, 7, 399, 7, 7, 7, 7, 335, 7, 7, 427, 7, 7, 7, 7, 429, 7, 7, 301, 431, 294, 294, 301, 301, 301, 301, 301, 301, 301, 294, 301, 294, 301, 431, 301, 294, 301, 301, 294, 301, 301, 144, 147, 168, 169, 170, 300, 446, 301, 144, 147, 168, 169, 171, 172, 300, 448, 301, 301, 301, 21, 93, 144, 176, 177, 300, 450, 301, 301, 21, 93, 137, 144, 145, 176, 182, 183, 300, 452, 301, 294, 294, 301, 294, 294, 301, 301, 301, 503, 504, 301, 301, 294, 301, 294, 294, 301, 301, 301, 301, 301, 301, 301, 301, 431, 333, 435, 503, 435, 463, 7, 294, 316, 316, 299, 316, 299, 299, 299, 299, 299, 481, 316, 280, 281, 282, 283, 301, 478, 264, 331, 481, 301, 294, 301, 482, 507, 485, 496, 300, 301, 321, 301, 301, 301, 327, 301, 7, 299, 300, 316, 294, 335, 496, 3, 294, 275, 339, 316, 117, 7, 327, 300, 301, 300, 327, 300, 327, 7, 7, 7, 3, 7, 410, 7, 414, 7, 7, 5, 134, 300, 407, 293, 401, 294, 300, 327, 300, 327, 496, 294, 299, 7, 331, 503, 503, 496, 496, 496, 503, 7, 331, 7, 316, 294, 496, 7, 496, 496, 7, 503, 496, 299, 331, 496, 496, 331, 496, 299, 331, 496, 496, 496, 496, 496, 496, 496, 496, 496, 299, 496, 331, 331, 506, 496, 496, 503, 299, 299, 496, 496, 299, 331, 7, 7, 496, 7, 7, 498, 498, 498, 300, 301, 496, 498, 7, 316, 7, 7, 503, 503, 496, 503, 503, 316, 316, 5, 294, 436, 436, 5, 121, 300, 483, 7, 231, 331, 299, 499, 299, 299, 299, 294, 294, 5, 293, 481, 294, 134, 7, 82, 101, 140, 184, 221, 232, 233, 234, 235, 236, 237, 238, 239, 240, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, 257, 258, 259, 260, 261, 262, 263, 266, 300, 300, 301, 267, 488, 3, 5, 301, 331, 331, 331, 497, 331, 362, 294, 294, 301, 294, 340, 337, 294, 5, 5, 331, 5, 5, 294, 335, 335, 417, 316, 503, 7, 7, 503, 503, 7, 430, 294, 301, 301, 301, 301, 301, 301, 294, 301, 7, 294, 294, 294, 431, 301, 430, 7, 7, 7, 7, 301, 430, 7, 7, 7, 7, 7, 301, 301, 301, 7, 7, 430, 7, 7, 301, 301, 7, 7, 7, 430, 430, 7, 7, 453, 294, 301, 294, 294, 294, 301, 301, 503, 301, 301, 431, 301, 301, 294, 431, 431, 431, 301, 294, 301, 7, 294, 301, 437, 294, 299, 299, 5, 301, 499, 300, 499, 499, 499, 7, 479, 506, 294, 7, 316, 498, 506, 498, 299, 5, 275, 276, 506, 496, 496, 498, 496, 496, 506, 5, 496, 5, 299, 496, 333, 299, 299, 299, 299, 3, 496, 496, 496, 506, 506, 506, 496, 506, 300, 496, 294, 294, 294, 300, 294, 94, 95, 96, 97, 98, 99, 300, 363, 294, 496, 293, 300, 7, 300, 7, 411, 415, 7, 7, 294, 300, 7, 498, 496, 498, 496, 496, 503, 7, 503, 7, 7, 7, 294, 331, 300, 331, 300, 496, 496, 331, 300, 442, 496, 300, 300, 299, 300, 7, 496, 7, 7, 7, 496, 299, 506, 506, 294, 496, 496, 7, 294, 294, 294, 506, 7, 139, 7, 232, 236, 498, 7, 464, 464, 299, 331, 300, 300, 300, 300, 301, 294, 7, 481, 331, 506, 506, 499, 496, 496, 496, 499, 267, 294, 7, 7, 7, 7, 7, 5, 496, 496, 496, 496, 496, 299, 300, 337, 116, 7, 301, 301, 19, 294, 294, 301, 301, 301, 301, 294, 7, 301, 301, 301, 301, 294, 301, 137, 211, 294, 301, 454, 301, 294, 504, 294, 294, 7, 301, 301, 7, 7, 7, 294, 301, 506, 506, 498, 86, 89, 91, 134, 300, 416, 465, 300, 496, 301, 299, 299, 299, 299, 481, 294, 301, 300, 301, 301, 301, 300, 506, 7, 7, 7, 7, 7, 7, 7, 496, 294, 5, 335, 417, 299, 7, 7, 496, 496, 496, 496, 7, 331, 496, 331, 496, 299, 496, 299, 299, 299, 496, 21, 91, 93, 104, 117, 134, 300, 455, 331, 7, 300, 7, 7, 496, 496, 7, 331, 294, 301, 503, 5, 5, 316, 293, 301, 331, 499, 499, 499, 499, 294, 7, 331, 496, 496, 496, 300, 299, 294, 294, 430, 294, 294, 294, 301, 294, 301, 301, 301, 430, 294, 443, 444, 430, 301, 5, 5, 496, 331, 5, 316, 294, 301, 294, 294, 294, 7, 496, 7, 7, 7, 7, 466, 496, 300, 300, 300, 300, 300, 7, 301, 301, 301, 301, 496, 7, 7, 300, 7, 7, 7, 498, 299, 496, 498, 496, 300, 299, 299, 300, 299, 300, 300, 496, 7, 7, 7, 7, 7, 7, 7, 498, 299, 299, 7, 294, 335, 300, 299, 299, 300, 299, 299, 331, 496, 496, 496, 300, 301, 430, 294, 301, 301, 430, 503, 503, 301, 301, 430, 430, 7, 294, 299, 498, 499, 299, 499, 499, 300, 300, 300, 300, 7, 496, 300, 299, 498, 506, 300, 301, 301, 498, 299, 300, 300, 7, 496, 301, 300, 496, 300, 300, 69, 301, 430, 301, 301, 496, 496, 301, 498, 500, 7, 7, 300, 498, 300, 300, 300, 299, 316, 496, 300, 498, 498, 301, 301, 498, 300, 301, 301, 299, 499, 7, 294, 294, 301, 496, 496, 301, 294, 498, 498, 496, 300, 136, 7, 7, 439, 301, 301, 498, 7, 300, 301, 300, 5, 137, 211, 301, 438, 5, 5, 294, 496, 299, 299, 299, 299, 496, 294, 5, 300, 299, 300, 496, 496, 440, 441, 301, 299, 300, 430, 301, 300, 299, 300, 299, 300, 496, 430, 300, 496, 7, 503, 503, 301, 300, 299, 301, 300, 301, 301, 496, 299, 430, 496, 496, 496, 430, 300, 300, 301, 301, 300, 496, 496, 301, 301, 5, 5, 300, 300 }; #define yyerrok (yyerrstatus = 0) #define yyclearin (yychar = YYEMPTY) #define YYEMPTY (-2) #define YYEOF 0 #define YYACCEPT goto yyacceptlab #define YYABORT goto yyabortlab #define YYERROR goto yyerrorlab /* Like YYERROR except do call yyerror. This remains here temporarily to ease the transition to the new meaning of YYERROR, for GCC. Once GCC version 2 has supplanted version 1, this can go. */ #define YYFAIL goto yyerrlab #define YYRECOVERING() (!!yyerrstatus) #define YYBACKUP(Token, Value) \ do \ if (yychar == YYEMPTY && yylen == 1) \ { \ yychar = (Token); \ yylval = (Value); \ yytoken = YYTRANSLATE (yychar); \ YYPOPSTACK (1); \ goto yybackup; \ } \ else \ { \ yyerror (YY_("syntax error: cannot back up")); \ YYERROR; \ } \ while (YYID (0)) #define YYTERROR 1 #define YYERRCODE 256 /* YYLLOC_DEFAULT -- Set CURRENT to span from RHS[1] to RHS[N]. If N is 0, then set CURRENT to the empty location which ends the previous symbol: RHS[0] (always defined). */ #define YYRHSLOC(Rhs, K) ((Rhs)[K]) #ifndef YYLLOC_DEFAULT # define YYLLOC_DEFAULT(Current, Rhs, N) \ do \ if (YYID (N)) \ { \ (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \ (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \ (Current).last_line = YYRHSLOC (Rhs, N).last_line; \ (Current).last_column = YYRHSLOC (Rhs, N).last_column; \ } \ else \ { \ (Current).first_line = (Current).last_line = \ YYRHSLOC (Rhs, 0).last_line; \ (Current).first_column = (Current).last_column = \ YYRHSLOC (Rhs, 0).last_column; \ } \ while (YYID (0)) #endif /* YY_LOCATION_PRINT -- Print the location on the stream. This macro was not mandated originally: define only if we know we won't break user code: when these are the locations we know. */ #ifndef YY_LOCATION_PRINT # if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL # define YY_LOCATION_PRINT(File, Loc) \ fprintf (File, "%d.%d-%d.%d", \ (Loc).first_line, (Loc).first_column, \ (Loc).last_line, (Loc).last_column) # else # define YY_LOCATION_PRINT(File, Loc) ((void) 0) # endif #endif /* YYLEX -- calling `yylex' with the right arguments. */ #ifdef YYLEX_PARAM # define YYLEX yylex (YYLEX_PARAM) #else # define YYLEX yylex () #endif /* Enable debugging if requested. */ #if YYDEBUG # ifndef YYFPRINTF # include /* INFRINGES ON USER NAME SPACE */ # define YYFPRINTF fprintf # endif # define YYDPRINTF(Args) \ do { \ if (yydebug) \ YYFPRINTF Args; \ } while (YYID (0)) # define YY_SYMBOL_PRINT(Title, Type, Value, Location) \ do { \ if (yydebug) \ { \ YYFPRINTF (stderr, "%s ", Title); \ yy_symbol_print (stderr, \ Type, Value); \ YYFPRINTF (stderr, "\n"); \ } \ } while (YYID (0)) /*--------------------------------. | Print this symbol on YYOUTPUT. | `--------------------------------*/ /*ARGSUSED*/ #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) static void yy_symbol_value_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep) #else static void yy_symbol_value_print (yyoutput, yytype, yyvaluep) FILE *yyoutput; int yytype; YYSTYPE const * const yyvaluep; #endif { if (!yyvaluep) return; # ifdef YYPRINT if (yytype < YYNTOKENS) YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); # else YYUSE (yyoutput); # endif switch (yytype) { default: break; } } /*--------------------------------. | Print this symbol on YYOUTPUT. | `--------------------------------*/ #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) static void yy_symbol_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep) #else static void yy_symbol_print (yyoutput, yytype, yyvaluep) FILE *yyoutput; int yytype; YYSTYPE const * const yyvaluep; #endif { if (yytype < YYNTOKENS) YYFPRINTF (yyoutput, "token %s (", yytname[yytype]); else YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]); yy_symbol_value_print (yyoutput, yytype, yyvaluep); YYFPRINTF (yyoutput, ")"); } /*------------------------------------------------------------------. | yy_stack_print -- Print the state stack from its BOTTOM up to its | | TOP (included). | `------------------------------------------------------------------*/ #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) static void yy_stack_print (yytype_int16 *bottom, yytype_int16 *top) #else static void yy_stack_print (bottom, top) yytype_int16 *bottom; yytype_int16 *top; #endif { YYFPRINTF (stderr, "Stack now"); for (; bottom <= top; ++bottom) YYFPRINTF (stderr, " %d", *bottom); YYFPRINTF (stderr, "\n"); } # define YY_STACK_PRINT(Bottom, Top) \ do { \ if (yydebug) \ yy_stack_print ((Bottom), (Top)); \ } while (YYID (0)) /*------------------------------------------------. | Report that the YYRULE is going to be reduced. | `------------------------------------------------*/ #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) static void yy_reduce_print (YYSTYPE *yyvsp, int yyrule) #else static void yy_reduce_print (yyvsp, yyrule) YYSTYPE *yyvsp; int yyrule; #endif { int yynrhs = yyr2[yyrule]; int yyi; unsigned long int yylno = yyrline[yyrule]; YYFPRINTF (stderr, "Reducing stack by rule %d (line %lu):\n", yyrule - 1, yylno); /* The symbols being reduced. */ for (yyi = 0; yyi < yynrhs; yyi++) { fprintf (stderr, " $%d = ", yyi + 1); yy_symbol_print (stderr, yyrhs[yyprhs[yyrule] + yyi], &(yyvsp[(yyi + 1) - (yynrhs)]) ); fprintf (stderr, "\n"); } } # define YY_REDUCE_PRINT(Rule) \ do { \ if (yydebug) \ yy_reduce_print (yyvsp, Rule); \ } while (YYID (0)) /* Nonzero means print parse trace. It is left uninitialized so that multiple parsers can coexist. */ int yydebug; #else /* !YYDEBUG */ # define YYDPRINTF(Args) # define YY_SYMBOL_PRINT(Title, Type, Value, Location) # define YY_STACK_PRINT(Bottom, Top) # define YY_REDUCE_PRINT(Rule) #endif /* !YYDEBUG */ /* YYINITDEPTH -- initial size of the parser's stacks. */ #ifndef YYINITDEPTH # define YYINITDEPTH 200 #endif /* YYMAXDEPTH -- maximum size the stacks can grow to (effective only if the built-in stack extension method is used). Do not make this value too large; the results are undefined if YYSTACK_ALLOC_MAXIMUM < YYSTACK_BYTES (YYMAXDEPTH) evaluated with infinite-precision integer arithmetic. */ #ifndef YYMAXDEPTH # define YYMAXDEPTH 10000 #endif #if YYERROR_VERBOSE # ifndef yystrlen # if defined __GLIBC__ && defined _STRING_H # define yystrlen strlen # else /* Return the length of YYSTR. */ #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) static YYSIZE_T yystrlen (const char *yystr) #else static YYSIZE_T yystrlen (yystr) const char *yystr; #endif { YYSIZE_T yylen; for (yylen = 0; yystr[yylen]; yylen++) continue; return yylen; } # endif # endif # ifndef yystpcpy # if defined __GLIBC__ && defined _STRING_H && defined _GNU_SOURCE # define yystpcpy stpcpy # else /* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in YYDEST. */ #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) static char * yystpcpy (char *yydest, const char *yysrc) #else static char * yystpcpy (yydest, yysrc) char *yydest; const char *yysrc; #endif { char *yyd = yydest; const char *yys = yysrc; while ((*yyd++ = *yys++) != '\0') continue; return yyd - 1; } # endif # endif # ifndef yytnamerr /* Copy to YYRES the contents of YYSTR after stripping away unnecessary quotes and backslashes, so that it's suitable for yyerror. The heuristic is that double-quoting is unnecessary unless the string contains an apostrophe, a comma, or backslash (other than backslash-backslash). YYSTR is taken from yytname. If YYRES is null, do not copy; instead, return the length of what the result would have been. */ static YYSIZE_T yytnamerr (char *yyres, const char *yystr) { if (*yystr == '"') { YYSIZE_T yyn = 0; char const *yyp = yystr; for (;;) switch (*++yyp) { case '\'': case ',': goto do_not_strip_quotes; case '\\': if (*++yyp != '\\') goto do_not_strip_quotes; /* Fall through. */ default: if (yyres) yyres[yyn] = *yyp; yyn++; break; case '"': if (yyres) yyres[yyn] = '\0'; return yyn; } do_not_strip_quotes: ; } if (! yyres) return yystrlen (yystr); return yystpcpy (yyres, yystr) - yyres; } # endif /* Copy into YYRESULT an error message about the unexpected token YYCHAR while in state YYSTATE. Return the number of bytes copied, including the terminating null byte. If YYRESULT is null, do not copy anything; just return the number of bytes that would be copied. As a special case, return 0 if an ordinary "syntax error" message will do. Return YYSIZE_MAXIMUM if overflow occurs during size calculation. */ static YYSIZE_T yysyntax_error (char *yyresult, int yystate, int yychar) { int yyn = yypact[yystate]; if (! (YYPACT_NINF < yyn && yyn <= YYLAST)) return 0; else { int yytype = YYTRANSLATE (yychar); YYSIZE_T yysize0 = yytnamerr (0, yytname[yytype]); YYSIZE_T yysize = yysize0; YYSIZE_T yysize1; int yysize_overflow = 0; enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 }; char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM]; int yyx; # if 0 /* This is so xgettext sees the translatable formats that are constructed on the fly. */ YY_("syntax error, unexpected %s"); YY_("syntax error, unexpected %s, expecting %s"); YY_("syntax error, unexpected %s, expecting %s or %s"); YY_("syntax error, unexpected %s, expecting %s or %s or %s"); YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s"); # endif char *yyfmt; char const *yyf; static char const yyunexpected[] = "syntax error, unexpected %s"; static char const yyexpecting[] = ", expecting %s"; static char const yyor[] = " or %s"; char yyformat[sizeof yyunexpected + sizeof yyexpecting - 1 + ((YYERROR_VERBOSE_ARGS_MAXIMUM - 2) * (sizeof yyor - 1))]; char const *yyprefix = yyexpecting; /* Start YYX at -YYN if negative to avoid negative indexes in YYCHECK. */ int yyxbegin = yyn < 0 ? -yyn : 0; /* Stay within bounds of both yycheck and yytname. */ int yychecklim = YYLAST - yyn + 1; int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS; int yycount = 1; yyarg[0] = yytname[yytype]; yyfmt = yystpcpy (yyformat, yyunexpected); for (yyx = yyxbegin; yyx < yyxend; ++yyx) if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR) { if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM) { yycount = 1; yysize = yysize0; yyformat[sizeof yyunexpected - 1] = '\0'; break; } yyarg[yycount++] = yytname[yyx]; yysize1 = yysize + yytnamerr (0, yytname[yyx]); yysize_overflow |= (yysize1 < yysize); yysize = yysize1; yyfmt = yystpcpy (yyfmt, yyprefix); yyprefix = yyor; } yyf = YY_(yyformat); yysize1 = yysize + yystrlen (yyf); yysize_overflow |= (yysize1 < yysize); yysize = yysize1; if (yysize_overflow) return YYSIZE_MAXIMUM; if (yyresult) { /* Avoid sprintf, as that infringes on the user's name space. Don't have undefined behavior even if the translation produced a string with the wrong number of "%s"s. */ char *yyp = yyresult; int yyi = 0; while ((*yyp = *yyf) != '\0') { if (*yyp == '%' && yyf[1] == 's' && yyi < yycount) { yyp += yytnamerr (yyp, yyarg[yyi++]); yyf += 2; } else { yyp++; yyf++; } } } return yysize; } } #endif /* YYERROR_VERBOSE */ /*-----------------------------------------------. | Release the memory associated to this symbol. | `-----------------------------------------------*/ /*ARGSUSED*/ #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) static void yydestruct (const char *yymsg, int yytype, YYSTYPE *yyvaluep) #else static void yydestruct (yymsg, yytype, yyvaluep) const char *yymsg; int yytype; YYSTYPE *yyvaluep; #endif { YYUSE (yyvaluep); if (!yymsg) yymsg = "Deleting"; YY_SYMBOL_PRINT (yymsg, yytype, yyvaluep, yylocationp); switch (yytype) { default: break; } } /* Prevent warnings from -Wmissing-prototypes. */ #ifdef YYPARSE_PARAM #if defined __STDC__ || defined __cplusplus int yyparse (void *YYPARSE_PARAM); #else int yyparse (); #endif #else /* ! YYPARSE_PARAM */ #if defined __STDC__ || defined __cplusplus int yyparse (void); #else int yyparse (); #endif #endif /* ! YYPARSE_PARAM */ /* The look-ahead symbol. */ int yychar; /* The semantic value of the look-ahead symbol. */ YYSTYPE yylval; /* Number of syntax errors so far. */ int yynerrs; /*----------. | yyparse. | `----------*/ #ifdef YYPARSE_PARAM #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) int yyparse (void *YYPARSE_PARAM) #else int yyparse (YYPARSE_PARAM) void *YYPARSE_PARAM; #endif #else /* ! YYPARSE_PARAM */ #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) int yyparse (void) #else int yyparse () #endif #endif { int yystate; int yyn; int yyresult; /* Number of tokens to shift before error messages enabled. */ int yyerrstatus; /* Look-ahead token as an internal (translated) token number. */ int yytoken = 0; #if YYERROR_VERBOSE /* Buffer for error messages, and its allocated size. */ char yymsgbuf[128]; char *yymsg = yymsgbuf; YYSIZE_T yymsg_alloc = sizeof yymsgbuf; #endif /* Three stacks and their tools: `yyss': related to states, `yyvs': related to semantic values, `yyls': related to locations. Refer to the stacks thru separate pointers, to allow yyoverflow to reallocate them elsewhere. */ /* The state stack. */ yytype_int16 yyssa[YYINITDEPTH]; yytype_int16 *yyss = yyssa; yytype_int16 *yyssp; /* The semantic value stack. */ YYSTYPE yyvsa[YYINITDEPTH]; YYSTYPE *yyvs = yyvsa; YYSTYPE *yyvsp; #define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N)) YYSIZE_T yystacksize = YYINITDEPTH; /* The variables used to return semantic value and location from the action routines. */ YYSTYPE yyval; /* The number of symbols on the RHS of the reduced rule. Keep to zero when no symbol should be popped. */ int yylen = 0; YYDPRINTF ((stderr, "Starting parse\n")); yystate = 0; yyerrstatus = 0; yynerrs = 0; yychar = YYEMPTY; /* Cause a token to be read. */ /* Initialize stack pointers. Waste one element of value and location stack so that they stay on the same level as the state stack. The wasted elements are never initialized. */ yyssp = yyss; yyvsp = yyvs; goto yysetstate; /*------------------------------------------------------------. | yynewstate -- Push a new state, which is found in yystate. | `------------------------------------------------------------*/ yynewstate: /* In all cases, when you get here, the value and location stacks have just been pushed. So pushing a state here evens the stacks. */ yyssp++; yysetstate: *yyssp = yystate; if (yyss + yystacksize - 1 <= yyssp) { /* Get the current used size of the three stacks, in elements. */ YYSIZE_T yysize = yyssp - yyss + 1; #ifdef yyoverflow { /* Give user a chance to reallocate the stack. Use copies of these so that the &'s don't force the real ones into memory. */ YYSTYPE *yyvs1 = yyvs; yytype_int16 *yyss1 = yyss; /* Each stack pointer address is followed by the size of the data in use in that stack, in bytes. This used to be a conditional around just the two extra args, but that might be undefined if yyoverflow is a macro. */ yyoverflow (YY_("memory exhausted"), &yyss1, yysize * sizeof (*yyssp), &yyvs1, yysize * sizeof (*yyvsp), &yystacksize); yyss = yyss1; yyvs = yyvs1; } #else /* no yyoverflow */ # ifndef YYSTACK_RELOCATE goto yyexhaustedlab; # else /* Extend the stack our own way. */ if (YYMAXDEPTH <= yystacksize) goto yyexhaustedlab; yystacksize *= 2; if (YYMAXDEPTH < yystacksize) yystacksize = YYMAXDEPTH; { yytype_int16 *yyss1 = yyss; union yyalloc *yyptr = (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize)); if (! yyptr) goto yyexhaustedlab; YYSTACK_RELOCATE (yyss); YYSTACK_RELOCATE (yyvs); # undef YYSTACK_RELOCATE if (yyss1 != yyssa) YYSTACK_FREE (yyss1); } # endif #endif /* no yyoverflow */ yyssp = yyss + yysize - 1; yyvsp = yyvs + yysize - 1; YYDPRINTF ((stderr, "Stack size increased to %lu\n", (unsigned long int) yystacksize)); if (yyss + yystacksize - 1 <= yyssp) YYABORT; } YYDPRINTF ((stderr, "Entering state %d\n", yystate)); goto yybackup; /*-----------. | yybackup. | `-----------*/ yybackup: /* Do appropriate processing given the current state. Read a look-ahead token if we need one and don't already have one. */ /* First try to decide what to do without reference to look-ahead token. */ yyn = yypact[yystate]; if (yyn == YYPACT_NINF) goto yydefault; /* Not known => get a look-ahead token if don't already have one. */ /* YYCHAR is either YYEMPTY or YYEOF or a valid look-ahead symbol. */ if (yychar == YYEMPTY) { YYDPRINTF ((stderr, "Reading a token: ")); yychar = YYLEX; } if (yychar <= YYEOF) { yychar = yytoken = YYEOF; YYDPRINTF ((stderr, "Now at end of input.\n")); } else { yytoken = YYTRANSLATE (yychar); YY_SYMBOL_PRINT ("Next token is", yytoken, &yylval, &yylloc); } /* If the proper action on seeing token YYTOKEN is to reduce or to detect an error, take that action. */ yyn += yytoken; if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken) goto yydefault; yyn = yytable[yyn]; if (yyn <= 0) { if (yyn == 0 || yyn == YYTABLE_NINF) goto yyerrlab; yyn = -yyn; goto yyreduce; } if (yyn == YYFINAL) YYACCEPT; /* Count tokens shifted since error; after three, turn off error status. */ if (yyerrstatus) yyerrstatus--; /* Shift the look-ahead token. */ YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc); /* Discard the shifted token unless it is eof. */ if (yychar != YYEOF) yychar = YYEMPTY; yystate = yyn; *++yyvsp = yylval; goto yynewstate; /*-----------------------------------------------------------. | yydefault -- do the default action for the current state. | `-----------------------------------------------------------*/ yydefault: yyn = yydefact[yystate]; if (yyn == 0) goto yyerrlab; goto yyreduce; /*-----------------------------. | yyreduce -- Do a reduction. | `-----------------------------*/ yyreduce: /* yyn is the number of a rule to reduce with. */ yylen = yyr2[yyn]; /* If YYLEN is nonzero, implement the default value of the action: `$$ = $1'. Otherwise, the following line sets YYVAL to garbage. This behavior is undocumented and Bison users should not rely upon it. Assigning to YYVAL unconditionally makes the parser a bit smaller, and it avoids a GCC warning that YYVAL may be used uninitialized. */ yyval = yyvsp[1-yylen]; YY_REDUCE_PRINT (yyn); switch (yyn) { case 2: #line 308 "ProParser.y" { Alloc_ParserVariables(); ;} break; case 5: #line 322 "ProParser.y" { Formulation_S.DefineQuantity = NULL; ;} break; case 19: #line 345 "ProParser.y" { strcpy(getdp_yyincludename, (yyvsp[(2) - (2)].c)); getdp_yyincludenum++; return(0); ;} break; case 22: #line 366 "ProParser.y" { Add_Group(&Group_S, (yyvsp[(1) - (4)].c), false, 0, 0); ;} break; case 23: #line 369 "ProParser.y" { Add_Group(&Group_S, (yyvsp[(1) - (5)].c), true, 0, 0); ;} break; case 24: #line 372 "ProParser.y" { int j = 0; if(List_Nbr((yyvsp[(5) - (5)].l)) == 1) List_Read((yyvsp[(5) - (5)].l), 0, &j); else vyyerror("Single region number expected for moving band definition"); Group_S.InitialList = List_Create(1, 1, sizeof(int)); List_Add(Group_S.InitialList, &j); Group_S.Type = MOVINGBAND2D; Group_S.FunctionType = REGION; Group_S.InitialSuppList = NULL; Group_S.SuppListType = SUPPLIST_NONE; Group_S.MovingBand2D = (struct MovingBand2D *)Malloc(sizeof(struct MovingBand2D)); Group_S.MovingBand2D->PhysNum = j; ;} break; case 25: #line 388 "ProParser.y" { Group_S.MovingBand2D->InitialList1 = (yyvsp[(8) - (8)].l); Group_S.MovingBand2D->ExtendedList1 = NULL; ;} break; case 26: #line 393 "ProParser.y" { Group_S.MovingBand2D->InitialList2 = (yyvsp[(11) - (15)].l); Group_S.MovingBand2D->Period2 = (int)(yyvsp[(13) - (15)].d); Add_Group(&Group_S, (yyvsp[(1) - (15)].c), false, 0, 0); ;} break; case 29: #line 407 "ProParser.y" { Group_S.FunctionType = (yyvsp[(1) - (3)].i); switch (Group_S.FunctionType) { case ELEMENTSOF : Group_S.Type = ELEMENTLIST; break; default : Group_S.Type = REGIONLIST; break; } Group_S.InitialList = (yyvsp[(3) - (3)].l); ;} break; case 30: #line 416 "ProParser.y" { Group_S.SuppListType = Type_SuppList; Group_S.InitialSuppList = (yyvsp[(5) - (6)].l); (yyval.i) = -1; ;} break; case 31: #line 424 "ProParser.y" { Group_S.FunctionType = REGION; Group_S.Type = REGIONLIST; Group_S.InitialList = (yyvsp[(2) - (2)].l); Group_S.SuppListType = SUPPLIST_NONE; Group_S.InitialSuppList = NULL; (yyval.i) = -1; ;} break; case 32: #line 435 "ProParser.y" { (yyval.i) = (yyvsp[(1) - (1)].i); ;} break; case 33: #line 440 "ProParser.y" { int i; if(!strcmp((yyvsp[(1) - (1)].c), "All")) { (yyval.i) = -3; } else if((i = List_ISearchSeq(Problem_S.Group, (yyvsp[(1) - (1)].c), fcmp_Group_Name)) >= 0) { List_Read(Problem_S.Group, i, &Group_S); (yyval.i) = i; } else { (yyval.i) = -2; vyyerror("Unknown Group: %s", (yyvsp[(1) - (1)].c)); } Free((yyvsp[(1) - (1)].c)); ;} break; case 34: #line 458 "ProParser.y" { (yyval.i) = REGION; ;} break; case 35: #line 461 "ProParser.y" { (yyval.i) = Get_DefineForString(FunctionForGroup_Type, (yyvsp[(1) - (1)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of Function for Group: %s", (yyvsp[(1) - (1)].c)); Get_Valid_SXD(FunctionForGroup_Type); } Free((yyvsp[(1) - (1)].c)); ;} break; case 36: #line 473 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (1)].l); ;} break; case 37: #line 474 "ProParser.y" { (yyval.l) = NULL; ;} break; case 38: #line 481 "ProParser.y" { Type_SuppList = SUPPLIST_NONE; (yyval.l) = NULL; ;} break; case 39: #line 484 "ProParser.y" { Type_SuppList = (yyvsp[(2) - (3)].i); (yyval.l) = (yyvsp[(3) - (3)].l); ;} break; case 40: #line 487 "ProParser.y" { int i; Type_SuppList = SUPPLIST_INSUPPORT; if((i = List_ISearchSeq(Problem_S.Group, (yyvsp[(3) - (3)].c), fcmp_Group_Name)) >= 0) { if(((struct Group *)List_Pointer(Problem_S.Group, i))->Type == ELEMENTLIST) { (yyval.l) = List_Create(1, 5, sizeof(int)); List_Add((yyval.l), &i); } else vyyerror("Not a Support of Element Type: %s", (yyvsp[(3) - (3)].c)); } else vyyerror("Unknown Region for Support: %s", (yyvsp[(3) - (3)].c)); Free((yyvsp[(3) - (3)].c)); ;} break; case 41: #line 506 "ProParser.y" { (yyval.i) = Get_DefineForString(FunctionForGroup_SuppList, (yyvsp[(1) - (1)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of Supplementary Region: %s", (yyvsp[(1) - (1)].c)); Get_Valid_SXD(FunctionForGroup_SuppList); } Free((yyvsp[(1) - (1)].c)); ;} break; case 42: #line 518 "ProParser.y" { (yyval.l) = List_Create(((List_Nbr((yyvsp[(1) - (1)].l)) > 0)? List_Nbr((yyvsp[(1) - (1)].l)) : 1), 5, sizeof(int)); for(int i = 0; i < List_Nbr((yyvsp[(1) - (1)].l)); i++) List_Add((yyval.l), (int *)List_Pointer((yyvsp[(1) - (1)].l), i)); ;} break; case 43: #line 525 "ProParser.y" { (yyval.l) = (yyvsp[(2) - (3)].l); ;} break; case 44: #line 531 "ProParser.y" { (yyval.l) = List_Create(5, 5, sizeof(int)); ;} break; case 45: #line 536 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (3)].l); for(int i = 0; i < List_Nbr((yyvsp[(3) - (3)].l)); i++) List_Add((yyval.l), (int *)List_Pointer((yyvsp[(3) - (3)].l), i)); ;} break; case 46: #line 543 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (4)].l); for(int i = 0; i < List_Nbr((yyvsp[(4) - (4)].l)); i++) List_Suppress((yyval.l), (int *)List_Pointer((yyvsp[(4) - (4)].l), i), fcmp_Integer); ;} break; case 47: #line 554 "ProParser.y" { List_Reset(ListOfInt_L); List_Add((yyval.l) = ListOfInt_L, &((yyvsp[(1) - (1)].i))); ;} break; case 48: #line 559 "ProParser.y" { List_Reset((yyval.l) = ListOfInt_L); for(int j = (yyvsp[(1) - (3)].i); ((yyvsp[(1) - (3)].i) < (yyvsp[(3) - (3)].i)) ? (j <= (yyvsp[(3) - (3)].i)) : (j >= (yyvsp[(3) - (3)].i)); ((yyvsp[(1) - (3)].i) < (yyvsp[(3) - (3)].i)) ? (j += 1) : (j -= 1)) List_Add(ListOfInt_L, &j); ;} break; case 49: #line 567 "ProParser.y" { List_Reset((yyval.l) = ListOfInt_L); if(!(yyvsp[(5) - (5)].i) || ((yyvsp[(1) - (5)].i) < (yyvsp[(3) - (5)].i) && (yyvsp[(5) - (5)].i) < 0) || ((yyvsp[(1) - (5)].i) > (yyvsp[(3) - (5)].i) && (yyvsp[(5) - (5)].i) > 0)){ vyyerror("Wrong increment in '%d : %d : %d'", (yyvsp[(1) - (5)].i), (yyvsp[(3) - (5)].i), (yyvsp[(5) - (5)].i)); List_Add(ListOfInt_L, &((yyvsp[(1) - (5)].i))); } else for(int j = (yyvsp[(1) - (5)].i); ((yyvsp[(5) - (5)].i) > 0) ? (j <= (yyvsp[(3) - (5)].i)) : (j >= (yyvsp[(3) - (5)].i)); j += (yyvsp[(5) - (5)].i)) List_Add((yyval.l), &j); ;} break; case 50: #line 579 "ProParser.y" { int i; if((i = List_ISearchSeq(Problem_S.Group, (yyvsp[(1) - (1)].c), fcmp_Group_Name)) < 0) { // Si ce n'est pas un nom de groupe, est-ce un nom de constante ? : Constant_S.Name = (yyvsp[(1) - (1)].c); if(!Tree_Query(ConstantTable_L, &Constant_S)) { vyyerror("Unknown Constant: %s", (yyvsp[(1) - (1)].c)); i = 0; List_Reset(ListOfInt_L); List_Add((yyval.l) = ListOfInt_L, &i); } else if(Constant_S.Type == VAR_FLOAT) { i = (int)Constant_S.Value.Float; List_Reset(ListOfInt_L); List_Add((yyval.l) = ListOfInt_L, &i); } else if(Constant_S.Type == VAR_LISTOFFLOAT) { List_Reset((yyval.l) = ListOfInt_L); for(int i = 0; i < List_Nbr(Constant_S.Value.ListOfFloat); i++) { double d; List_Read(Constant_S.Value.ListOfFloat, i, &d); int j = (int)d; List_Add(ListOfInt_L, &j); } } else { vyyerror("Unknown type of Constant: %s", (yyvsp[(1) - (1)].c)); i = 0; List_Reset(ListOfInt_L); List_Add((yyval.l) = ListOfInt_L, &i); } } else // Si c'est un nom de groupe : (yyval.l) = ((struct Group *)List_Pointer(Problem_S.Group, i))->InitialList; Free((yyvsp[(1) - (1)].c)); ;} break; case 51: #line 616 "ProParser.y" { int i = (int)(yyvsp[(2) - (3)].d); List_Reset(ListOfInt_L); List_Add((yyval.l) = ListOfInt_L, &i); ;} break; case 52: #line 623 "ProParser.y" { List_Reset(ListOfInt_L); for(int i = 0; i < List_Nbr((yyvsp[(2) - (3)].l)); i++) { double d; List_Read((yyvsp[(2) - (3)].l), i, &d); int j = (int)d; List_Add(ListOfInt_L, &j); } (yyval.l) = ListOfInt_L; ;} break; case 53: #line 637 "ProParser.y" { List_Reset(ListOfInt_L); for(int i = 0; i < List_Nbr((yyvsp[(2) - (3)].l)); i++) { double d; List_Read((yyvsp[(2) - (3)].l), i, &d); int j = (int)d; List_Add(ListOfInt_L, &j); } (yyval.l) = ListOfInt_L; ;} break; case 55: #line 656 "ProParser.y" { CharOptions_S["Strings"].push_back((yyvsp[(1) - (1)].c)); Free((yyvsp[(1) - (1)].c)); ;} break; case 56: #line 662 "ProParser.y" { char tmp[128]; sprintf(tmp, "%d", (yyvsp[(1) - (1)].i)); CharOptions_S["Strings"].push_back(tmp); ;} break; case 57: #line 669 "ProParser.y" { CharOptions_S["Strings"].push_back((yyvsp[(3) - (3)].c)); Free((yyvsp[(3) - (3)].c)); ;} break; case 58: #line 675 "ProParser.y" { char tmp[128]; sprintf(tmp, "%d", (yyvsp[(3) - (3)].i)); CharOptions_S["Strings"].push_back(tmp); ;} break; case 60: #line 687 "ProParser.y" { int i; if ( (i = List_ISearchSeq(Problem_S.Group, (yyvsp[(3) - (3)].c), fcmp_Group_Name)) < 0 ) { Group_S.Type = REGIONLIST ; Group_S.FunctionType = REGION ; Group_S.InitialList = List_Create( 5, 5, sizeof(int)) ; Group_S.SuppListType = SUPPLIST_NONE ; Group_S.InitialSuppList = NULL ; i = Add_Group(&Group_S, (yyvsp[(3) - (3)].c), false, 0, 0) ; } else Free((yyvsp[(3) - (3)].c)) ; ;} break; case 61: #line 699 "ProParser.y" { FloatOptions_S.clear(); CharOptions_S.clear(); ;} break; case 62: #line 701 "ProParser.y" { int i; if ( (i = List_ISearchSeq(Problem_S.Group, (yyvsp[(3) - (11)].c), fcmp_Group_Name)) < 0 ) { Group_S.Name = (yyvsp[(3) - (11)].c); // will be overwritten in Add_Group Group_S.Type = REGIONLIST ; Group_S.FunctionType = REGION ; Group_S.InitialList = List_Create( 5, 5, sizeof(int)) ; if(CharOptions_S.count("Strings")){ std::vector vec(CharOptions_S["Strings"]); for(unsigned int i = 0; i < vec.size(); i++) Fill_GroupInitialListFromString(Group_S.InitialList, vec[i].c_str()); } Message::ExchangeOnelabParameter(&Group_S, FloatOptions_S, CharOptions_S); Group_S.SuppListType = SUPPLIST_NONE ; Group_S.InitialSuppList = NULL ; i = Add_Group(&Group_S, (yyvsp[(3) - (11)].c), false, 0, 0) ; } else Free((yyvsp[(3) - (11)].c)) ; ;} break; case 63: #line 720 "ProParser.y" { for (int k = 0 ; k < (int)(yyvsp[(5) - (6)].d) ; k++) { char tmpstr[256]; sprintf(tmpstr, "%s_%d", (yyvsp[(3) - (6)].c), k+1) ; int i; if ( (i = List_ISearchSeq(Problem_S.Group, tmpstr, fcmp_Group_Name)) < 0 ) { Group_S.Type = REGIONLIST ; Group_S.FunctionType = REGION ; Group_S.SuppListType = SUPPLIST_NONE ; Group_S.InitialSuppList = NULL ; Group_S.InitialList = List_Create( 5, 5, sizeof(int)) ; Add_Group(&Group_S, (yyvsp[(3) - (6)].c), false, 2, k+1) ; } } Free((yyvsp[(3) - (6)].c)) ; ;} break; case 69: #line 756 "ProParser.y" { int i; if((i = List_ISearchSeq (Problem_S.Expression, (yyvsp[(1) - (6)].c), fcmp_Expression_Name)) >= 0) { if(((struct Expression *)List_Pointer(Problem_S.Expression, i))->Type == UNDEFINED_EXP) { Free(((struct Expression *)List_Pointer(Problem_S.Expression, i))->Name); List_Read (Problem_S.Expression, (yyvsp[(5) - (6)].i), &Expression_S); List_Write(Problem_S.Expression, i, &Expression_S); ((struct Expression *)List_Pointer(Problem_S.Expression, i))->Name = (yyvsp[(1) - (6)].c); List_Pop(Problem_S.Expression); } else { vyyerror("Redefinition of Function: %s", (yyvsp[(1) - (6)].c)); } } else { /* new identifier */ Free(((struct Expression *)List_Pointer(Problem_S.Expression, (yyvsp[(5) - (6)].i)))->Name); ((struct Expression *)List_Pointer(Problem_S.Expression, (yyvsp[(5) - (6)].i)))->Name = (yyvsp[(1) - (6)].c); } ;} break; case 70: #line 777 "ProParser.y" { int i; if((i = List_ISearchSeq (Problem_S.Expression, (yyvsp[(1) - (7)].c), fcmp_Expression_Name)) < 0) { /* Si le nom n'existe pas : */ i = List_Nbr(Problem_S.Expression); Expression_S.Type = PIECEWISEFUNCTION; Expression_S.Case.PieceWiseFunction.ExpressionPerRegion = List_Create(5, 5, sizeof(struct ExpressionPerRegion)); Expression_S.Case.PieceWiseFunction.NumLastRegion = -1; Add_Expression(&Expression_S, (yyvsp[(1) - (7)].c), 0); Expression_P = (struct Expression*)List_Pointer(Problem_S.Expression, i); } else { Expression_P = (struct Expression*)List_Pointer(Problem_S.Expression, i); if(Expression_P->Type == UNDEFINED_EXP) { Expression_P->Type = PIECEWISEFUNCTION; Expression_P->Case.PieceWiseFunction.ExpressionPerRegion = List_Create(5, 5, sizeof(struct ExpressionPerRegion)); Expression_P->Case.PieceWiseFunction.NumLastRegion = -1; } else if(Expression_P->Type != PIECEWISEFUNCTION) vyyerror("Not piece-wise Expression: %s", (yyvsp[(1) - (7)].c)); Free((yyvsp[(1) - (7)].c)); } if((yyvsp[(3) - (7)].i) >= 0 || (yyvsp[(3) - (7)].i) == -1) { ExpressionPerRegion_S.ExpressionIndex = (yyvsp[(6) - (7)].i); for(int i = 0; i < List_Nbr(Group_S.InitialList); i++) { List_Read(Group_S.InitialList, i, &ExpressionPerRegion_S.RegionIndex); if(List_Search(Expression_P->Case.PieceWiseFunction.ExpressionPerRegion, &ExpressionPerRegion_S.RegionIndex, fcmp_Integer)) vyyerror("Redefinition of piece-wise Function: %s [%d]", Expression_P->Name, ExpressionPerRegion_S.RegionIndex); else List_Add(Expression_P->Case.PieceWiseFunction.ExpressionPerRegion, &ExpressionPerRegion_S); } if((yyvsp[(3) - (7)].i) == -1) { List_Delete(Group_S.InitialList); } } else vyyerror("Bad Group right hand side"); ;} break; case 73: #line 829 "ProParser.y" { int i; if ( (i = List_ISearchSeq (Problem_S.Expression, (yyvsp[(3) - (3)].c), fcmp_Expression_Name)) < 0 ) { Expression_S.Type = UNDEFINED_EXP ; Add_Expression(&Expression_S, (yyvsp[(3) - (3)].c), 0) ; } else Free((yyvsp[(3) - (3)].c)) ; ;} break; case 74: #line 840 "ProParser.y" { for (int k = 0 ; k < (int)(yyvsp[(5) - (6)].d) ; k++) { char tmpstr[256]; sprintf(tmpstr, "%s_%d", (yyvsp[(3) - (6)].c), k+1) ; int i; if ( (i = List_ISearchSeq(Problem_S.Expression, tmpstr, fcmp_Expression_Name)) < 0 ) { Expression_S.Type = UNDEFINED_EXP ; Add_Expression(&Expression_S, tmpstr, 2) ; } } Free((yyvsp[(3) - (6)].c)) ; ;} break; case 75: #line 864 "ProParser.y" { Expression_S.Type = CONSTANT; Expression_S.Case.Constant = (yyvsp[(3) - (4)].d); (yyval.i) = Add_Expression(&Expression_S, (char*)"Exp_Cst", 1); ;} break; case 76: #line 870 "ProParser.y" { int i; if((i = List_ISearchSeq(Problem_S.Expression, (yyvsp[(3) - (4)].c), fcmp_Expression_Name)) < 0) vyyerror("Unknown name of Expression: %s", (yyvsp[(3) - (4)].c)); Free((yyvsp[(3) - (4)].c)); (yyval.i) = i; ;} break; case 77: #line 877 "ProParser.y" { Current_DofIndexInWholeQuantity = -2; List_Reset(ListOfPointer_L); List_Reset(ListOfPointer2_L); ;} break; case 78: #line 880 "ProParser.y" { Expression_S.Type = WHOLEQUANTITY; Expression_S.Case.WholeQuantity = (yyvsp[(2) - (2)].l); (yyval.i) = Add_Expression(&Expression_S, (char*)"Exp_Fct", 1); ;} break; case 79: #line 885 "ProParser.y" { Expression_S.Type = UNDEFINED_EXP; (yyval.i) = Add_Expression(&Expression_S, (char*)"Exp_Undefined", 1); ;} break; case 80: #line 892 "ProParser.y" { List_Reset(ListOfInt_L); ;} break; case 82: #line 903 "ProParser.y" { List_Reset(ListOfInt_L); List_Add(ListOfInt_L, &((yyvsp[(1) - (1)].i))); ;} break; case 83: #line 906 "ProParser.y" { List_Add(ListOfInt_L, &((yyvsp[(3) - (3)].i))); ;} break; case 84: #line 912 "ProParser.y" { Current_WholeQuantity_L = List_Create(5, 5, sizeof(struct WholeQuantity)); List_Add(ListOfPointer_L, &Current_WholeQuantity_L); ;} break; case 85: #line 916 "ProParser.y" { (yyval.l) = *((List_T **)List_Pointer(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1)); List_Pop(ListOfPointer_L); ;} break; case 87: #line 928 "ProParser.y" { WholeQuantity_S.Type = WQ_TEST; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); WholeQuantity_P = (struct WholeQuantity*) List_Pointer(Current_WholeQuantity_L, List_Nbr(Current_WholeQuantity_L)-1); List_Add(ListOfPointer2_L, &WholeQuantity_P); List_Add(ListOfPointer2_L, &WholeQuantity_P); Current_WholeQuantity_L = List_Create(5, 5, sizeof(struct WholeQuantity)); List_Add(ListOfPointer_L, &Current_WholeQuantity_L); ;} break; case 88: #line 941 "ProParser.y" { WholeQuantity_P = *((struct WholeQuantity**) List_Pointer(ListOfPointer2_L, List_Nbr(ListOfPointer2_L)-1)); List_Pop(ListOfPointer2_L); WholeQuantity_P->Case.Test.WholeQuantity_True = *((List_T **)List_Pointer(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1)); List_Pop(ListOfPointer_L); Current_WholeQuantity_L = List_Create(5, 5, sizeof(struct WholeQuantity)); List_Add(ListOfPointer_L, &Current_WholeQuantity_L); ;} break; case 89: #line 955 "ProParser.y" { WholeQuantity_P = *((struct WholeQuantity**) List_Pointer(ListOfPointer2_L, List_Nbr(ListOfPointer2_L)-1)); List_Pop(ListOfPointer2_L); WholeQuantity_P->Case.Test.WholeQuantity_False = *((List_T **)List_Pointer(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1)); List_Pop(ListOfPointer_L); List_Read(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1, &Current_WholeQuantity_L); ;} break; case 90: #line 970 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_TIME; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_ProductValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 91: #line 978 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_CROSSPRODUCT; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_CrossProductValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 92: #line 986 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_CROSSPRODUCT; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_CrossProductValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 93: #line 994 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_DIVIDE; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_DivideValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 94: #line 1002 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_PLUS; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_AddValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 95: #line 1010 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_MINUS; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_SubstractValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 96: #line 1018 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_MODULO; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_ModuloValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 97: #line 1026 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_POWER; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_PowerValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 98: #line 1034 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_LESS; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_LessValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 99: #line 1042 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_GREATER; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_GreaterValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 100: #line 1050 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_LESSOREQUAL; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_LessOrEqualValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 101: #line 1058 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_GREATEROREQUAL; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_GreaterOrEqualValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 102: #line 1066 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_EQUAL; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_EqualValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 103: #line 1074 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_NOTEQUAL; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_NotEqualValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 104: #line 1082 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_APPROXEQUAL; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_ApproxEqualValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 105: #line 1090 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_AND; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_AndValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 106: #line 1098 "ProParser.y" { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_OR; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_OrValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 107: #line 1107 "ProParser.y" { WholeQuantity_S.Type = WQ_UNARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_NEG; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_NegValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 109: #line 1117 "ProParser.y" { WholeQuantity_S.Type = WQ_UNARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_NOT; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_NotValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 110: #line 1125 "ProParser.y" { WholeQuantity_S.Type = WQ_CHANGECURRENTPOSITION ; List_Add(Current_WholeQuantity_L, &WholeQuantity_S) ; WholeQuantity_P = (struct WholeQuantity*) List_Pointer(Current_WholeQuantity_L, List_Nbr(Current_WholeQuantity_L)-1); List_Add(ListOfPointer2_L, &WholeQuantity_P); Current_WholeQuantity_L = List_Create( 5, 5, sizeof(struct WholeQuantity)) ; List_Add(ListOfPointer_L, &Current_WholeQuantity_L) ; ;} break; case 111: #line 1137 "ProParser.y" { WholeQuantity_P = *((struct WholeQuantity**) List_Pointer(ListOfPointer2_L, List_Nbr(ListOfPointer2_L)-1)) ; List_Pop(ListOfPointer2_L) ; WholeQuantity_P->Case.ChangeCurrentPosition.WholeQuantity = *((List_T **)List_Pointer(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1)) ; List_Pop(ListOfPointer_L) ; List_Read(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1, &Current_WholeQuantity_L) ; ;} break; case 113: #line 1158 "ProParser.y" { WholeQuantity_S.Type = WQ_CONSTANT; WholeQuantity_S.Case.Constant = (yyvsp[(1) - (1)].d); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 114: #line 1164 "ProParser.y" { /* Expression */ int l; if((l = List_ISearchSeq(Problem_S.Expression, (yyvsp[(1) - (3)].c), fcmp_Expression_Name)) >= 0) { WholeQuantity_S.Type = WQ_EXPRESSION; WholeQuantity_S.Case.Expression.Index = l; WholeQuantity_S.Case.Expression.NbrArguments = (yyvsp[(2) - (3)].i); if((yyvsp[(2) - (3)].i) < 0) vyyerror("Uncompatible argument for Function: %s", (yyvsp[(1) - (3)].c)); } /* Built in functions */ else { Get_Function2NbrForString(F_Function, (yyvsp[(1) - (3)].c), &FlagError, &WholeQuantity_S.Case.Function.Fct, &WholeQuantity_S.Case.Function.NbrParameters, &WholeQuantity_S.Case.Function.NbrArguments); WholeQuantity_S.Case.Function.Active = NULL; if(!FlagError) { /* arguments */ if((yyvsp[(2) - (3)].i) >= 0) { if((yyvsp[(2) - (3)].i) == WholeQuantity_S.Case.Function.NbrArguments) { WholeQuantity_S.Type = WQ_BUILTINFUNCTION; } else if(WholeQuantity_S.Case.Function.NbrArguments == -1 || (WholeQuantity_S.Case.Function.NbrArguments == -2)) { /* && ($2)%2 == 0)) { */ WholeQuantity_S.Type = WQ_BUILTINFUNCTION; WholeQuantity_S.Case.Function.NbrArguments = (yyvsp[(2) - (3)].i); } else { vyyerror("Wrong number of arguments for Function '%s' (%d instead of %d)", (yyvsp[(1) - (3)].c), (yyvsp[(2) - (3)].i), WholeQuantity_S.Case.Function.NbrArguments); } } else { WholeQuantity_S.Type = WQ_EXTERNBUILTINFUNCTION; } /* parameters */ if(WholeQuantity_S.Case.Function.NbrParameters >= 0 && WholeQuantity_S.Case.Function.NbrParameters != List_Nbr((yyvsp[(3) - (3)].l))) { vyyerror("Wrong number of parameters for Function '%s' (%d instead of %d)", (yyvsp[(1) - (3)].c), List_Nbr((yyvsp[(3) - (3)].l)), WholeQuantity_S.Case.Function.NbrParameters); } else if(WholeQuantity_S.Case.Function.NbrParameters == -2 && List_Nbr((yyvsp[(3) - (3)].l))%2 != 0) { vyyerror("Wrong number of parameters for Function '%s' (%d is not even)", (yyvsp[(1) - (3)].c), List_Nbr((yyvsp[(3) - (3)].l))); } else { WholeQuantity_S.Case.Function.NbrParameters = List_Nbr((yyvsp[(3) - (3)].l)); if(WholeQuantity_S.Case.Function.NbrParameters > 0) { WholeQuantity_S.Case.Function.Para = (double *)Malloc (WholeQuantity_S.Case.Function.NbrParameters * sizeof(double)); for(int i = 0; i < WholeQuantity_S.Case.Function.NbrParameters; i++) List_Read((yyvsp[(3) - (3)].l), i, &WholeQuantity_S.Case.Function.Para[i]); } } } else { vyyerror("Unknown Function: %s", (yyvsp[(1) - (3)].c)); } } List_Add(Current_WholeQuantity_L, &WholeQuantity_S); List_Delete((yyvsp[(3) - (3)].l)); ;} break; case 115: #line 1239 "ProParser.y" { WholeQuantity_S.Type = WQ_OPERATORANDQUANTITY; WholeQuantity_S.Case.OperatorAndQuantity.NbrArguments = 0; WholeQuantity_S.Case.OperatorAndQuantity.TypeQuantity = Get_DefineForString(QuantityFromFS_Type, (yyvsp[(1) - (2)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of discrete Quantity: %s", (yyvsp[(1) - (2)].c)); Get_Valid_SXD(QuantityFromFS_Type); } Free((yyvsp[(1) - (2)].c)); WholeQuantity_S.Case.OperatorAndQuantity.TypeOperator = (yyvsp[(2) - (2)].t).Int1; WholeQuantity_S.Case.OperatorAndQuantity.Index = (yyvsp[(2) - (2)].t).Int2; switch(WholeQuantity_S.Case.OperatorAndQuantity.TypeQuantity) { case QUANTITY_DOF : if(Current_DofIndexInWholeQuantity == -1) Current_DofIndexInWholeQuantity = List_Nbr(Current_WholeQuantity_L); else if(Current_DofIndexInWholeQuantity == -2) vyyerror("Dof{} definition out of context"); else vyyerror("More than one Dof definition in Expression"); break; case QUANTITY_NODOF : if(Current_DofIndexInWholeQuantity == -2) vyyerror("NoDof definition out of context"); else if(Current_NoDofIndexInWholeQuantity == -1) Current_NoDofIndexInWholeQuantity = List_Nbr(Current_WholeQuantity_L); else vyyerror("More than one NoDof definition in Expression"); break; } List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 116: #line 1273 "ProParser.y" { WholeQuantity_S.Type = WQ_OPERATORANDQUANTITY; WholeQuantity_S.Case.OperatorAndQuantity.NbrArguments = 0; WholeQuantity_S.Case.OperatorAndQuantity.TypeQuantity = QUANTITY_SIMPLE; WholeQuantity_S.Case.OperatorAndQuantity.TypeOperator = (yyvsp[(1) - (1)].t).Int1; WholeQuantity_S.Case.OperatorAndQuantity.Index = (yyvsp[(1) - (1)].t).Int2; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 117: #line 1282 "ProParser.y" { if((yyvsp[(2) - (2)].i) != 1 && (yyvsp[(2) - (2)].i) != 2 && (yyvsp[(2) - (2)].i) != 3 && (yyvsp[(2) - (2)].i) != 4) vyyerror("Wrong number of arguments for discrete quantity evaluation (%d)", (yyvsp[(2) - (2)].i)); WholeQuantity_S.Type = WQ_OPERATORANDQUANTITYEVAL; WholeQuantity_S.Case.OperatorAndQuantity.NbrArguments = (yyvsp[(2) - (2)].i); WholeQuantity_S.Case.OperatorAndQuantity.TypeQuantity = QUANTITY_SIMPLE; WholeQuantity_S.Case.OperatorAndQuantity.TypeOperator = (yyvsp[(1) - (2)].t).Int1; WholeQuantity_S.Case.OperatorAndQuantity.Index = (yyvsp[(1) - (2)].t).Int2; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 118: #line 1294 "ProParser.y" { Last_DofIndexInWholeQuantity = Current_DofIndexInWholeQuantity; ;} break; case 119: #line 1296 "ProParser.y" { WholeQuantity_S.Type = WQ_TIMEDERIVATIVE; WholeQuantity_S.Case.TimeDerivative.WholeQuantity = (yyvsp[(4) - (5)].l); List_Read(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1, &Current_WholeQuantity_L); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); if(Current_DofIndexInWholeQuantity != Last_DofIndexInWholeQuantity) vyyerror("Dof{} definition out of context"); ;} break; case 120: #line 1308 "ProParser.y" { Last_DofIndexInWholeQuantity = Current_DofIndexInWholeQuantity; ;} break; case 121: #line 1310 "ProParser.y" { WholeQuantity_S.Type = WQ_ATANTERIORTIMESTEP; WholeQuantity_S.Case.AtAnteriorTimeStep.WholeQuantity = (yyvsp[(4) - (7)].l); WholeQuantity_S.Case.AtAnteriorTimeStep.TimeStep = (yyvsp[(6) - (7)].i); List_Read(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1, &Current_WholeQuantity_L); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); if(Current_DofIndexInWholeQuantity != Last_DofIndexInWholeQuantity) vyyerror("Dof{} definition out of context"); ;} break; case 122: #line 1322 "ProParser.y" { Last_DofIndexInWholeQuantity = Current_DofIndexInWholeQuantity; ;} break; case 123: #line 1324 "ProParser.y" { int i; if((i = List_ISearchSeq(Problem_S.Expression, (yyvsp[(3) - (11)].c),fcmp_Expression_Name)) < 0) vyyerror("Undefined function '%s' used in MHTransform", (yyvsp[(3) - (11)].c)); if(Current_DofIndexInWholeQuantity != Last_DofIndexInWholeQuantity) vyyerror("Dof{} definition cannot be used in MHTransform"); WholeQuantity_S.Type = WQ_MHTRANSFORM; WholeQuantity_S.Case.MHTransform.Index = i; WholeQuantity_S.Case.MHTransform.WholeQuantity = (yyvsp[(6) - (11)].l); WholeQuantity_S.Case.MHTransform.NbrPoints = (int)(yyvsp[(10) - (11)].d); List_Read(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1, &Current_WholeQuantity_L); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 124: #line 1339 "ProParser.y" { int i; if((i = List_ISearchSeq(Problem_S.Expression, (yyvsp[(3) - (9)].c),fcmp_Expression_Name)) < 0) vyyerror("Undefined function '%s' used in MHJacNL", (yyvsp[(3) - (9)].c)); WholeQuantity_S.Type = WQ_MHJACNL; WholeQuantity_S.Case.MHJacNL.Index = i; WholeQuantity_S.Case.MHJacNL.NbrPoints = (int)(yyvsp[(6) - (9)].d); WholeQuantity_S.Case.MHJacNL.FreqOffSet = (int)(yyvsp[(8) - (9)].d); List_Read(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1, &Current_WholeQuantity_L); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 125: #line 1352 "ProParser.y" { WholeQuantity_S.Type = WQ_SOLIDANGLE; WholeQuantity_S.Case.OperatorAndQuantity.Index = (yyvsp[(3) - (4)].t).Int2; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 126: #line 1358 "ProParser.y" { WholeQuantity_S.Type = WQ_ORDER; WholeQuantity_S.Case.OperatorAndQuantity.Index = (yyvsp[(3) - (4)].t).Int2; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 127: #line 1364 "ProParser.y" { Last_DofIndexInWholeQuantity = Current_DofIndexInWholeQuantity; ;} break; case 128: #line 1366 "ProParser.y" { WholeQuantity_S.Type = WQ_TRACE; WholeQuantity_S.Case.Trace.WholeQuantity = (yyvsp[(4) - (7)].l); WholeQuantity_S.Case.Trace.InIndex = Num_Group(&Group_S, (char*)"WQ_Trace_In", (yyvsp[(6) - (7)].i)); if(Group_S.Type != ELEMENTLIST || Group_S.SuppListType != SUPPLIST_CONNECTEDTO) vyyerror("Group for Trace should be of Type 'ElementsOf[x, ConnectedTo y]'"); WholeQuantity_S.Case.Trace.DofIndexInWholeQuantity = -1; if(Current_DofIndexInWholeQuantity != Last_DofIndexInWholeQuantity){ for(int i = 0; i < List_Nbr((yyvsp[(4) - (7)].l)); i++){ WholeQuantity_P = (struct WholeQuantity*)List_Pointer((yyvsp[(4) - (7)].l), i); if(WholeQuantity_P->Type == WQ_OPERATORANDQUANTITY) if(WholeQuantity_P->Case.OperatorAndQuantity.TypeQuantity == QUANTITY_DOF){ WholeQuantity_S.Case.Trace.DofIndexInWholeQuantity = i; Current_DofIndexInWholeQuantity = -4; TypeOperatorDofInTrace = WholeQuantity_P->Case.OperatorAndQuantity.TypeOperator; DefineQuantityIndexDofInTrace = WholeQuantity_P->Case.OperatorAndQuantity.Index; } } if(Current_DofIndexInWholeQuantity != -4) vyyerror("Dof{} definition out of context in Trace operator"); } List_Read(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1, &Current_WholeQuantity_L); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 129: #line 1395 "ProParser.y" { WholeQuantity_S.Type = WQ_CAST; WholeQuantity_S.Case.Cast.WholeQuantity = (yyvsp[(5) - (6)].l); int i; if((i = List_ISearchSeq(Formulation_S.DefineQuantity, (yyvsp[(2) - (6)].c), fcmp_DefineQuantity_Name)) < 0) { if(!strcmp((yyvsp[(2) - (6)].c), "Real")) WholeQuantity_S.Case.Cast.NbrHar = 1; else if(!strcmp((yyvsp[(2) - (6)].c), "Complex")) WholeQuantity_S.Case.Cast.NbrHar = 2; else vyyerror("Unknown Cast: %s", (yyvsp[(2) - (6)].c)); } else { WholeQuantity_S.Case.Cast.NbrHar = 0; WholeQuantity_S.Case.Cast.FunctionSpaceIndexForType = ((struct DefineQuantity *)List_Pointer(Formulation_S.DefineQuantity, i)) ->FunctionSpaceIndex; } Free((yyvsp[(2) - (6)].c)); List_Read(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1, &Current_WholeQuantity_L); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 130: #line 1421 "ProParser.y" { WholeQuantity_S.Type = WQ_CURRENTVALUE; Get_PointerForString(Current_Value, (yyvsp[(2) - (2)].c), &FlagError, (void **)&WholeQuantity_S.Case.CurrentValue.Value); if(FlagError){ vyyerror("Unknown current value: $%s", (yyvsp[(2) - (2)].c)); Get_Valid_SXP(Current_Value); } Free((yyvsp[(2) - (2)].c)); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 131: #line 1434 "ProParser.y" { WholeQuantity_S.Type = WQ_CURRENTVALUE; Get_PointerForString(Current_Value, "TimeStep", &FlagError, (void **)&WholeQuantity_S.Case.CurrentValue.Value); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 132: #line 1440 "ProParser.y" { WholeQuantity_S.Type = WQ_CURRENTVALUE; Get_PointerForString(Current_Value, "DTime", &FlagError, (void **)&WholeQuantity_S.Case.CurrentValue.Value); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 133: #line 1447 "ProParser.y" { WholeQuantity_S.Type = WQ_ARGUMENT; WholeQuantity_S.Case.Argument.Index = (yyvsp[(2) - (2)].i); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 134: #line 1453 "ProParser.y" { WholeQuantity_S.Type = WQ_SAVEVALUE; WholeQuantity_S.Case.SaveValue.Index = (yyvsp[(3) - (3)].i) - 1; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 135: #line 1460 "ProParser.y" { WholeQuantity_S.Type = WQ_VALUESAVED; WholeQuantity_S.Case.ValueSaved.Index = (yyvsp[(2) - (2)].i) - 1; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 136: #line 1467 "ProParser.y" { WholeQuantity_S.Type = WQ_SHOWVALUE; WholeQuantity_S.Case.ShowValue.Index = (int)(yyvsp[(3) - (3)].d); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); ;} break; case 137: #line 1474 "ProParser.y" { WholeQuantity_S.Type = WQ_CONSTANT ; WholeQuantity_S.Case.Constant = (yyvsp[(1) - (1)].i) ; List_Add(Current_WholeQuantity_L, &WholeQuantity_S) ; ;} break; case 138: #line 1480 "ProParser.y" { WholeQuantity_S.Type = WQ_CONSTANT ; WholeQuantity_S.Case.Constant = (yyvsp[(1) - (1)].i) ; List_Add(Current_WholeQuantity_L, &WholeQuantity_S) ; ;} break; case 139: #line 1489 "ProParser.y" { (yyval.i) = -1; ;} break; case 140: #line 1490 "ProParser.y" { (yyval.i) = 0; ;} break; case 141: #line 1491 "ProParser.y" { (yyval.i) = (yyvsp[(2) - (3)].i); ;} break; case 142: #line 1496 "ProParser.y" { (yyval.i) = 1; ;} break; case 143: #line 1497 "ProParser.y" { (yyval.i) = (yyvsp[(1) - (3)].i) + 1; ;} break; case 144: #line 1503 "ProParser.y" { (yyval.l) = NULL; ;} break; case 145: #line 1506 "ProParser.y" { (yyval.l) = (yyvsp[(2) - (3)].l); ;} break; case 146: #line 1509 "ProParser.y" { /* Attention: provisoire. Note: Impossible a mettre dans MultiFExpr car conflit avec Affectation dans Group */ (yyval.l) = List_Create(2, 1, sizeof(double)); double d = (double)Num_Group(&Group_S, (char*)"PA_Region", (yyvsp[(4) - (6)].i)); List_Add((yyval.l), &d); ;} break; case 147: #line 1524 "ProParser.y" { if(!Problem_S.JacobianMethod) Problem_S.JacobianMethod = List_Create(5, 5, sizeof (struct JacobianMethod)); ;} break; case 148: #line 1529 "ProParser.y" { List_Add(Problem_S.JacobianMethod, &JacobianMethod_S); ;} break; case 149: #line 1536 "ProParser.y" { JacobianMethod_S.Name = NULL; JacobianMethod_S.JacobianCase = NULL; ;} break; case 151: #line 1545 "ProParser.y" { Check_NameOfStructNotExist("JacobianMethod", Problem_S.JacobianMethod, (yyvsp[(2) - (3)].c), fcmp_JacobianMethod_Name); JacobianMethod_S.Name = (yyvsp[(2) - (3)].c); ;} break; case 152: #line 1550 "ProParser.y" { JacobianMethod_S.JacobianCase = (yyvsp[(3) - (4)].l); ;} break; case 153: #line 1557 "ProParser.y" { (yyval.l) = List_Create(5, 5, sizeof (struct JacobianCase)); ;} break; case 154: #line 1560 "ProParser.y" { List_Add((yyval.l) = (yyvsp[(1) - (4)].l), &JacobianCase_S); ;} break; case 155: #line 1567 "ProParser.y" { JacobianCase_S.RegionIndex = -1; JacobianCase_S.TypeJacobian = JACOBIAN_VOL; ;} break; case 157: #line 1577 "ProParser.y" { JacobianCase_S.RegionIndex = Num_Group(&Group_S, (char*)"JA_Region", (yyvsp[(2) - (3)].i)); ;} break; case 158: #line 1580 "ProParser.y" { JacobianCase_S.RegionIndex = -1; ;} break; case 159: #line 1583 "ProParser.y" { JacobianCase_S.TypeJacobian = Get_Define1NbrForString(Jacobian_Type, (yyvsp[(2) - (4)].c), &FlagError, &JacobianCase_S.NbrParameters); if(!FlagError) { if(JacobianCase_S.NbrParameters == -2 && (List_Nbr((yyvsp[(3) - (4)].l)))%2 != 0) vyyerror("Wrong number of parameters for Jacobian '%s' (%d is not even)", (yyvsp[(2) - (4)].c), List_Nbr((yyvsp[(3) - (4)].l))); if(JacobianCase_S.NbrParameters < 0) JacobianCase_S.NbrParameters = List_Nbr((yyvsp[(3) - (4)].l)); if(List_Nbr((yyvsp[(3) - (4)].l)) == JacobianCase_S.NbrParameters) { if(JacobianCase_S.NbrParameters) { JacobianCase_S.Para = (double *)Malloc(JacobianCase_S.NbrParameters * sizeof(double)); for(int i = 0; i < JacobianCase_S.NbrParameters; i++) List_Read((yyvsp[(3) - (4)].l), i, &JacobianCase_S.Para[i]); } } else vyyerror("Wrong number of parameters for Jacobian '%s' (%d instead of %d)", (yyvsp[(2) - (4)].c), List_Nbr((yyvsp[(3) - (4)].l)), JacobianCase_S.NbrParameters); } else{ vyyerror("Unknown type of Jacobian: %s", (yyvsp[(2) - (4)].c)); Get_Valid_SXD1N(Jacobian_Type); } Free((yyvsp[(2) - (4)].c)); List_Delete((yyvsp[(3) - (4)].l)); ;} break; case 160: #line 1621 "ProParser.y" { if(!Problem_S.IntegrationMethod) Problem_S.IntegrationMethod = List_Create(5, 5, sizeof(struct IntegrationMethod)); ;} break; case 161: #line 1627 "ProParser.y" { List_Add(Problem_S.IntegrationMethod, &IntegrationMethod_S); ;} break; case 162: #line 1634 "ProParser.y" { IntegrationMethod_S.Name = NULL; IntegrationMethod_S.IntegrationCase = NULL; IntegrationMethod_S.CriterionIndex = -1; ;} break; case 164: #line 1647 "ProParser.y" { Check_NameOfStructNotExist("IntegrationMethod", Problem_S.IntegrationMethod, (yyvsp[(2) - (3)].c), fcmp_IntegrationMethod_Name); IntegrationMethod_S.Name = (yyvsp[(2) - (3)].c); ;} break; case 165: #line 1654 "ProParser.y" { IntegrationMethod_S.CriterionIndex = (yyvsp[(2) - (3)].i); ;} break; case 166: #line 1657 "ProParser.y" { IntegrationMethod_S.IntegrationCase = (yyvsp[(3) - (4)].l); ;} break; case 167: #line 1664 "ProParser.y" { (yyval.l) = List_Create(5, 5, sizeof (struct IntegrationCase)); ;} break; case 168: #line 1667 "ProParser.y" { List_Add((yyval.l) = (yyvsp[(1) - (4)].l), &IntegrationCase_S); ;} break; case 169: #line 1674 "ProParser.y" { IntegrationCase_S.Type = GAUSS; IntegrationCase_S.SubType = STANDARD; ;} break; case 171: #line 1686 "ProParser.y" { IntegrationCase_S.Type = Get_DefineForString(Integration_Type, (yyvsp[(2) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of Integration method: %s", (yyvsp[(2) - (3)].c)); Get_Valid_SXD(Integration_Type); } Free((yyvsp[(2) - (3)].c)); ;} break; case 172: #line 1696 "ProParser.y" { IntegrationCase_S.SubType = Get_DefineForString(Integration_SubType, (yyvsp[(2) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown subtype of Integration method: %s", (yyvsp[(2) - (3)].c)); Get_Valid_SXD(Integration_Type); } Free((yyvsp[(2) - (3)].c)); ;} break; case 173: #line 1706 "ProParser.y" { IntegrationCase_S.Case = (yyvsp[(3) - (4)].l); ;} break; case 174: #line 1713 "ProParser.y" { (yyval.l) = List_Create(5, 5, sizeof (struct Quadrature)); ;} break; case 175: #line 1716 "ProParser.y" { List_Add((yyval.l) = (yyvsp[(1) - (4)].l), &QuadratureCase_S); ;} break; case 176: #line 1723 "ProParser.y" { QuadratureCase_S.ElementType = TRIANGLE; QuadratureCase_S.NumberOfPoints = 4; QuadratureCase_S.MaxNumberOfPoints = 4; QuadratureCase_S.NumberOfDivisions = 1; QuadratureCase_S.MaxNumberOfDivisions = 1; QuadratureCase_S.StoppingCriterion = 1.E-4; QuadratureCase_S.Function = 0; //FIXME(void (*)())Gauss_Triangle; ;} break; case 178: #line 1739 "ProParser.y" { QuadratureCase_S.ElementType = Get_DefineForString(Element_Type, (yyvsp[(2) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of Element: %s", (yyvsp[(2) - (3)].c)); Get_Valid_SXD(Element_Type); } switch(IntegrationCase_S.SubType) { case STANDARD : switch (IntegrationCase_S.Type) { case GAUSS : Get_FunctionForDefine (FunctionForGauss, QuadratureCase_S.ElementType, &FlagError, (void (**)())&QuadratureCase_S.Function); break; case GAUSSLEGENDRE : Get_FunctionForDefine (FunctionForGaussLegendre, QuadratureCase_S.ElementType, &FlagError, (void (**)())&QuadratureCase_S.Function); break; default : vyyerror("Incompatible type of Integration method"); break; } break; case SINGULAR : switch (IntegrationCase_S.Type) { case GAUSS : Get_FunctionForDefine (FunctionForSingularGauss, QuadratureCase_S.ElementType, &FlagError, (void (**)())&QuadratureCase_S.Function); break; default : vyyerror("Incompatible type of Integration method"); break; } break; default : vyyerror("Incompatible type of Integration method"); break; } if(FlagError) vyyerror("Bad type of Integration method for Element: %s", (yyvsp[(2) - (3)].c)); Free((yyvsp[(2) - (3)].c)); ;} break; case 179: #line 1787 "ProParser.y" { QuadratureCase_S.NumberOfPoints = (int)(yyvsp[(2) - (3)].d); ;} break; case 180: #line 1790 "ProParser.y" { QuadratureCase_S.MaxNumberOfPoints = (int)(yyvsp[(2) - (3)].d); ;} break; case 181: #line 1793 "ProParser.y" { QuadratureCase_S.NumberOfDivisions = (int)(yyvsp[(2) - (3)].d); ;} break; case 182: #line 1796 "ProParser.y" { QuadratureCase_S.MaxNumberOfDivisions = (int)(yyvsp[(2) - (3)].d); ;} break; case 183: #line 1799 "ProParser.y" { QuadratureCase_S.StoppingCriterion = (yyvsp[(2) - (3)].d); ;} break; case 184: #line 1810 "ProParser.y" { if(!Problem_S.Constraint) Problem_S.Constraint = List_Create(20, 20, sizeof (struct Constraint)); ;} break; case 186: #line 1820 "ProParser.y" { List_Add(Problem_S.Constraint, &Constraint_S); ;} break; case 188: #line 1830 "ProParser.y" { Constraint_S.Name = NULL; Constraint_S.Type = ASSIGN; Constraint_S.ConstraintPerRegion = NULL; Constraint_S.MultiConstraintPerRegion = NULL; ;} break; case 190: #line 1843 "ProParser.y" { Check_NameOfStructNotExist("Constraint", Problem_S.Constraint, (yyvsp[(2) - (3)].c), fcmp_Constraint_Name); Constraint_S.Name = (yyvsp[(2) - (3)].c); ;} break; case 191: #line 1850 "ProParser.y" { Constraint_S.Type = Get_DefineForString(Constraint_Type, (yyvsp[(2) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of Constraint: %s", (yyvsp[(2) - (3)].c)); Get_Valid_SXD(Constraint_Type); } Free((yyvsp[(2) - (3)].c)); ;} break; case 192: #line 1859 "ProParser.y" { Constraint_S.ConstraintPerRegion = (yyvsp[(3) - (4)].l); ;} break; case 193: #line 1862 "ProParser.y" { if(!Constraint_S.MultiConstraintPerRegion) Constraint_S.MultiConstraintPerRegion = List_Create(5, 5, sizeof(struct MultiConstraintPerRegion)); MultiConstraintPerRegion_S.Name = (yyvsp[(2) - (5)].c); MultiConstraintPerRegion_S.ConstraintPerRegion = (yyvsp[(4) - (5)].l); MultiConstraintPerRegion_S.Active = NULL; List_Add(Constraint_S.MultiConstraintPerRegion, &MultiConstraintPerRegion_S); ;} break; case 194: #line 1880 "ProParser.y" { (yyval.l) = List_Create(6, 6, sizeof (struct ConstraintPerRegion)); ;} break; case 195: #line 1885 "ProParser.y" { List_Add((yyval.l) = (yyvsp[(1) - (4)].l), &ConstraintPerRegion_S); ;} break; case 196: #line 1890 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (2)].l); ;} break; case 197: #line 1899 "ProParser.y" { ConstraintPerRegion_S.Type = Constraint_S.Type; ConstraintPerRegion_S.RegionIndex = -1; ConstraintPerRegion_S.SubRegionIndex = -1; ConstraintPerRegion_S.TimeFunctionIndex = -1; ;} break; case 199: #line 1913 "ProParser.y" { ConstraintPerRegion_S.Type = Get_DefineForString(Constraint_Type, (yyvsp[(2) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of Constraint: %s", (yyvsp[(2) - (3)].c)); Get_Valid_SXD(Constraint_Type); } Free((yyvsp[(2) - (3)].c)); ;} break; case 200: #line 1923 "ProParser.y" { ConstraintPerRegion_S.RegionIndex = Num_Group(&Group_S, (char*)"CO_Region", (yyvsp[(2) - (3)].i)); ;} break; case 201: #line 1928 "ProParser.y" { ConstraintPerRegion_S.SubRegionIndex = Num_Group(&Group_S, (char*)"CO_SubRegion", (yyvsp[(2) - (3)].i)); ;} break; case 202: #line 1934 "ProParser.y" { ConstraintPerRegion_S.TimeFunctionIndex = (yyvsp[(2) - (3)].i); if(Is_ExpressionPieceWiseDefined((yyvsp[(2) - (3)].i))) vyyerror("TimeFunction should never be piece-wise defined"); ;} break; case 203: #line 1941 "ProParser.y" { if(ConstraintPerRegion_S.Type == ASSIGN || ConstraintPerRegion_S.Type == INIT){ ConstraintPerRegion_S.Case.Fixed.ExpressionIndex = (yyvsp[(2) - (3)].i); ConstraintPerRegion_S.Case.Fixed.ExpressionIndex2 = -1; } else vyyerror("Value incompatible with Type"); ;} break; case 204: #line 1951 "ProParser.y" { if(ConstraintPerRegion_S.Type == ASSIGN || ConstraintPerRegion_S.Type == INIT){ ConstraintPerRegion_S.Case.Fixed.ExpressionIndex = (yyvsp[(5) - (7)].i); ConstraintPerRegion_S.Case.Fixed.ExpressionIndex2 = (yyvsp[(3) - (7)].i); } else vyyerror("Value incompatible with Type"); ;} break; case 205: #line 1961 "ProParser.y" { if(ConstraintPerRegion_S.Type == ASSIGNFROMRESOLUTION || ConstraintPerRegion_S.Type == INITFROMRESOLUTION) ConstraintPerRegion_S.Case.Solve.ResolutionName = (yyvsp[(2) - (3)].c); else vyyerror("NameOfResolution incompatible with Type"); ;} break; case 206: #line 1969 "ProParser.y" { if(ConstraintPerRegion_S.Type == NETWORK) { ConstraintPerRegion_S.Case.Network.Node1 = (int)(yyvsp[(3) - (7)].d); ConstraintPerRegion_S.Case.Network.Node2 = (int)(yyvsp[(5) - (7)].d); } else vyyerror("Branch incompatible with Type"); ;} break; case 207: #line 1978 "ProParser.y" { if(ConstraintPerRegion_S.Type == CST_LINK || ConstraintPerRegion_S.Type == CST_LINKCPLX) { ConstraintPerRegion_S.Case.Link.RegionRefIndex = Num_Group(&Group_S, (char*)"CO_RegionRef", (yyvsp[(2) - (3)].i)); ConstraintPerRegion_S.Case.Link.SubRegionRefIndex = -1; ConstraintPerRegion_S.Case.Link.FilterIndex = -1; ConstraintPerRegion_S.Case.Link.FunctionIndex = -1; ConstraintPerRegion_S.Case.Link.CoefIndex = -1; ConstraintPerRegion_S.Case.Link.FilterIndex2 = -1; ConstraintPerRegion_S.Case.Link.FunctionIndex2 = -1; ConstraintPerRegion_S.Case.Link.CoefIndex2 = -1; } else vyyerror("RegionRef incompatible with Type"); ;} break; case 208: #line 1996 "ProParser.y" { if(ConstraintPerRegion_S.Type == CST_LINK || ConstraintPerRegion_S.Type == CST_LINKCPLX) ConstraintPerRegion_S.Case.Link.SubRegionRefIndex = Num_Group(&Group_S, (char*)"CO_RegionRef", (yyvsp[(2) - (3)].i)); else vyyerror("SubRegionRef incompatible with Type"); ;} break; case 209: #line 2005 "ProParser.y" { if(ConstraintPerRegion_S.Type == CST_LINK || ConstraintPerRegion_S.Type == CST_LINKCPLX) ConstraintPerRegion_S.Case.Link.FunctionIndex = (yyvsp[(2) - (3)].i); else vyyerror("Function incompatible with Type"); ;} break; case 210: #line 2013 "ProParser.y" { if(ConstraintPerRegion_S.Type == CST_LINK || ConstraintPerRegion_S.Type == CST_LINKCPLX) ConstraintPerRegion_S.Case.Link.CoefIndex = (yyvsp[(2) - (3)].i); else vyyerror("Coefficient incompatible with Type"); ;} break; case 211: #line 2021 "ProParser.y" { if(ConstraintPerRegion_S.Type == CST_LINK || ConstraintPerRegion_S.Type == CST_LINKCPLX) { ConstraintPerRegion_S.Case.Link.FilterIndex = (yyvsp[(2) - (3)].i); ConstraintPerRegion_S.Case.Link.FilterIndex2 = -1; } else vyyerror("Filter incompatible with Type"); ;} break; case 212: #line 2031 "ProParser.y" { if(ConstraintPerRegion_S.Type == CST_LINK || ConstraintPerRegion_S.Type == CST_LINKCPLX) { ConstraintPerRegion_S.Case.Link.FunctionIndex = (yyvsp[(3) - (7)].i); ConstraintPerRegion_S.Case.Link.FunctionIndex2 = (yyvsp[(5) - (7)].i); } else vyyerror("Function incompatible with Type"); ;} break; case 213: #line 2041 "ProParser.y" { if(ConstraintPerRegion_S.Type == CST_LINK || ConstraintPerRegion_S.Type == CST_LINKCPLX) { ConstraintPerRegion_S.Case.Link.CoefIndex = (yyvsp[(3) - (7)].i); ConstraintPerRegion_S.Case.Link.CoefIndex2 = (yyvsp[(5) - (7)].i); } else vyyerror("Coefficient incompatible with Type"); ;} break; case 214: #line 2051 "ProParser.y" { if(ConstraintPerRegion_S.Type == CST_LINK || ConstraintPerRegion_S.Type == CST_LINKCPLX) { ConstraintPerRegion_S.Case.Link.FilterIndex = (yyvsp[(3) - (7)].i); ConstraintPerRegion_S.Case.Link.FilterIndex2 = (yyvsp[(5) - (7)].i); } else vyyerror("Filter incompatible with Type"); ;} break; case 215: #line 2071 "ProParser.y" { if(!Problem_S.FunctionSpace) Problem_S.FunctionSpace = List_Create(10, 5, sizeof (struct FunctionSpace)); ;} break; case 217: #line 2082 "ProParser.y" { List_Add(Problem_S.FunctionSpace, &FunctionSpace_S); ;} break; case 219: #line 2093 "ProParser.y" { FunctionSpace_S.Name = NULL; FunctionSpace_S.Type = FORM0; FunctionSpace_S.BasisFunction = FunctionSpace_S.SubSpace = FunctionSpace_S.GlobalQuantity = FunctionSpace_S.Constraint = NULL; ;} break; case 222: #line 2107 "ProParser.y" { Check_NameOfStructNotExist("FunctionSpace", Problem_S.FunctionSpace, (yyvsp[(2) - (3)].c), fcmp_FunctionSpace_Name); FunctionSpace_S.Name = (yyvsp[(2) - (3)].c); ;} break; case 223: #line 2114 "ProParser.y" { FunctionSpace_S.Type = Get_DefineForString(Field_Type, (yyvsp[(2) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of FunctionSpace: %s", (yyvsp[(2) - (3)].c)); Get_Valid_SXD(Field_Type); } Free((yyvsp[(2) - (3)].c)); ;} break; case 224: #line 2123 "ProParser.y" { FunctionSpace_S.BasisFunction = (yyvsp[(3) - (4)].l); ;} break; case 225: #line 2126 "ProParser.y" { FunctionSpace_S.SubSpace = (yyvsp[(3) - (4)].l); ;} break; case 226: #line 2129 "ProParser.y" { FunctionSpace_S.GlobalQuantity = (yyvsp[(3) - (4)].l); ;} break; case 227: #line 2132 "ProParser.y" { FunctionSpace_S.Constraint = (yyvsp[(3) - (4)].l); ;} break; case 228: #line 2139 "ProParser.y" { (yyval.l) = Current_BasisFunction_L = List_Create(6, 6, sizeof (struct BasisFunction)); ;} break; case 229: #line 2145 "ProParser.y" { int i; if((i = List_ISearchSeq((yyvsp[(1) - (4)].l), BasisFunction_S.Name, fcmp_BasisFunction_Name)) < 0) { /* BasisFunction_S.Num = Num_BasisFunction++; */ BasisFunction_S.Num = Num_BasisFunction; Num_BasisFunction += (BasisFunction_S.SubFunction)? List_Nbr(BasisFunction_S.SubFunction) : 1; } else /* BasisFunction definie par morceaux => meme Num */ BasisFunction_S.Num = ((struct BasisFunction *)List_Pointer((yyvsp[(1) - (4)].l), i))->Num; List_Add((yyval.l) = (yyvsp[(1) - (4)].l), &BasisFunction_S); ;} break; case 230: #line 2163 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (2)].l); ;} break; case 231: #line 2172 "ProParser.y" { BasisFunction_S.Name = NULL; BasisFunction_S.NameOfCoef = NULL; BasisFunction_S.Num = 0; BasisFunction_S.GlobalBasisFunction = NULL; BasisFunction_S.Function = NULL; BasisFunction_S.dFunction = NULL; BasisFunction_S.dInvFunction = NULL; BasisFunction_S.SubFunction = NULL; BasisFunction_S.SubdFunction = NULL; BasisFunction_S.SupportIndex = -1; BasisFunction_S.EntityIndex = -1; ;} break; case 233: #line 2193 "ProParser.y" { BasisFunction_S.Name = (yyvsp[(2) - (3)].c); ;} break; case 234: #line 2196 "ProParser.y" { Check_NameOfStructNotExist("NameOfCoef", Current_BasisFunction_L, (yyvsp[(2) - (3)].c), fcmp_BasisFunction_NameOfCoef); BasisFunction_S.NameOfCoef = (yyvsp[(2) - (3)].c); BasisFunction_S.Dimension = 1; ;} break; case 235: #line 2201 "ProParser.y" { Get_3Function3NbrForString (BF_Function, (yyvsp[(2) - (4)].c), &FlagError, &BasisFunction_S.Function, &BasisFunction_S.dFunction, &BasisFunction_S.dInvFunction, &BasisFunction_S.Order, &BasisFunction_S.ElementType, &BasisFunction_S.Orient); if(FlagError){ vyyerror("Unknown Function for BasisFunction: %s", (yyvsp[(2) - (4)].c)); Get_Valid_SX3F3N(BF_Function); } Free((yyvsp[(2) - (4)].c)); ;} break; case 236: #line 2215 "ProParser.y" { void (*FunctionDummy)(); int i, j; double d; Get_3Function3NbrForString (BF_Function, (yyvsp[(3) - (7)].c), &FlagError, &BasisFunction_S.dFunction, &FunctionDummy, &FunctionDummy, &d, &i, &j); if(FlagError){ vyyerror("Unknown dFunction (1) for BasisFunction: %s", (yyvsp[(3) - (7)].c)); Get_Valid_SX3F3N(BF_Function); } Free((yyvsp[(3) - (7)].c)); Get_3Function3NbrForString (BF_Function, (yyvsp[(5) - (7)].c), &FlagError, &BasisFunction_S.dInvFunction, &FunctionDummy, &FunctionDummy, &d, &i, &j); if(FlagError){ vyyerror("Unknown dFunction (2) for BasisFunction: %s", (yyvsp[(5) - (7)].c)); Get_Valid_SX3F3N(BF_Function); } Free((yyvsp[(5) - (7)].c)); ;} break; case 237: #line 2238 "ProParser.y" { BasisFunction_S.SubFunction = List_Copy(ListOfInt_L); ;} break; case 238: #line 2243 "ProParser.y" { BasisFunction_S.SubdFunction = List_Copy(ListOfInt_L); ;} break; case 239: #line 2248 "ProParser.y" { BasisFunction_S.SupportIndex = Num_Group(&Group_S, (char*)"BF_Support", (yyvsp[(2) - (3)].i)); ;} break; case 240: #line 2253 "ProParser.y" { BasisFunction_S.EntityIndex = Num_Group(&Group_S, (char*)"BF_Entity", (yyvsp[(2) - (3)].i)); if(Group_S.InitialList) List_Sort(Group_S.InitialList, fcmp_Integer); /* Needed for Global Region */ if(BasisFunction_S.GlobalBasisFunction) { /* Function to be defined before Entity */ if(Group_S.FunctionType == GLOBAL) { if(List_Nbr(BasisFunction_S.GlobalBasisFunction) == List_Nbr(Group_S.InitialList)) { for(int k = 0; k < List_Nbr(Group_S.InitialList); k++) if(*((int*)List_Pointer(Group_S.InitialList, k)) != *((int*)List_Pointer(BasisFunction_S.GlobalBasisFunction, k))) { vyyerror("Bad correspondance between Group and Entity (elements differ)"); break; } } else if(List_Nbr(Group_S.InitialList) != 0 || GlobalBasisFunction_S.EntityIndex != -1) vyyerror("Bad correspondance between Group and Entity (#BF %d, #Global %d)", List_Nbr(BasisFunction_S.GlobalBasisFunction), List_Nbr(Group_S.InitialList)); } else vyyerror("Bad correspondance between Group and Entity (Entity must be Global)"); } ;} break; case 242: #line 2289 "ProParser.y" { int dim = (yyvsp[(8) - (20)].d); if(dim != (yyvsp[(17) - (20)].d)) vyyerror("Number of formulations different from number of resolutions"); if(List_Nbr(Group_S.InitialList) != dim) vyyerror("Group sould have %d single regions", dim); BasisFunction_S.GlobalBasisFunction = List_Create(dim, 1, sizeof(struct GlobalBasisFunction)); for(int k = 0; k < dim; k++) { int i; List_Read(Group_S.InitialList, k, &i); GlobalBasisFunction_S.EntityIndex = i; char tmpstr[256]; sprintf(tmpstr, "%s_%d", (yyvsp[(6) - (20)].c), k+1); if((i = List_ISearchSeq(Problem_S.Formulation, tmpstr, fcmp_Formulation_Name)) >= 0) { GlobalBasisFunction_S.FormulationIndex = i; List_Read(Problem_S.Formulation, i, &Formulation_S); if((i = List_ISearchSeq(Formulation_S.DefineQuantity, (yyvsp[(3) - (20)].c), fcmp_DefineQuantity_Name)) >= 0) GlobalBasisFunction_S.DefineQuantityIndex = i; else { vyyerror("Unknown Quantity '%s' in Formulation '%s'", (yyvsp[(3) - (20)].c), Formulation_S.Name); break; } } else vyyerror("Unknown Formulation: %s", tmpstr); sprintf(tmpstr, "%s_%d", (yyvsp[(15) - (20)].c), k+1); if((i = List_ISearchSeq(Problem_S.Resolution, tmpstr, fcmp_Resolution_Name)) >= 0) GlobalBasisFunction_S.ResolutionIndex = i; else vyyerror("Unknown Resolution: %s", tmpstr); GlobalBasisFunction_S.QuantityStorage = NULL; List_Add(BasisFunction_S.GlobalBasisFunction, &GlobalBasisFunction_S); } List_Sort(BasisFunction_S.GlobalBasisFunction, fcmp_Integer); Free((yyvsp[(3) - (20)].c)); Free((yyvsp[(6) - (20)].c)); Free((yyvsp[(15) - (20)].c)); ;} break; case 243: #line 2342 "ProParser.y" { (yyval.l) = Current_SubSpace_L = List_Create(6, 6, sizeof (struct SubSpace)); ;} break; case 244: #line 2348 "ProParser.y" { List_Add((yyval.l) = (yyvsp[(1) - (4)].l), &SubSpace_S); ;} break; case 245: #line 2357 "ProParser.y" { SubSpace_S.Name = NULL; SubSpace_S.BasisFunction = NULL; ;} break; case 247: #line 2368 "ProParser.y" { Check_NameOfStructNotExist("SubSpace", Current_SubSpace_L, (yyvsp[(2) - (3)].c), fcmp_SubSpace_Name); SubSpace_S.Name = (yyvsp[(2) - (3)].c); ;} break; case 248: #line 2375 "ProParser.y" { SubSpace_S.BasisFunction = (yyvsp[(2) - (3)].l); ;} break; case 249: #line 2378 "ProParser.y" { SubSpace_S.BasisFunction = (yyvsp[(2) - (3)].l); ;} break; case 250: #line 2385 "ProParser.y" { (yyval.l) = List_Create(1, 1, sizeof(int)); int i; if((i = List_ISearchSeq(Current_BasisFunction_L, (yyvsp[(1) - (1)].c), fcmp_BasisFunction_Name)) < 0) vyyerror("Unknown BasisFunction: %s", (yyvsp[(1) - (1)].c)); else { List_Add((yyval.l), &i); int j = i+1; while((i = List_ISearchSeqPartial(Current_BasisFunction_L, (yyvsp[(1) - (1)].c), j, fcmp_BasisFunction_Name)) >= 0) { List_Add((yyval.l), &i); j = i+1; /* for piecewise defined basis functions */ } } Free((yyvsp[(1) - (1)].c)); ;} break; case 251: #line 2403 "ProParser.y" { (yyval.l) = (yyvsp[(2) - (3)].l); ;} break; case 252: #line 2409 "ProParser.y" { (yyval.l) = List_Create(5, 5, sizeof(int)); ;} break; case 253: #line 2412 "ProParser.y" { int i; if((i = List_ISearchSeq(Current_BasisFunction_L, (yyvsp[(3) - (3)].c), fcmp_BasisFunction_Name)) < 0) vyyerror("Unknown BasisFunction: %s", (yyvsp[(3) - (3)].c)); else { List_Add((yyvsp[(1) - (3)].l), &i); int j = i+1; while((i = List_ISearchSeqPartial(Current_BasisFunction_L, (yyvsp[(3) - (3)].c), j, fcmp_BasisFunction_Name)) >= 0) { List_Add((yyvsp[(1) - (3)].l), &i); j = i+1; /* for piecewise defined basis functions */ } } (yyval.l) = (yyvsp[(1) - (3)].l); Free((yyvsp[(3) - (3)].c)); ;} break; case 254: #line 2433 "ProParser.y" { (yyval.l) = List_Create(1, 1, sizeof(int)); int i; if((i = List_ISearchSeq(Current_BasisFunction_L, (yyvsp[(1) - (1)].c), fcmp_BasisFunction_NameOfCoef)) < 0) vyyerror("Unknown BasisFunctionCoef: %s", (yyvsp[(1) - (1)].c)); else { List_Add((yyval.l), &i); } Free((yyvsp[(1) - (1)].c)); ;} break; case 255: #line 2446 "ProParser.y" { (yyval.l) = (yyvsp[(2) - (3)].l); ;} break; case 256: #line 2453 "ProParser.y" { (yyval.l) = List_Create(5, 5, sizeof(int)); ;} break; case 257: #line 2458 "ProParser.y" { int i; if((i = List_ISearchSeq(Current_BasisFunction_L, (yyvsp[(3) - (3)].c), fcmp_BasisFunction_NameOfCoef)) < 0) vyyerror("Unknown BasisFunctionCoef: %s", (yyvsp[(3) - (3)].c)); else { List_Add((yyvsp[(1) - (3)].l), &i); } (yyval.l) = (yyvsp[(1) - (3)].l); Free((yyvsp[(3) - (3)].c)); ;} break; case 258: #line 2474 "ProParser.y" { (yyval.l) = Current_GlobalQuantity_L = List_Create(6, 6, sizeof (struct GlobalQuantity)); ;} break; case 259: #line 2480 "ProParser.y" { GlobalQuantity_S.Num = Num_BasisFunction++; List_Add((yyval.l) = (yyvsp[(1) - (4)].l), &GlobalQuantity_S); ;} break; case 260: #line 2486 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (2)].l); ;} break; case 261: #line 2495 "ProParser.y" { GlobalQuantity_S.Name = NULL; GlobalQuantity_S.Num = 0; GlobalQuantity_S.Type = ALIASOF; GlobalQuantity_S.ReferenceIndex = -1; ;} break; case 263: #line 2507 "ProParser.y" { Check_NameOfStructNotExist("GlobalQuantity", Current_GlobalQuantity_L, (yyvsp[(2) - (3)].c), fcmp_GlobalQuantity_Name); GlobalQuantity_S.Name = (yyvsp[(2) - (3)].c); ;} break; case 264: #line 2514 "ProParser.y" { GlobalQuantity_S.Type = Get_DefineForString(GlobalQuantity_Type, (yyvsp[(2) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of GlobalQuantity: %s", (yyvsp[(2) - (3)].c)); Get_Valid_SXD(GlobalQuantity_Type); } Free((yyvsp[(2) - (3)].c)); ;} break; case 265: #line 2525 "ProParser.y" { int i; if((i = List_ISearchSeq(FunctionSpace_S.BasisFunction, (yyvsp[(2) - (3)].c), fcmp_BasisFunction_NameOfCoef)) < 0) vyyerror("Unknown NameOfCoef: %s", (yyvsp[(2) - (3)].c)); else GlobalQuantity_S.ReferenceIndex = i; Free((yyvsp[(2) - (3)].c)); ;} break; case 266: #line 2540 "ProParser.y" { (yyval.l) = List_Create(6, 6, sizeof (struct ConstraintInFS)); ;} break; case 267: #line 2545 "ProParser.y" { Group_S.FunctionType = Type_Function; Group_S.SuppListType = Type_SuppList; switch (Group_S.FunctionType) { case ELEMENTSOF : Group_S.Type = ELEMENTLIST; break; default : Group_S.Type = REGIONLIST ; break; } if(Constraint_Index >= 0) { Constraint_P = (struct Constraint *) List_Pointer(Problem_S.Constraint, Constraint_Index); for(int i = 0; i < List_Nbr(Constraint_P->ConstraintPerRegion); i++) { ConstraintPerRegion_P = (struct ConstraintPerRegion *) List_Pointer(Constraint_P->ConstraintPerRegion, i); if(ConstraintPerRegion_P->RegionIndex >= 0) { Group_S.InitialList = ((struct Group *) List_Pointer(Problem_S.Group, ConstraintPerRegion_P->RegionIndex)) ->InitialList; Group_S.InitialSuppList = (ConstraintPerRegion_P->SubRegionIndex >= 0)? ((struct Group *) List_Pointer(Problem_S.Group, ConstraintPerRegion_P->SubRegionIndex)) ->InitialList : NULL; ConstraintInFS_S.EntityIndex = Add_Group(&Group_S, (char*)"CO_Entity", false, 1, 0); ConstraintInFS_S.ConstraintPerRegion = ConstraintPerRegion_P; List_Add((yyval.l) = (yyvsp[(1) - (4)].l), &ConstraintInFS_S); } } } ;} break; case 268: #line 2583 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (2)].l); ;} break; case 269: #line 2592 "ProParser.y" { ConstraintInFS_S.QuantityType = LOCALQUANTITY; ConstraintInFS_S.ReferenceIndex = -1; ConstraintInFS_S.EntityIndex = -1; ConstraintInFS_S.ConstraintPerRegion = NULL; ConstraintInFS_S.Active.ResolutionIndex = -1; ConstraintInFS_S.Active.Active = NULL; Constraint_Index = -1; ;} break; case 271: #line 2608 "ProParser.y" { int i; if((i = List_ISearchSeq(FunctionSpace_S.BasisFunction, (yyvsp[(2) - (3)].c), fcmp_BasisFunction_NameOfCoef)) < 0) { if((i = List_ISearchSeq(FunctionSpace_S.GlobalQuantity, (yyvsp[(2) - (3)].c), fcmp_GlobalQuantity_Name)) < 0) vyyerror("Unknown NameOfCoef: %s", (yyvsp[(2) - (3)].c)); else { ConstraintInFS_S.QuantityType = GLOBALQUANTITY; ConstraintInFS_S.ReferenceIndex = i; } } else { ConstraintInFS_S.QuantityType = LOCALQUANTITY; ConstraintInFS_S.ReferenceIndex = i; } Free((yyvsp[(2) - (3)].c)); ;} break; case 272: #line 2628 "ProParser.y" { Type_Function = (yyvsp[(2) - (3)].i); ;} break; case 273: #line 2631 "ProParser.y" { Type_SuppList = (yyvsp[(2) - (3)].i); ;} break; case 274: #line 2634 "ProParser.y" { Constraint_Index = List_ISearchSeq(Problem_S.Constraint, (yyvsp[(2) - (3)].c), fcmp_Constraint_Name); if(Constraint_Index < 0) Message::Warning("Constraint '%s' is not provided", (yyvsp[(2) - (3)].c)); Free((yyvsp[(2) - (3)].c)); ;} break; case 275: #line 2651 "ProParser.y" { if(!Problem_S.Formulation) Problem_S.Formulation = List_Create(10, 5, sizeof (struct Formulation)); ;} break; case 277: #line 2661 "ProParser.y" { List_Add(Problem_S.Formulation, &Formulation_S); ;} break; case 279: #line 2672 "ProParser.y" { Formulation_S.Name = NULL; Formulation_S.Type = FEMEQUATION; Formulation_S.DefineQuantity = NULL; Formulation_S.Equation = NULL; ;} break; case 281: #line 2683 "ProParser.y" { Check_NameOfStructNotExist("Formulation", Problem_S.Formulation, (yyvsp[(2) - (3)].c), fcmp_Formulation_Name); Formulation_S.Name = (yyvsp[(2) - (3)].c); ;} break; case 282: #line 2690 "ProParser.y" { Formulation_S.Type = Get_DefineForString(Formulation_Type, (yyvsp[(2) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of Formulation: %s", (yyvsp[(2) - (3)].c)); Get_Valid_SXD(Formulation_Type); } Free((yyvsp[(2) - (3)].c)); ;} break; case 284: #line 2702 "ProParser.y" { Formulation_S.Equation = (yyvsp[(3) - (4)].l); Free((yyvsp[(1) - (4)].c)); ;} break; case 285: #line 2711 "ProParser.y" { Formulation_S.DefineQuantity = List_Create(6, 6, sizeof (struct DefineQuantity)); ;} break; case 286: #line 2716 "ProParser.y" { List_Add(Formulation_S.DefineQuantity, &DefineQuantity_S); ;} break; case 288: #line 2727 "ProParser.y" { DefineQuantity_S.Name = NULL; DefineQuantity_S.Type = LOCALQUANTITY; DefineQuantity_S.IndexInFunctionSpace = NULL; DefineQuantity_S.FunctionSpaceIndex = -1; DefineQuantity_S.DofDataIndex = -1; DefineQuantity_S.DofData = NULL; DefineQuantity_S.DummyFrequency = NULL; DefineQuantity_S.IntegralQuantity.InIndex = -1; DefineQuantity_S.IntegralQuantity.IntegrationMethodIndex = -1; DefineQuantity_S.IntegralQuantity.JacobianMethodIndex = -1; DefineQuantity_S.IntegralQuantity.Symmetry = 0; DefineQuantity_S.IntegralQuantity.WholeQuantity = NULL; ;} break; case 290: #line 2749 "ProParser.y" { DefineQuantity_S.Name = (yyvsp[(2) - (3)].c); ;} break; case 291: #line 2752 "ProParser.y" { DefineQuantity_S.Type = GLOBALQUANTITY; ;} break; case 292: #line 2756 "ProParser.y" { DefineQuantity_S.Type = INTEGRALQUANTITY; ;} break; case 293: #line 2759 "ProParser.y" { DefineQuantity_S.Type = Get_DefineForString(DefineQuantity_Type, (yyvsp[(2) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of Quantity: %s", (yyvsp[(2) - (3)].c)); Get_Valid_SXD(DefineQuantity_Type); } Free((yyvsp[(2) - (3)].c)); ;} break; case 294: #line 2769 "ProParser.y" { DefineQuantity_S.DummyFrequency = (yyvsp[(2) - (3)].l); ;} break; case 295: #line 2773 "ProParser.y" { int i; if((i = List_ISearchSeq(Problem_S.FunctionSpace, (yyvsp[(2) - (2)].c), fcmp_FunctionSpace_Name)) < 0) vyyerror("Unknown FunctionSpace: %s", (yyvsp[(2) - (2)].c)); else DefineQuantity_S.FunctionSpaceIndex = i; ;} break; case 296: #line 2782 "ProParser.y" { if(DefineQuantity_S.FunctionSpaceIndex >= 0) { if(DefineQuantity_S.Type == GLOBALQUANTITY && !DefineQuantity_S.IndexInFunctionSpace) { if(DefineQuantity_S.Name) { List_Read(Problem_S.FunctionSpace, DefineQuantity_S.FunctionSpaceIndex, &FunctionSpace_S); int i; if((i = List_ISearchSeq(FunctionSpace_S.GlobalQuantity, DefineQuantity_S.Name, fcmp_GlobalQuantity_Name)) < 0) { vyyerror("Unknown GlobalQuantity: %s", DefineQuantity_S.Name); } else { DefineQuantity_S.IndexInFunctionSpace = List_Create(1, 1, sizeof(int)); List_Add(DefineQuantity_S.IndexInFunctionSpace, &i); } } else vyyerror("No Name pre-defined for GlobalQuantity"); } } ;} break; case 297: #line 2807 "ProParser.y" { DefineQuantity_S.DofDataIndex = (int)(yyvsp[(2) - (3)].d); ;} break; case 298: #line 2812 "ProParser.y" { Current_DofIndexInWholeQuantity = -1; Current_NoDofIndexInWholeQuantity = -1; List_Reset(ListOfPointer_L); ;} break; case 299: #line 2818 "ProParser.y" { DefineQuantity_S.IntegralQuantity.WholeQuantity = (yyvsp[(3) - (5)].l); DefineQuantity_S.IntegralQuantity.DofIndexInWholeQuantity = Current_DofIndexInWholeQuantity; WholeQuantity_P = (struct WholeQuantity*) List_Pointer(DefineQuantity_S.IntegralQuantity.WholeQuantity, 0); /* Ce qui suit ne suffit pas : il faudrait aussi gerer des Quantity_def sans Dof */ if(Current_DofIndexInWholeQuantity >= 0) { DefineQuantity_S.IntegralQuantity.TypeOperatorDof = (WholeQuantity_P+Current_DofIndexInWholeQuantity)-> Case.OperatorAndQuantity.TypeOperator; DefineQuantity_S.IntegralQuantity.DefineQuantityIndexDof = (WholeQuantity_P+Current_DofIndexInWholeQuantity)-> Case.OperatorAndQuantity.Index; DefineQuantity_S.FunctionSpaceIndex = ((struct DefineQuantity*) List_Pointer(Formulation_S.DefineQuantity, DefineQuantity_S.IntegralQuantity.DefineQuantityIndexDof))-> FunctionSpaceIndex; } else { /* No Dof{} */ DefineQuantity_S.IntegralQuantity.TypeOperatorDof = NOOP; DefineQuantity_S.IntegralQuantity.DefineQuantityIndexDof = -1; } if(Current_NoDofIndexInWholeQuantity >= 0) { DefineQuantity_S.IntegralQuantity.DefineQuantityIndexNoDof = (WholeQuantity_P+Current_NoDofIndexInWholeQuantity)-> Case.OperatorAndQuantity.Index; } else { /* No NoDof{} */ DefineQuantity_S.IntegralQuantity.DefineQuantityIndexNoDof = -1; } /* Check if the WholeQuantity is a Canonical Form */ DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_NONE; if(List_Nbr(DefineQuantity_S.IntegralQuantity.WholeQuantity) == 1){ /* GF_FUNCTION */ if((WholeQuantity_P+0)->Type == WQ_BUILTINFUNCTION) { Get_FunctionForFunction(GF_Function, (WholeQuantity_P+0)->Case.Function.Fct, &FlagError, &DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Fct); if(!FlagError){ DefineQuantity_S.IntegralQuantity.FunctionForCanonical.NbrParameters = (WholeQuantity_P+0)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Para = (WholeQuantity_P+0)->Case.Function.Para; } DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_GF; } } else if(List_Nbr(DefineQuantity_S.IntegralQuantity.WholeQuantity) == 3){ /* GF_FUNCTION OPER DOF */ if ((WholeQuantity_P+0)->Type == WQ_BUILTINFUNCTION && (WholeQuantity_P+1)->Type == WQ_OPERATORANDQUANTITY && (WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR && Current_DofIndexInWholeQuantity == 1) { Get_FunctionForFunction(GF_Function, (WholeQuantity_P+0)->Case.Function.Fct, &FlagError, &DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Fct); if(!FlagError){ DefineQuantity_S.IntegralQuantity.FunctionForCanonical.NbrParameters = (WholeQuantity_P+0)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Para = (WholeQuantity_P+0)->Case.Function.Para; } if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_GF_PSCA_DOF; if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_GF_PVEC_DOF; } /* DOF OPER GF_FUNCTION */ else if((WholeQuantity_P+0)->Type == WQ_OPERATORANDQUANTITY && (WholeQuantity_P+1)->Type == WQ_BUILTINFUNCTION && (WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR && Current_DofIndexInWholeQuantity == 0) { Get_FunctionForFunction(GF_Function, (WholeQuantity_P+1)->Case.Function.Fct, &FlagError, &DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Fct); if(!FlagError){ DefineQuantity_S.IntegralQuantity.FunctionForCanonical.NbrParameters = (WholeQuantity_P+1)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Para = (WholeQuantity_P+1)->Case.Function.Para; } if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_GF_PSCA_DOF;/* Scalar Prod Transitive */ if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_DOF_PVEC_GF; } /* GF_FUNCTION OPER EXPR */ else if((WholeQuantity_P+0)->Type == WQ_BUILTINFUNCTION && (WholeQuantity_P+1)->Type == WQ_EXPRESSION && (WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR ) { Get_FunctionForFunction(GF_Function, (WholeQuantity_P+0)->Case.Function.Fct, &FlagError, &DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Fct); if(!FlagError){ DefineQuantity_S.IntegralQuantity.FunctionForCanonical.NbrParameters = (WholeQuantity_P+0)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Para = (WholeQuantity_P+0)->Case.Function.Para; } DefineQuantity_S.IntegralQuantity.ExpressionIndexForCanonical = (WholeQuantity_P+1)->Case.Expression.Index; if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_GF_PSCA_EXP; if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_GF_PVEC_EXP; /* DefineQuantity_S.IntegralQuantity.FunctionForCanonical.NbrParameters = (WholeQuantity_P+0)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Para = (WholeQuantity_P+0)->Case.Function.Para; */ } /* EXPR OPER GF_FUNCTION */ else if((WholeQuantity_P+0)->Type == WQ_EXPRESSION && (WholeQuantity_P+1)->Type == WQ_BUILTINFUNCTION && (WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR ) { Get_FunctionForFunction(GF_Function, (WholeQuantity_P+1)->Case.Function.Fct, &FlagError, &DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Fct); if(!FlagError){ DefineQuantity_S.IntegralQuantity.FunctionForCanonical.NbrParameters = (WholeQuantity_P+1)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Para = (WholeQuantity_P+1)->Case.Function.Para; } DefineQuantity_S.IntegralQuantity.ExpressionIndexForCanonical = (WholeQuantity_P+0)->Case.Expression.Index; if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_GF_PSCA_EXP;/* Transitive product */ if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_EXP_PVEC_GF; } } else if(List_Nbr(DefineQuantity_S.IntegralQuantity.WholeQuantity) == 5){ /* EXPR OPER GF_FUNCTION OPER DOF */ if ((WholeQuantity_P+0)->Type == WQ_EXPRESSION && (WholeQuantity_P+1)->Type == WQ_BUILTINFUNCTION && (WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR && (WholeQuantity_P+3)->Type == WQ_OPERATORANDQUANTITY && (WholeQuantity_P+4)->Type == WQ_BINARYOPERATOR && Current_DofIndexInWholeQuantity == 3) { Get_FunctionForFunction(GF_Function, (WholeQuantity_P+1)->Case.Function.Fct, &FlagError, &DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Fct); if(!FlagError){ DefineQuantity_S.IntegralQuantity.FunctionForCanonical.NbrParameters = (WholeQuantity_P+1)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Para = (WholeQuantity_P+1)->Case.Function.Para; } DefineQuantity_S.IntegralQuantity.ExpressionIndexForCanonical = (WholeQuantity_P+0)->Case.Expression.Index; if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME){ if((WholeQuantity_P+4)->Case.Operator.TypeOperator == OP_TIME) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_EXP_TIME_GF_PSCA_DOF; if((WholeQuantity_P+4)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_EXP_TIME_GF_PVEC_DOF; } else if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_CROSSPRODUCT){ if((WholeQuantity_P+4)->Case.Operator.TypeOperator == OP_TIME) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_EXP_PVEC_GF_PSCA_DOF; if((WholeQuantity_P+4)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_EXP_PVEC_GF_PVEC_DOF; } } /* FCT OPER GF_FUNCTION OPER DOF */ else if((WholeQuantity_P+0)->Type == WQ_BUILTINFUNCTION && (WholeQuantity_P+1)->Type == WQ_BUILTINFUNCTION && (WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR && (WholeQuantity_P+3)->Type == WQ_OPERATORANDQUANTITY && (WholeQuantity_P+4)->Type == WQ_BINARYOPERATOR && Current_DofIndexInWholeQuantity == 3) { Get_FunctionForFunction(GF_Function, (WholeQuantity_P+1)->Case.Function.Fct, &FlagError, &DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Fct); if(!FlagError){ DefineQuantity_S.IntegralQuantity.FunctionForCanonical.NbrParameters = (WholeQuantity_P+1)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Para = (WholeQuantity_P+1)->Case.Function.Para; } DefineQuantity_S.IntegralQuantity.AnyFunction.Fct = (WholeQuantity_P+0)->Case.Function.Fct; DefineQuantity_S.IntegralQuantity.AnyFunction.NbrParameters = (WholeQuantity_P+0)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.AnyFunction.Para = (WholeQuantity_P+0)->Case.Function.Para; if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME){ if((WholeQuantity_P+4)->Case.Operator.TypeOperator == OP_TIME) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_FCT_TIME_GF_PSCA_DOF; if((WholeQuantity_P+4)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_FCT_TIME_GF_PVEC_DOF; } else if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_CROSSPRODUCT){ if((WholeQuantity_P+4)->Case.Operator.TypeOperator == OP_TIME) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_FCT_PVEC_GF_PSCA_DOF; if((WholeQuantity_P+4)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_FCT_PVEC_GF_PVEC_DOF; } } } Pro_DefineQuantityIndex (DefineQuantity_S.IntegralQuantity.WholeQuantity, -1, &DefineQuantity_S.IntegralQuantity.NbrQuantityIndex, &DefineQuantity_S.IntegralQuantity.QuantityIndexTable, &DefineQuantity_S.IntegralQuantity.QuantityTraceGroupIndexTable); if(DefineQuantity_S.IntegralQuantity.NbrQuantityIndex > 1) vyyerror("More than one LocalQuantity in IntegralQuantity"); ;} break; case 300: #line 3080 "ProParser.y" { DefineQuantity_S.IntegralQuantity.InIndex = Num_Group(&Group_S, (char*)"IQ_In", (yyvsp[(2) - (3)].i)); ;} break; case 301: #line 3085 "ProParser.y" { int i; if((i = List_ISearchSeq(Problem_S.IntegrationMethod, (yyvsp[(2) - (3)].c), fcmp_IntegrationMethod_Name)) < 0) vyyerror("Unknown Integration method: %s", (yyvsp[(2) - (3)].c)); else DefineQuantity_S.IntegralQuantity.IntegrationMethodIndex = i; Free((yyvsp[(2) - (3)].c)); ;} break; case 302: #line 3096 "ProParser.y" { int i; if((i = List_ISearchSeq(Problem_S.JacobianMethod, (yyvsp[(2) - (3)].c), fcmp_JacobianMethod_Name)) < 0) vyyerror("Unknown Jacobian method: %s", (yyvsp[(2) - (3)].c)); else DefineQuantity_S.IntegralQuantity.JacobianMethodIndex = i; Free((yyvsp[(2) - (3)].c)); ;} break; case 303: #line 3107 "ProParser.y" { DefineQuantity_S.IntegralQuantity.Symmetry = (yyvsp[(2) - (3)].i); ;} break; case 305: #line 3115 "ProParser.y" { if(DefineQuantity_S.FunctionSpaceIndex >= 0) { if(DefineQuantity_S.Type == LOCALQUANTITY) { int i; if((i = List_ISearchSeq (((struct FunctionSpace *) List_Pointer(Problem_S.FunctionSpace, DefineQuantity_S.FunctionSpaceIndex))->SubSpace, (yyvsp[(2) - (3)].c), fcmp_SubSpace_Name)) < 0) vyyerror("Unknown SubSpace: %s", (yyvsp[(2) - (3)].c)); else { DefineQuantity_S.IndexInFunctionSpace = ((struct SubSpace *) List_Pointer (((struct FunctionSpace *) List_Pointer(Problem_S.FunctionSpace, DefineQuantity_S.FunctionSpaceIndex))->SubSpace, i)) ->BasisFunction; } } else if(DefineQuantity_S.Type == GLOBALQUANTITY) { List_Read(Problem_S.FunctionSpace, DefineQuantity_S.FunctionSpaceIndex, &FunctionSpace_S); int i; if((i = List_ISearchSeq(FunctionSpace_S.GlobalQuantity, (yyvsp[(2) - (3)].c), fcmp_GlobalQuantity_Name)) < 0) { vyyerror("Unknown GlobalQuantity: %s", (yyvsp[(2) - (3)].c)); } else { DefineQuantity_S.IndexInFunctionSpace = List_Create(1, 1, sizeof(int)); List_Add(DefineQuantity_S.IndexInFunctionSpace, &i); } } } Free((yyvsp[(2) - (3)].c)); ;} break; case 306: #line 3157 "ProParser.y" { (yyval.l) = List_Create(6, 6, sizeof(struct EquationTerm)); ;} break; case 307: #line 3162 "ProParser.y" { List_Add((yyval.l) = (yyvsp[(1) - (2)].l), &EquationTerm_S); ;} break; case 308: #line 3167 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (2)].l); ;} break; case 309: #line 3176 "ProParser.y" { EquationTerm_S.Type = GALERKIN; ;} break; case 310: #line 3179 "ProParser.y" { EquationTerm_S.Type = DERHAM; ;} break; case 311: #line 3182 "ProParser.y" { EquationTerm_S.Type = GLOBALTERM; ;} break; case 312: #line 3185 "ProParser.y" { EquationTerm_S.Type = GLOBALEQUATION; ;} break; case 313: #line 3192 "ProParser.y" { EquationTerm_S.Case.GlobalEquation.Type = NETWORK; EquationTerm_S.Case.GlobalEquation.ConstraintIndex = -1; EquationTerm_S.Case.GlobalEquation.GlobalEquationTerm = NULL; ;} break; case 315: #line 3203 "ProParser.y" { EquationTerm_S.Case.GlobalEquation.Type = Get_DefineForString(Constraint_Type, (yyvsp[(2) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of GlobalEquation: %s", (yyvsp[(2) - (3)].c)); Get_Valid_SXD(Constraint_Type); } Free((yyvsp[(2) - (3)].c)); ;} break; case 316: #line 3213 "ProParser.y" { int i; if((i = List_ISearchSeq(Problem_S.Constraint, (yyvsp[(2) - (3)].c), fcmp_Constraint_Name)) >= 0) EquationTerm_S.Case.GlobalEquation.ConstraintIndex = i; else EquationTerm_S.Case.GlobalEquation.ConstraintIndex = -1; Free((yyvsp[(2) - (3)].c)); ;} break; case 317: #line 3224 "ProParser.y" { if(!EquationTerm_S.Case.GlobalEquation.GlobalEquationTerm) EquationTerm_S.Case.GlobalEquation.GlobalEquationTerm = List_Create(3, 3, sizeof(struct GlobalEquationTerm)); List_Add(EquationTerm_S.Case.GlobalEquation.GlobalEquationTerm, &GlobalEquationTerm_S); ;} break; case 318: #line 3238 "ProParser.y" { GlobalEquationTerm_S.DefineQuantityIndexNode = -1; GlobalEquationTerm_S.DefineQuantityIndexLoop = -1; GlobalEquationTerm_S.DefineQuantityIndexEqu = -1; GlobalEquationTerm_S.InIndex = -1; ;} break; case 320: #line 3249 "ProParser.y" { if(!strcmp((yyvsp[(1) - (3)].c), "Node")) GlobalEquationTerm_S.DefineQuantityIndexNode = (yyvsp[(2) - (3)].t).Int2; else if(!strcmp((yyvsp[(1) - (3)].c), "Loop")) GlobalEquationTerm_S.DefineQuantityIndexLoop = (yyvsp[(2) - (3)].t).Int2; else if(!strcmp((yyvsp[(1) - (3)].c), "Equation")) GlobalEquationTerm_S.DefineQuantityIndexEqu = (yyvsp[(2) - (3)].t).Int2; else vyyerror("Unknown global equation term: %s", (yyvsp[(1) - (3)].c)); Free((yyvsp[(1) - (3)].c)); ;} break; case 321: #line 3261 "ProParser.y" { GlobalEquationTerm_S.InIndex = Num_Group(&Group_S, (char*)"FO_In", (yyvsp[(2) - (3)].i)); ;} break; case 322: #line 3269 "ProParser.y" { EquationTerm_S.Case.LocalTerm.Term.TypeTimeDerivative = NODT_; EquationTerm_S.Case.LocalTerm.Term.TypeOperatorEqu = NOOP; EquationTerm_S.Case.LocalTerm.Term.TypeOperatorDof = NOOP; EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexEqu = -1; EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexDof = -1; EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexNoDof = -1; EquationTerm_S.Case.LocalTerm.Term.WholeQuantity = NULL; EquationTerm_S.Case.LocalTerm.Term.DofIndexInWholeQuantity = -1; EquationTerm_S.Case.LocalTerm.Term.DofInTrace = 0; EquationTerm_S.Case.LocalTerm.InIndex = -1; EquationTerm_S.Case.LocalTerm.IntegrationMethodIndex = -1; EquationTerm_S.Case.LocalTerm.MatrixIndex = -1; EquationTerm_S.Case.LocalTerm.JacobianMethodIndex = -1; EquationTerm_S.Case.LocalTerm.ExpressionIndexForMetricTensor = -1; EquationTerm_S.Case.LocalTerm.Active = NULL; EquationTerm_S.Case.LocalTerm.Full_Matrix = 0; ;} break; case 324: #line 3294 "ProParser.y" { EquationTerm_S.Case.LocalTerm.Term.TypeTimeDerivative = Type_TermOperator; Current_DofIndexInWholeQuantity = -1; Current_NoDofIndexInWholeQuantity = -1; List_Reset(ListOfPointer_L); ;} break; case 325: #line 3302 "ProParser.y" { EquationTerm_S.Case.LocalTerm.Term.WholeQuantity = (yyvsp[(4) - (4)].l); EquationTerm_S.Case.LocalTerm.Term.DofIndexInWholeQuantity = Current_DofIndexInWholeQuantity; WholeQuantity_P = (struct WholeQuantity*) List_Pointer(EquationTerm_S.Case.LocalTerm.Term.WholeQuantity, 0); if(Current_DofIndexInWholeQuantity == -4){ EquationTerm_S.Case.LocalTerm.Term.DofInTrace = 1; EquationTerm_S.Case.LocalTerm.Term.TypeOperatorDof = TypeOperatorDofInTrace; EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexDof = DefineQuantityIndexDofInTrace; } else if(Current_DofIndexInWholeQuantity >= 0) { EquationTerm_S.Case.LocalTerm.Term.TypeOperatorDof = (WholeQuantity_P+Current_DofIndexInWholeQuantity)-> Case.OperatorAndQuantity.TypeOperator; EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexDof = (WholeQuantity_P+Current_DofIndexInWholeQuantity)-> Case.OperatorAndQuantity.Index; } else { /* No Dof{} */ EquationTerm_S.Case.LocalTerm.Term.TypeOperatorDof = NOOP; EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexDof = -1; } if(Current_NoDofIndexInWholeQuantity >= 0) { EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexNoDof = (WholeQuantity_P+Current_NoDofIndexInWholeQuantity)-> Case.OperatorAndQuantity.Index; } else { /* No NoDof{} */ EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexNoDof = -1; } /* Check if the WholeQuantity is a Canonical Form of type 'expr[] * Dof{}'*/ if((List_Nbr(EquationTerm_S.Case.LocalTerm.Term.WholeQuantity) == 3) && ((WholeQuantity_P+0)->Type == WQ_EXPRESSION) && ((WholeQuantity_P+1)->Type == WQ_OPERATORANDQUANTITY) && ((WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR) && ((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME) && (Current_DofIndexInWholeQuantity == 1)) { EquationTerm_S.Case.LocalTerm.Term.CanonicalWholeQuantity = CWQ_EXP_TIME_DOF; EquationTerm_S.Case.LocalTerm.Term.ExpressionIndexForCanonical = (WholeQuantity_P+0)->Case.Expression.Index; } else if((List_Nbr(EquationTerm_S.Case.LocalTerm.Term.WholeQuantity) == 3) && ((WholeQuantity_P+0)->Type == WQ_BUILTINFUNCTION) && ((WholeQuantity_P+1)->Type == WQ_OPERATORANDQUANTITY) && ((WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR) && (Current_DofIndexInWholeQuantity == 1)) { if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME) EquationTerm_S.Case.LocalTerm.Term.CanonicalWholeQuantity = CWQ_FCT_TIME_DOF; if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) EquationTerm_S.Case.LocalTerm.Term.CanonicalWholeQuantity = CWQ_FCT_PVEC_DOF; EquationTerm_S.Case.LocalTerm.Term.FunctionForCanonical.Fct = (WholeQuantity_P+0)->Case.Function.Fct; EquationTerm_S.Case.LocalTerm.Term.FunctionForCanonical.NbrParameters = (WholeQuantity_P+0)->Case.Function.NbrParameters; EquationTerm_S.Case.LocalTerm.Term.FunctionForCanonical.Para = (WholeQuantity_P+0)->Case.Function.Para; } else if((List_Nbr(EquationTerm_S.Case.LocalTerm.Term.WholeQuantity) == 1) && ((WholeQuantity_P+0)->Type == WQ_OPERATORANDQUANTITY) && (Current_DofIndexInWholeQuantity == 0)) { EquationTerm_S.Case.LocalTerm.Term.CanonicalWholeQuantity = CWQ_DOF; } else { EquationTerm_S.Case.LocalTerm.Term.CanonicalWholeQuantity = CWQ_NONE; } ;} break; case 326: #line 3381 "ProParser.y" { EquationTerm_S.Case.LocalTerm.Term.TypeOperatorEqu = Quantity_TypeOperator; EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexEqu = Quantity_Index; EquationTerm_S.Case.LocalTerm.Term.CanonicalWholeQuantity_Equ = CWQ_NONE; WholeQuantity_P = (struct WholeQuantity*) List_Pointer((yyvsp[(7) - (9)].l), 0); if(List_Nbr((yyvsp[(7) - (9)].l)) == 1){ if((WholeQuantity_P+0)->Type != WQ_OPERATORANDQUANTITY) vyyerror("Missing Quantity in Equation"); } else if(List_Nbr((yyvsp[(7) - (9)].l)) == 3 && ((WholeQuantity_P+0)->Type == WQ_EXPRESSION && (WholeQuantity_P+1)->Type == WQ_OPERATORANDQUANTITY && (WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR)) { // FIXME: should also add the case (BUILTINFUNCTION OPERATORANDQUANTITY BINARYOPERATOR) EquationTerm_S.Case.LocalTerm.Term.CanonicalWholeQuantity_Equ = CWQ_EXP_TIME_DOF; EquationTerm_S.Case.LocalTerm.Term.ExpressionIndexForCanonical_Equ = (WholeQuantity_P+0)->Case.Expression.Index; EquationTerm_S.Case.LocalTerm.Term.OperatorTypeForCanonical_Equ = (WholeQuantity_P+2)->Case.Operator.TypeOperator; } else if(List_Nbr((yyvsp[(7) - (9)].l)) == 2 && ((WholeQuantity_P+0)->Type == WQ_OPERATORANDQUANTITY && (WholeQuantity_P+1)->Type == WQ_BUILTINFUNCTION)) { EquationTerm_S.Case.LocalTerm.Term.CanonicalWholeQuantity_Equ = CWQ_FCT_DOF; EquationTerm_S.Case.LocalTerm.Term.BuiltInFunction_Equ = (WholeQuantity_P+1)->Case.Function.Fct; } else{ vyyerror("Unrecognized quantity structure in Equation"); } Pro_DefineQuantityIndex (EquationTerm_S.Case.LocalTerm.Term.WholeQuantity, EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexEqu, &EquationTerm_S.Case.LocalTerm.Term.NbrQuantityIndex, &EquationTerm_S.Case.LocalTerm.Term.QuantityIndexTable, &EquationTerm_S.Case.LocalTerm.Term.QuantityTraceGroupIndexTable); EquationTerm_S.Case.LocalTerm.Term.QuantityIndexPost = 0; for(int i = 0; i < EquationTerm_S.Case.LocalTerm.Term.NbrQuantityIndex; i++) { if((EquationTerm_S.Case.LocalTerm.Term.QuantityIndexTable[i] != EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexEqu) && (EquationTerm_S.Case.LocalTerm.Term.QuantityIndexTable[i] != EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexDof)) { EquationTerm_S.Case.LocalTerm.Term.QuantityIndexPost = 1; break; } } ;} break; case 327: #line 3436 "ProParser.y" { EquationTerm_S.Case.LocalTerm.InIndex = Num_Group(&Group_S, (char*)"FO_In", (yyvsp[(2) - (3)].i)); ;} break; case 328: #line 3441 "ProParser.y" { int i; if((i = List_ISearchSeq(Problem_S.JacobianMethod, (yyvsp[(2) - (3)].c), fcmp_JacobianMethod_Name)) < 0) vyyerror("Unknown Jacobian method: %s",(yyvsp[(2) - (3)].c)); else EquationTerm_S.Case.LocalTerm.JacobianMethodIndex = i; Free((yyvsp[(2) - (3)].c)); ;} break; case 329: #line 3452 "ProParser.y" { int i; if((i = List_ISearchSeq(Problem_S.IntegrationMethod, (yyvsp[(2) - (3)].c), fcmp_IntegrationMethod_Name)) < 0) vyyerror("Unknown Integration method: %s", (yyvsp[(2) - (3)].c)); else EquationTerm_S.Case.LocalTerm.IntegrationMethodIndex = i; Free((yyvsp[(2) - (3)].c)); ;} break; case 330: #line 3463 "ProParser.y" { EquationTerm_S.Case.LocalTerm.Full_Matrix = 1; ;} break; case 331: #line 3468 "ProParser.y" { if((yyvsp[(3) - (5)].i) == 1 || (yyvsp[(3) - (5)].i) == 2 || (yyvsp[(3) - (5)].i) == 3) EquationTerm_S.Case.LocalTerm.MatrixIndex = (yyvsp[(3) - (5)].i); else vyyerror("Unknown Matrix123: %d", (yyvsp[(3) - (5)].i)); ;} break; case 332: #line 3475 "ProParser.y" { EquationTerm_S.Case.LocalTerm.ExpressionIndexForMetricTensor = (yyvsp[(2) - (3)].i); ;} break; case 333: #line 3484 "ProParser.y" { EquationTerm_S.Case.GlobalTerm.TypeTimeDerivative = NODT_; EquationTerm_S.Case.GlobalTerm.DefineQuantityIndex = -1; EquationTerm_S.Case.GlobalTerm.Term.TypeTimeDerivative = NODT_; EquationTerm_S.Case.GlobalTerm.Term.TypeOperatorEqu = NOOP; EquationTerm_S.Case.GlobalTerm.Term.TypeOperatorDof = NOOP; EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexEqu = -1; EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexDof = -1; EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexNoDof = -1; EquationTerm_S.Case.GlobalTerm.Term.WholeQuantity = NULL; EquationTerm_S.Case.GlobalTerm.Term.DofIndexInWholeQuantity = -1; EquationTerm_S.Case.GlobalTerm.InIndex = -1; ;} break; case 335: #line 3504 "ProParser.y" { EquationTerm_S.Case.GlobalTerm.InIndex = Num_Group(&Group_S, (char*)"FO_In", (yyvsp[(2) - (3)].i)); ;} break; case 336: #line 3509 "ProParser.y" { EquationTerm_S.Case.GlobalTerm.Term.TypeTimeDerivative = Type_TermOperator; Current_DofIndexInWholeQuantity = -1; Current_NoDofIndexInWholeQuantity = -1; List_Reset(ListOfPointer_L); ;} break; case 337: #line 3517 "ProParser.y" { EquationTerm_S.Case.GlobalTerm.Term.WholeQuantity = (yyvsp[(4) - (4)].l); EquationTerm_S.Case.GlobalTerm.Term.DofIndexInWholeQuantity = Current_DofIndexInWholeQuantity; WholeQuantity_P = (struct WholeQuantity*) List_Pointer(EquationTerm_S.Case.GlobalTerm.Term.WholeQuantity, 0); if(Current_DofIndexInWholeQuantity >= 0) { EquationTerm_S.Case.GlobalTerm.Term.TypeOperatorDof = (WholeQuantity_P+Current_DofIndexInWholeQuantity)-> Case.OperatorAndQuantity.TypeOperator; EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexDof = (WholeQuantity_P+Current_DofIndexInWholeQuantity)-> Case.OperatorAndQuantity.Index; } else { /* No Dof{} */ EquationTerm_S.Case.GlobalTerm.Term.TypeOperatorDof = NOOP; EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexDof = -1; } if(Current_NoDofIndexInWholeQuantity >= 0) { EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexNoDof = (WholeQuantity_P+Current_NoDofIndexInWholeQuantity)-> Case.OperatorAndQuantity.Index; } else { /* No NoDof{} */ EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexNoDof = -1; } /* Check if the WholeQuantity is a Canonical Form of type 'expr[] * Dof{}'*/ if((List_Nbr(EquationTerm_S.Case.GlobalTerm.Term.WholeQuantity) == 3) && ((WholeQuantity_P+0)->Type == WQ_EXPRESSION) && ((WholeQuantity_P+1)->Type == WQ_OPERATORANDQUANTITY) && ((WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR) && ((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME) && (Current_DofIndexInWholeQuantity == 1)) { EquationTerm_S.Case.GlobalTerm.Term.CanonicalWholeQuantity = CWQ_EXP_TIME_DOF; EquationTerm_S.Case.GlobalTerm.Term.ExpressionIndexForCanonical = (WholeQuantity_P+0)->Case.Expression.Index; } else if((List_Nbr(EquationTerm_S.Case.GlobalTerm.Term.WholeQuantity) == 1) && ((WholeQuantity_P+0)->Type == WQ_OPERATORANDQUANTITY) && (Current_DofIndexInWholeQuantity == 0)) { EquationTerm_S.Case.GlobalTerm.Term.CanonicalWholeQuantity = CWQ_DOF; } else { EquationTerm_S.Case.GlobalTerm.Term.CanonicalWholeQuantity = CWQ_NONE; } ;} break; case 338: #line 3572 "ProParser.y" { EquationTerm_S.Case.GlobalTerm.Term.TypeOperatorEqu = (yyvsp[(7) - (9)].t).Int1; EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexEqu = (yyvsp[(7) - (9)].t).Int2; Pro_DefineQuantityIndex (EquationTerm_S.Case.GlobalTerm.Term.WholeQuantity, EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexEqu, &EquationTerm_S.Case.GlobalTerm.Term.NbrQuantityIndex, &EquationTerm_S.Case.GlobalTerm.Term.QuantityIndexTable, &EquationTerm_S.Case.GlobalTerm.Term.QuantityTraceGroupIndexTable); ;} break; case 339: #line 3589 "ProParser.y" { Type_TermOperator = NODT_ ; ;} break; case 340: #line 3590 "ProParser.y" { Type_TermOperator = DT_ ; ;} break; case 341: #line 3591 "ProParser.y" { Type_TermOperator = DTDOF_ ; ;} break; case 342: #line 3592 "ProParser.y" { Type_TermOperator = DTDT_ ; ;} break; case 343: #line 3593 "ProParser.y" { Type_TermOperator = DTDTDOF_ ; ;} break; case 344: #line 3594 "ProParser.y" { Type_TermOperator = JACNL_ ; ;} break; case 345: #line 3595 "ProParser.y" { Type_TermOperator = DTDOFJACNL_; ;} break; case 346: #line 3596 "ProParser.y" { Type_TermOperator = NEVERDT_ ; ;} break; case 347: #line 3597 "ProParser.y" { Type_TermOperator = DTNL_ ; ;} break; case 348: #line 3604 "ProParser.y" { (yyval.t).Int1 = Get_DefineForString(Operator_Type, (yyvsp[(2) - (4)].c), &FlagError); if(FlagError){ vyyerror("Unknown Operator for discrete Quantity: %s", (yyvsp[(2) - (4)].c)); Get_Valid_SXD(Operator_Type); } Free((yyvsp[(2) - (4)].c)); int i; if((i = List_ISearchSeq(Formulation_S.DefineQuantity, (yyvsp[(3) - (4)].c), fcmp_DefineQuantity_Name)) < 0) vyyerror("Unknown discrete Quantity: %s", (yyvsp[(3) - (4)].c)); (yyval.t).Int2 = i; /* the following should be suppressed as soon as the test function part in the formulations is correctly treated */ Quantity_TypeOperator = (yyval.t).Int1; Quantity_Index = (yyval.t).Int2; Free((yyvsp[(3) - (4)].c)); ;} break; case 349: #line 3625 "ProParser.y" { (yyval.t).Int1 = NOOP; int i; if((i = List_ISearchSeq(Formulation_S.DefineQuantity, (yyvsp[(2) - (3)].c), fcmp_DefineQuantity_Name)) < 0) vyyerror("Unknown discrete Quantity: %s", (yyvsp[(2) - (3)].c)); (yyval.t).Int2 = i; /* the following should be suppressed as soon as the test function part in the formulations is correctly treated */ Quantity_TypeOperator = (yyval.t).Int1; Quantity_Index = (yyval.t).Int2; Free((yyvsp[(2) - (3)].c)); ;} break; case 350: #line 3649 "ProParser.y" { if(!Problem_S.Resolution) Problem_S.Resolution = List_Create(10, 5, sizeof (struct Resolution)); ;} break; case 352: #line 3659 "ProParser.y" { List_Add(Problem_S.Resolution, &Resolution_S); ;} break; case 354: #line 3670 "ProParser.y" { Resolution_S.Name = NULL; Resolution_S.DefineSystem = NULL; Resolution_S.Operation = NULL; ;} break; case 356: #line 3682 "ProParser.y" { Check_NameOfStructNotExist("Resolution", Problem_S.Resolution, (yyvsp[(2) - (3)].c), fcmp_Resolution_Name); Resolution_S.Name = (yyvsp[(2) - (3)].c); ;} break; case 357: #line 3689 "ProParser.y" { Resolution_S.DefineSystem = (yyvsp[(3) - (4)].l); ;} break; case 358: #line 3692 "ProParser.y" { Operation_L = List_Create(5, 5, sizeof(struct Operation)); ;} break; case 359: #line 3694 "ProParser.y" { Resolution_S.Operation = (yyvsp[(4) - (5)].l); List_Delete(Operation_L); ;} break; case 361: #line 3702 "ProParser.y" { (yyval.l) = Current_System_L = List_Create(6, 6, sizeof (struct DefineSystem)); ;} break; case 362: #line 3707 "ProParser.y" { int i ; if ((i = List_ISearchSeq(Current_System_L, DefineSystem_S.Name, fcmp_DefineSystem_Name)) < 0) List_Add((yyval.l) = Current_System_L = (yyvsp[(1) - (4)].l), &DefineSystem_S) ; else List_Write(Current_System_L, i, &DefineSystem_S) ; ;} break; case 363: #line 3716 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (2)].l); ;} break; case 364: #line 3725 "ProParser.y" { DefineSystem_S.Name = NULL; DefineSystem_S.Type = VAL_REAL; DefineSystem_S.FormulationIndex = NULL; DefineSystem_S.MeshName = NULL; DefineSystem_S.AdaptName = NULL; DefineSystem_S.FrequencyValue = NULL; DefineSystem_S.SolverDataFileName = NULL; DefineSystem_S.OriginSystemIndex = NULL; DefineSystem_S.DestinationSystemName = NULL; DefineSystem_S.DestinationSystemIndex = -1; ;} break; case 366: #line 3744 "ProParser.y" { int i; if ((i = List_ISearchSeq(Current_System_L, (yyvsp[(2) - (3)].c), fcmp_DefineSystem_Name)) < 0) DefineSystem_S.Name = (yyvsp[(2) - (3)].c) ; else List_Read(Current_System_L, i, &DefineSystem_S) ; ;} break; case 367: #line 3753 "ProParser.y" { DefineSystem_S.Type = Get_DefineForString(DefineSystem_Type, (yyvsp[(2) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of System: %s", (yyvsp[(2) - (3)].c)); Get_Valid_SXD(DefineSystem_Type); } Free((yyvsp[(2) - (3)].c)); ;} break; case 368: #line 3762 "ProParser.y" { DefineSystem_S.FormulationIndex = (yyvsp[(2) - (3)].l); ;} break; case 369: #line 3765 "ProParser.y" { DefineSystem_S.MeshName = (yyvsp[(2) - (3)].c); ;} break; case 370: #line 3770 "ProParser.y" { if (!DefineSystem_S.OriginSystemIndex) { DefineSystem_S.OriginSystemIndex = (yyvsp[(2) - (3)].l) ; } else { for (int i = 0 ; i < List_Nbr((yyvsp[(2) - (3)].l)) ; i++) List_Add(DefineSystem_S.OriginSystemIndex, (int *)List_Pointer((yyvsp[(2) - (3)].l), i) ) ; } ;} break; case 371: #line 3781 "ProParser.y" { DefineSystem_S.DestinationSystemName = (yyvsp[(2) - (3)].c); ;} break; case 372: #line 3786 "ProParser.y" { DefineSystem_S.FrequencyValue = (yyvsp[(2) - (3)].l); DefineSystem_S.Type = VAL_COMPLEX; ;} break; case 373: #line 3791 "ProParser.y" { DefineSystem_S.SolverDataFileName = (yyvsp[(2) - (3)].c); ;} break; case 375: #line 3802 "ProParser.y" { (yyval.l) = List_Create(1, 1, sizeof(int)); int i; if((i = List_ISearchSeq(Problem_S.Formulation, (yyvsp[(1) - (1)].c), fcmp_Formulation_Name)) < 0) vyyerror("Unknown Formulation: %s", (yyvsp[(1) - (1)].c)); else List_Add((yyval.l), &i); Free((yyvsp[(1) - (1)].c)); ;} break; case 376: #line 3812 "ProParser.y" { (yyval.l) = (yyvsp[(2) - (3)].l); ;} break; case 377: #line 3819 "ProParser.y" { (yyval.l) = List_Create(2, 2, sizeof(int)); ;} break; case 378: #line 3822 "ProParser.y" { int i; if((i = List_ISearchSeq(Problem_S.Formulation, (yyvsp[(3) - (3)].c), fcmp_Formulation_Name)) < 0) vyyerror("Unknown Formulation: %s", (yyvsp[(3) - (3)].c)); else List_Add((yyvsp[(1) - (3)].l), &i); (yyval.l) = (yyvsp[(1) - (3)].l); Free((yyvsp[(3) - (3)].c)); ;} break; case 379: #line 3835 "ProParser.y" { (yyval.l) = List_Create(1, 1, sizeof(int)); int i; if((i = List_ISearchSeq(Current_System_L, (yyvsp[(1) - (1)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(1) - (1)].c)); else List_Add((yyval.l), &i); Free((yyvsp[(1) - (1)].c)); ;} break; case 380: #line 3846 "ProParser.y" { (yyval.l) = (yyvsp[(2) - (3)].l); ;} break; case 381: #line 3852 "ProParser.y" { (yyval.l) = List_Create(2, 2, sizeof(int)); ;} break; case 382: #line 3855 "ProParser.y" { int i; if((i = List_ISearchSeq(Current_System_L, (yyvsp[(3) - (3)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (3)].c)); else List_Add((yyvsp[(1) - (3)].l), &i); (yyval.l) = (yyvsp[(1) - (3)].l); Free((yyvsp[(3) - (3)].c)); ;} break; case 383: #line 3868 "ProParser.y" { (yyval.l) = List_Create(6, 6, sizeof (struct Operation)); Operation_S.Type = OPERATION_NONE; Operation_S.DefineSystemIndex = -1; Operation_S.Rank = -1; List_Add(Operation_L, &Operation_S); ;} break; case 384: #line 3877 "ProParser.y" { if(((struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1))->Type != OPERATION_NONE) List_Add((yyval.l) = (yyvsp[(1) - (2)].l), (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1)); ;} break; case 385: #line 3886 "ProParser.y" { (yyval.i) = -1; ;} break; case 386: #line 3888 "ProParser.y" { (yyval.i) = (int)(yyvsp[(2) - (2)].d); ;} break; case 387: #line 3896 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = Get_DefineForString(Operation_Type, (yyvsp[(1) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of Operation: %s", (yyvsp[(1) - (3)].c)); Get_Valid_SXD(Operation_Type); } Free((yyvsp[(1) - (3)].c)); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(2) - (3)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(2) - (3)].c)); Free((yyvsp[(2) - (3)].c)); Operation_P->DefineSystemIndex = i; if(Operation_P->Type == OPERATION_GENERATE || Operation_P->Type == OPERATION_GENERATERHS || Operation_P->Type == OPERATION_GENERATEJAC || Operation_P->Type == OPERATION_GENERATESEPARATE) Operation_P->Case.Generate.GroupIndex = -1; ;} break; case 388: #line 3920 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SETTIME; Operation_P->Case.SetTime.ExpressionIndex = (yyvsp[(2) - (3)].i); ;} break; case 389: #line 3927 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_TIMELOOPTHETA; ;} break; case 390: #line 3933 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_TIMELOOPNEWMARK; ;} break; case 391: #line 3939 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_ITERATIVELOOP; ;} break; case 392: #line 3945 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_ITERATIVETIMEREDUCTION; ;} break; case 393: #line 3953 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = Get_DefineForString(Operation_Type, (yyvsp[(1) - (6)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of Operation: %s", (yyvsp[(1) - (6)].c)); Get_Valid_SXD(Operation_Type); } Free((yyvsp[(1) - (6)].c)); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (6)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (6)].c)); Free((yyvsp[(3) - (6)].c)); Operation_P->DefineSystemIndex = i; if(Operation_P->Type == OPERATION_GENERATE || Operation_P->Type == OPERATION_GENERATERHS || Operation_P->Type == OPERATION_GENERATEJAC || Operation_P->Type == OPERATION_GENERATESEPARATE) Operation_P->Case.Generate.GroupIndex = -1; if((yyvsp[(4) - (6)].i) >= -1) Operation_P->Rank = (yyvsp[(4) - (6)].i); else { Message::Warning("Negative MPI Rank"); Operation_P->Rank = -1; } ;} break; case 394: #line 3983 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SETTIME; Operation_P->Case.SetTime.ExpressionIndex = (yyvsp[(3) - (5)].i); ;} break; case 395: #line 3990 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SETCOMMSELF; Operation_P->Rank = -1; ;} break; case 396: #line 3997 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SETCOMMWORLD; Operation_P->Rank = -1; ;} break; case 397: #line 4004 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_BARRIER; Operation_P->Rank = -1; ;} break; case 398: #line 4011 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_BREAK; ;} break; case 399: #line 4017 "ProParser.y" { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_TEST; Operation_P->Case.Test.ExpressionIndex = (yyvsp[(3) - (7)].i); Operation_P->Case.Test.Operation_True = (yyvsp[(6) - (7)].l); Operation_P->Case.Test.Operation_False = NULL; ;} break; case 400: #line 4028 "ProParser.y" { List_Pop(Operation_L); List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_TEST; Operation_P->Case.Test.ExpressionIndex = (yyvsp[(3) - (11)].i); Operation_P->Case.Test.Operation_True = (yyvsp[(6) - (11)].l); Operation_P->Case.Test.Operation_False = (yyvsp[(10) - (11)].l); ;} break; case 401: #line 4040 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SETFREQUENCY; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (7)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (7)].c)); Free((yyvsp[(3) - (7)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.SetFrequency.ExpressionIndex = (yyvsp[(5) - (7)].i); ;} break; case 402: #line 4053 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_GENERATEONLY; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (7)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (7)].c)); Free((yyvsp[(3) - (7)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.GenerateOnly.MatrixIndex_L = List_Create(List_Nbr((yyvsp[(5) - (7)].l)),1,sizeof(int)); for(int i = 0; i < List_Nbr((yyvsp[(5) - (7)].l)); i++){ double d; List_Read((yyvsp[(5) - (7)].l),i,&d); int j = (int)d; List_Add(Operation_P->Case.GenerateOnly.MatrixIndex_L, &j); } List_Delete((yyvsp[(5) - (7)].l)); ;} break; case 403: #line 4075 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_GENERATEONLYJAC; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (7)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (7)].c)); Free((yyvsp[(3) - (7)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.GenerateOnly.MatrixIndex_L = List_Create(List_Nbr((yyvsp[(5) - (7)].l)),1,sizeof(int)); for(int i = 0; i < List_Nbr((yyvsp[(5) - (7)].l)); i++){ double d; List_Read((yyvsp[(5) - (7)].l),i,&d); int j = (int)d; List_Add(Operation_P->Case.GenerateOnly.MatrixIndex_L, &j); } List_Delete((yyvsp[(5) - (7)].l)); ;} break; case 404: #line 4097 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_UPDATE; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (5)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (5)].c)); Free((yyvsp[(3) - (5)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.Update.ExpressionIndex = -1; ;} break; case 405: #line 4110 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_UPDATE; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (7)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (7)].c)); Free((yyvsp[(3) - (7)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.Update.ExpressionIndex = (yyvsp[(5) - (7)].i); ;} break; case 406: #line 4123 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_UPDATECONSTRAINT; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (9)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (9)].c)); Free((yyvsp[(3) - (9)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.UpdateConstraint.GroupIndex = Num_Group(&Group_S, (char*)"OP_UpdateCst", (yyvsp[(5) - (9)].i)); Operation_P->Case.UpdateConstraint.Type = Get_DefineForString(Constraint_Type, (yyvsp[(7) - (9)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of Constraint: %s", (yyvsp[(7) - (9)].c)); Get_Valid_SXD(Constraint_Type); } Free((yyvsp[(7) - (9)].c)); ;} break; case 407: #line 4144 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1) ; Operation_P->Type = OPERATION_UPDATECONSTRAINT ; int i; if ((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (5)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (5)].c)) ; Free((yyvsp[(3) - (5)].c)) ; Operation_P->DefineSystemIndex = i ; Operation_P->Case.UpdateConstraint.GroupIndex = -1; Operation_P->Case.UpdateConstraint.Type = ASSIGN; ;} break; case 408: #line 4158 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_FOURIERTRANSFORM; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (9)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (9)].c)); Free((yyvsp[(3) - (9)].c)); Operation_P->Case.FourierTransform.DefineSystemIndex[0] = i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(5) - (9)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(5) - (9)].c)); Free((yyvsp[(5) - (9)].c)); Operation_P->Case.FourierTransform.DefineSystemIndex[1] = i; Operation_P->Case.FourierTransform.Frequency = (yyvsp[(7) - (9)].l); ;} break; case 409: #line 4176 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_FOURIERTRANSFORM2; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (9)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (9)].c)); Free((yyvsp[(3) - (9)].c)); Operation_P->Case.FourierTransform2.DefineSystemIndex[0] = i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(5) - (9)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(5) - (9)].c)); Free((yyvsp[(5) - (9)].c)); Operation_P->Case.FourierTransform2.DefineSystemIndex[1] = i; Operation_P->Case.FourierTransform2.Period = (yyvsp[(7) - (9)].d); Operation_P->Case.FourierTransform2.Period_sofar = 0.; Operation_P->Case.FourierTransform2.Scales = NULL; ;} break; case 410: #line 4196 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_LANCZOS; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (11)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (11)].c)); Free((yyvsp[(3) - (11)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.Lanczos.Size = (int)(yyvsp[(5) - (11)].d); Operation_P->Case.Lanczos.Save = List_Create(List_Nbr((yyvsp[(7) - (11)].l)), 1, sizeof(int)); for(int l = 0; l < List_Nbr((yyvsp[(7) - (11)].l)); l++) { double d; List_Read((yyvsp[(7) - (11)].l), l, &d); int j = (int)d; List_Add(Operation_P->Case.Lanczos.Save, &j); } List_Delete((yyvsp[(7) - (11)].l)); Operation_P->Case.Lanczos.Shift = (yyvsp[(9) - (11)].d); ;} break; case 411: #line 4219 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_EIGENSOLVE; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (11)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (11)].c)); Free((yyvsp[(3) - (11)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.EigenSolve.NumEigenvalues = (int)(yyvsp[(5) - (11)].d); Operation_P->Case.EigenSolve.Shift_r = (yyvsp[(7) - (11)].d); Operation_P->Case.EigenSolve.Shift_i = (yyvsp[(9) - (11)].d); ;} break; case 412: #line 4234 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_EIGENSOLVEJAC; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (11)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (11)].c)); Free((yyvsp[(3) - (11)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.EigenSolve.NumEigenvalues = (int)(yyvsp[(5) - (11)].d); Operation_P->Case.EigenSolve.Shift_r = (yyvsp[(7) - (11)].d); Operation_P->Case.EigenSolve.Shift_i = (yyvsp[(9) - (11)].d); ;} break; case 413: #line 4249 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_EVALUATE; Operation_P->Case.Evaluate.ExpressionIndex = (int)(yyvsp[(3) - (6)].i); if((yyvsp[(4) - (6)].i) >= -1) Operation_P->Rank = (yyvsp[(4) - (6)].i); else { Message::Warning("Negative MPI Rank"); Operation_P->Rank = -1; } ;} break; case 414: #line 4261 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1) ; Operation_P->Type = OPERATION_SELECTCORRECTION; int i; if ((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (7)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (7)].c)) ; Free((yyvsp[(3) - (7)].c)) ; Operation_P->DefineSystemIndex = i ; Operation_P->Case.SelectCorrection.Iteration = (int)(yyvsp[(5) - (7)].d) ; ;} break; case 415: #line 4274 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1) ; Operation_P->Type = OPERATION_ADDCORRECTION; int i; if ((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (5)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (5)].c)) ; Free((yyvsp[(3) - (5)].c)) ; Operation_P->DefineSystemIndex = i ; Operation_P->Case.AddCorrection.Alpha = 1. ; ;} break; case 416: #line 4287 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1) ; Operation_P->Type = OPERATION_ADDCORRECTION; int i; if ((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (7)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (7)].c)) ; Free((yyvsp[(3) - (7)].c)) ; Operation_P->DefineSystemIndex = i ; Operation_P->Case.AddCorrection.Alpha = (yyvsp[(5) - (7)].d) ; ;} break; case 417: #line 4300 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1) ; Operation_P->Type = OPERATION_MULTIPLYSOLUTION; int i; if ((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (7)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (7)].c)) ; Free((yyvsp[(3) - (7)].c)) ; Operation_P->DefineSystemIndex = i ; Operation_P->Case.MultiplySolution.Alpha = (yyvsp[(5) - (7)].d) ; ;} break; case 418: #line 4313 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1) ; Operation_P->Type = OPERATION_ADDOPPOSITEFULLSOLUTION; int i; if ((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (5)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (5)].c)) ; Free((yyvsp[(3) - (5)].c)) ; Operation_P->DefineSystemIndex = i ; ;} break; case 419: #line 4326 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_PERTURBATION; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (17)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (17)].c)); Free((yyvsp[(3) - (17)].c)); Operation_P->DefineSystemIndex = i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(5) - (17)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(5) - (17)].c)); Free((yyvsp[(5) - (17)].c)); Operation_P->Case.Perturbation.DefineSystemIndex2 = i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(7) - (17)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(7) - (17)].c)); Free((yyvsp[(7) - (17)].c)); Operation_P->Case.Perturbation.DefineSystemIndex3 = i; Operation_P->Case.Perturbation.Size = (int)(yyvsp[(9) - (17)].d); Operation_P->Case.Perturbation.Save = List_Create(List_Nbr((yyvsp[(11) - (17)].l)), 1, sizeof(int)); for(int l = 0; l < List_Nbr((yyvsp[(11) - (17)].l)); l++) { double d; List_Read((yyvsp[(11) - (17)].l), l, &d); int j = (int)d; List_Add(Operation_P->Case.Perturbation.Save, &j); } List_Delete((yyvsp[(11) - (17)].l)); Operation_P->Case.Perturbation.Shift = (yyvsp[(13) - (17)].d); Operation_P->Case.Perturbation.PertFreq = (int)(yyvsp[(15) - (17)].d); ;} break; case 420: #line 4361 "ProParser.y" { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_TIMELOOPTHETA; Operation_P->Case.TimeLoopTheta.Time0 = (yyvsp[(3) - (13)].d); Operation_P->Case.TimeLoopTheta.TimeMax = (yyvsp[(5) - (13)].d); Operation_P->Case.TimeLoopTheta.DTimeIndex = (yyvsp[(7) - (13)].i); Operation_P->Case.TimeLoopTheta.ThetaIndex = (yyvsp[(9) - (13)].i); Operation_P->Case.TimeLoopTheta.Operation = (yyvsp[(12) - (13)].l); ;} break; case 421: #line 4374 "ProParser.y" { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_TIMELOOPNEWMARK; Operation_P->Case.TimeLoopNewmark.Time0 = (yyvsp[(3) - (15)].d); Operation_P->Case.TimeLoopNewmark.TimeMax = (yyvsp[(5) - (15)].d); Operation_P->Case.TimeLoopNewmark.DTimeIndex = (yyvsp[(7) - (15)].i); Operation_P->Case.TimeLoopNewmark.Beta = (yyvsp[(9) - (15)].d); Operation_P->Case.TimeLoopNewmark.Gamma = (yyvsp[(11) - (15)].d); Operation_P->Case.TimeLoopNewmark.Operation = (yyvsp[(14) - (15)].l); ;} break; case 422: #line 4388 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_TIMELOOPRUNGEKUTTA; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (17)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (17)].c)); Free((yyvsp[(3) - (17)].c)); Operation_P->DefineSystemIndex = i ; Operation_P->Case.TimeLoopRungeKutta.Time0 = (yyvsp[(5) - (17)].d); Operation_P->Case.TimeLoopRungeKutta.TimeMax = (yyvsp[(7) - (17)].d); Operation_P->Case.TimeLoopRungeKutta.DTimeIndex = (yyvsp[(9) - (17)].i); Operation_P->Case.TimeLoopRungeKutta.ButcherA = (yyvsp[(11) - (17)].l); Operation_P->Case.TimeLoopRungeKutta.ButcherB = (yyvsp[(13) - (17)].l); Operation_P->Case.TimeLoopRungeKutta.ButcherC = (yyvsp[(15) - (17)].l); ;} break; case 423: #line 4408 "ProParser.y" { List_Pop(Operation_L); List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_TIMELOOPADAPTIVE; Operation_P->Case.TimeLoopAdaptive.Time0 = (yyvsp[(3) - (25)].d); Operation_P->Case.TimeLoopAdaptive.TimeMax = (yyvsp[(5) - (25)].d); Operation_P->Case.TimeLoopAdaptive.DTimeInit = (yyvsp[(7) - (25)].d); Operation_P->Case.TimeLoopAdaptive.DTimeMin = (yyvsp[(9) - (25)].d); Operation_P->Case.TimeLoopAdaptive.DTimeMax = (yyvsp[(11) - (25)].d); Operation_P->Case.TimeLoopAdaptive.Scheme = (yyvsp[(13) - (25)].c); Operation_P->Case.TimeLoopAdaptive.Breakpoints_L = (yyvsp[(15) - (25)].l); Operation_P->Case.TimeLoopAdaptive.Operation = (yyvsp[(21) - (25)].l); Operation_P->Case.TimeLoopAdaptive.OperationEnd = (yyvsp[(24) - (25)].l); ;} break; case 424: #line 4427 "ProParser.y" { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_ITERATIVELOOPN; Operation_P->Case.IterativeLoop.NbrMaxIteration = (int)(yyvsp[(3) - (11)].d); Operation_P->Case.IterativeLoop.RelaxationFactorIndex = (yyvsp[(5) - (11)].i); Operation_P->Case.IterativeLoop.Operation = (yyvsp[(10) - (11)].l); ;} break; case 425: #line 4438 "ProParser.y" { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_ITERATIVELOOP; Operation_P->Case.IterativeLoop.NbrMaxIteration = (int)(yyvsp[(3) - (11)].d); Operation_P->Case.IterativeLoop.Criterion = (yyvsp[(5) - (11)].d); Operation_P->Case.IterativeLoop.RelaxationFactorIndex = (yyvsp[(7) - (11)].i); Operation_P->Case.IterativeLoop.Flag = 0; Operation_P->Case.IterativeLoop.Operation = (yyvsp[(10) - (11)].l); ;} break; case 426: #line 4451 "ProParser.y" { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_ITERATIVELOOP; Operation_P->Case.IterativeLoop.NbrMaxIteration = (int)(yyvsp[(3) - (13)].d); Operation_P->Case.IterativeLoop.Criterion = (yyvsp[(5) - (13)].d); Operation_P->Case.IterativeLoop.RelaxationFactorIndex = (yyvsp[(7) - (13)].i); Operation_P->Case.IterativeLoop.Flag = (int)(yyvsp[(9) - (13)].d); Operation_P->Case.IterativeLoop.Operation = (yyvsp[(12) - (13)].l); ;} break; case 427: #line 4466 "ProParser.y" { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_ITERATIVELINEARSOLVER; Operation_P->Case.IterativeLinearSolver.OpMatMult = (yyvsp[(3) - (24)].c); Operation_P->Case.IterativeLinearSolver.Type = (yyvsp[(5) - (24)].c); Operation_P->Case.IterativeLinearSolver.Tolerance = (yyvsp[(7) - (24)].d); Operation_P->Case.IterativeLinearSolver.MaxIter = (int)(yyvsp[(9) - (24)].d); Operation_P->Case.IterativeLinearSolver.Restart = (int)(yyvsp[(11) - (24)].d); Operation_P->Case.IterativeLinearSolver.MyFieldTag = (yyvsp[(13) - (24)].l); Operation_P->Case.IterativeLinearSolver.NeighborFieldTag = (yyvsp[(15) - (24)].l); Operation_P->Case.IterativeLinearSolver.DeflationIndices = (yyvsp[(17) - (24)].l); Operation_P->Case.IterativeLinearSolver.Operations_Ax = (yyvsp[(20) - (24)].l); Operation_P->Case.IterativeLinearSolver.Operations_Mx = (yyvsp[(23) - (24)].l); ;} break; case 428: #line 4483 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_PRINT; Operation_P->Case.Print.Expression = NULL; Operation_P->DefineSystemIndex = -1; ;} break; case 430: #line 4492 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_WRITE; Operation_P->Case.Print.Expression = NULL; Operation_P->DefineSystemIndex = -1; ;} break; case 432: #line 4501 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_CHANGEOFCOORDINATES; Operation_P->Case.ChangeOfCoordinates.GroupIndex = Num_Group(&Group_S, (char*)"OP_ChgCoord", (yyvsp[(3) - (7)].i)); Operation_P->Case.ChangeOfCoordinates.ExpressionIndex = (yyvsp[(5) - (7)].i); Operation_P->Case.ChangeOfCoordinates.ExpressionIndex2 = -1; ;} break; case 433: #line 4512 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_CHANGEOFCOORDINATES; Operation_P->Case.ChangeOfCoordinates.GroupIndex = Num_Group(&Group_S, (char*)"OP_ChgCoord", (yyvsp[(3) - (11)].i)); Operation_P->Case.ChangeOfCoordinates.ExpressionIndex = (yyvsp[(5) - (11)].i); Operation_P->Case.ChangeOfCoordinates.NumNode = (int)(yyvsp[(7) - (11)].d); Operation_P->Case.ChangeOfCoordinates.ExpressionIndex2 = (yyvsp[(9) - (11)].i); ;} break; case 434: #line 4524 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_POSTOPERATION; Operation_P->Case.PostOperation.PostOperations = List_Create(1,1,sizeof(char*)); List_Add(Operation_P->Case.PostOperation.PostOperations, &(yyvsp[(3) - (6)].c)); if((yyvsp[(4) - (6)].i) >= -1) Operation_P->Rank = (yyvsp[(4) - (6)].i); else { Message::Warning("Negative MPI Rank"); Operation_P->Rank = -1; } ;} break; case 435: #line 4540 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SYSTEMCOMMAND; Operation_P->Case.SystemCommand.String = (yyvsp[(3) - (5)].c); ;} break; case 436: #line 4548 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_GMSHREAD; Operation_P->Case.GmshRead.FileName = strSave(Get_AbsolutePath((yyvsp[(3) - (5)].c)).c_str()); Operation_P->Case.GmshRead.ViewTag = -1; Free((yyvsp[(3) - (5)].c)); ;} break; case 437: #line 4558 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_GMSHREAD; Operation_P->Case.GmshRead.FileName = strSave(Get_AbsolutePath((yyvsp[(3) - (7)].c)).c_str()); Operation_P->Case.GmshRead.ViewTag = (int)(yyvsp[(5) - (7)].d); Free((yyvsp[(3) - (7)].c)); ;} break; case 438: #line 4568 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_GMSHCLEARALL; ;} break; case 439: #line 4575 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_DELETEFILE; Operation_P->Case.DeleteFile.FileName = strSave(Get_AbsolutePath((yyvsp[(3) - (5)].c)).c_str()); Free((yyvsp[(3) - (5)].c)); ;} break; case 440: #line 4584 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_CREATEDIR; Operation_P->Case.CreateDir.DirName = strSave(Get_AbsolutePath((yyvsp[(3) - (5)].c)).c_str()); Free((yyvsp[(3) - (5)].c)); ;} break; case 441: #line 4593 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SOLVEJACADAPTRELAX; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (9)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (9)].c)); Free((yyvsp[(3) - (9)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.SolveJac_AdaptRelax.CheckAll = (int)(yyvsp[(7) - (9)].d); Operation_P->Case.SolveJac_AdaptRelax.Factor_L = (yyvsp[(5) - (9)].l); ;} break; case 442: #line 4607 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SAVESOLUTION_WITH_ENTITY_NUM; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (5)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (5)].c)); Free((yyvsp[(3) - (5)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.SaveSolutionWithEntityNum.GroupIndex = -1; ;} break; case 443: #line 4620 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SAVESOLUTION_WITH_ENTITY_NUM; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (8)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (8)].c)); Free((yyvsp[(3) - (8)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.SaveSolutionWithEntityNum.GroupIndex = Num_Group(&Group_S, (char*)"OP_SaveSolutionWithEntityNum", (yyvsp[(5) - (8)].i)); Operation_P->Case.SaveSolutionWithEntityNum.SaveFixed = ((yyvsp[(6) - (8)].i) >= 0) ? (yyvsp[(6) - (8)].i) : 0; ;} break; case 444: #line 4635 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SAVESOLUTIONEXTENDEDMH; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (9)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (9)].c)); Free((yyvsp[(3) - (9)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.SaveSolutionExtendedMH.NbrFreq = (int)(yyvsp[(5) - (9)].d); Operation_P->Case.SaveSolutionExtendedMH.ResFile = (yyvsp[(7) - (9)].c); ;} break; case 445: #line 4649 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SAVESOLUTIONMHTOTIME; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (9)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (9)].c)); Free((yyvsp[(3) - (9)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.SaveSolutionMHtoTime.Time = (yyvsp[(5) - (9)].l); Operation_P->Case.SaveSolutionMHtoTime.ResFile = (yyvsp[(7) - (9)].c); ;} break; case 446: #line 4663 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Problem_S.Group, (yyvsp[(3) - (5)].c), fcmp_Group_Name)) < 0) vyyerror("Unknown Group: %s", (yyvsp[(3) - (5)].c)); Operation_P->Type = OPERATION_INIT_MOVINGBAND2D; Operation_P->Case.Init_MovingBand2D.GroupIndex = i; Free((yyvsp[(3) - (5)].c)); ;} break; case 447: #line 4674 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Problem_S.Group, (yyvsp[(3) - (5)].c), fcmp_Group_Name)) < 0) vyyerror("Unknown Group: %s", (yyvsp[(3) - (5)].c)); Operation_P->Type = OPERATION_MESH_MOVINGBAND2D; Operation_P->Case.Mesh_MovingBand2D.GroupIndex = i; Free((yyvsp[(3) - (5)].c)); ;} break; case 448: #line 4685 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (11)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (11)].c)); Free((yyvsp[(3) - (11)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.SaveMesh.GroupIndex = Num_Group(&Group_S, (char*)"OP_SaveMesh", (yyvsp[(5) - (11)].i)); Operation_P->Case.SaveMesh.FileName = (yyvsp[(7) - (11)].c); Operation_P->Case.SaveMesh.ExprIndex = (yyvsp[(9) - (11)].i); Operation_P->Type = OPERATION_SAVEMESH; ;} break; case 449: #line 4700 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (9)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (9)].c)); Free((yyvsp[(3) - (9)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.SaveMesh.GroupIndex = Num_Group(&Group_S, (char*)"OP_SaveMesh", (yyvsp[(5) - (9)].i)); Operation_P->Case.SaveMesh.FileName = (yyvsp[(7) - (9)].c); Operation_P->Case.SaveMesh.ExprIndex = -1; Operation_P->Type = OPERATION_SAVEMESH; ;} break; case 450: #line 4716 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (14)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (14)].c)); Free((yyvsp[(3) - (14)].c)); Operation_P->DefineSystemIndex = i; if((i = List_ISearchSeq(Problem_S.Group, (yyvsp[(5) - (14)].c), fcmp_Group_Name)) < 0) vyyerror("Unknown Group: %s", (yyvsp[(5) - (14)].c)); Free((yyvsp[(5) - (14)].c)); Operation_P->Type = OPERATION_GENERATE_MH_MOVING; Operation_P->Case.Generate_MH_Moving.GroupIndex = i; Operation_P->Case.Generate_MH_Moving.Period = (yyvsp[(7) - (14)].d); Operation_P->Case.Generate_MH_Moving.NbrStep = (int)(yyvsp[(9) - (14)].d); Operation_P->Case.Generate_MH_Moving.Operation = (yyvsp[(12) - (14)].l); ;} break; case 451: #line 4736 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (14)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (14)].c)); Free((yyvsp[(3) - (14)].c)); Operation_P->DefineSystemIndex = i; if((i = List_ISearchSeq(Problem_S.Group, (yyvsp[(5) - (14)].c), fcmp_Group_Name)) < 0) vyyerror("Unknown Group: %s", (yyvsp[(5) - (14)].c)); Free((yyvsp[(5) - (14)].c)); Operation_P->Type = OPERATION_GENERATE_MH_MOVING_S; Operation_P->Case.Generate_MH_Moving_S.GroupIndex = i; Operation_P->Case.Generate_MH_Moving_S.Period = (yyvsp[(7) - (14)].d); Operation_P->Case.Generate_MH_Moving_S.NbrStep = (int)(yyvsp[(9) - (14)].d); Operation_P->Case.Generate_MH_Moving_S.Operation = (yyvsp[(12) - (14)].l); ;} break; case 452: #line 4755 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (7)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (7)].c)); Free((yyvsp[(3) - (7)].c)); Operation_P->Type = OPERATION_ADD_MH_MOVING; Operation_P->Case.Add_MH_Moving.dummy = (yyvsp[(5) - (7)].d); ;} break; case 453: #line 4767 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (12)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (12)].c)); Free((yyvsp[(3) - (12)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.DeformeMesh.Quantity = (yyvsp[(5) - (12)].c); Operation_P->Case.DeformeMesh.Name_MshFile = (yyvsp[(8) - (12)].c); Operation_P->Case.DeformeMesh.GeoDataIndex = -1; Operation_P->Case.DeformeMesh.Factor = (yyvsp[(10) - (12)].d); Operation_P->Type = OPERATION_DEFORMEMESH; ;} break; case 454: #line 4783 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (10)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (10)].c)); Free((yyvsp[(3) - (10)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.DeformeMesh.Quantity = (yyvsp[(5) - (10)].c); Operation_P->Case.DeformeMesh.Name_MshFile = (yyvsp[(8) - (10)].c); Operation_P->Case.DeformeMesh.GeoDataIndex = -1; Operation_P->Case.DeformeMesh.Factor = 1; Operation_P->Type = OPERATION_DEFORMEMESH; ;} break; case 455: #line 4799 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (7)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (7)].c)); Free((yyvsp[(3) - (7)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Case.DeformeMesh.Quantity = (yyvsp[(5) - (7)].c); Operation_P->Case.DeformeMesh.Name_MshFile = NULL; Operation_P->Case.DeformeMesh.GeoDataIndex = -1; Operation_P->Case.DeformeMesh.Factor = 1; Operation_P->Type = OPERATION_DEFORMEMESH; ;} break; case 456: #line 4815 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (8)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (8)].c)); Free((yyvsp[(3) - (8)].c)); Operation_P->DefineSystemIndex = i; if((i = List_ISearchSeq(Problem_S.Group, (yyvsp[(5) - (8)].c), fcmp_Group_Name)) < 0) vyyerror("Unknown Group: %s", (yyvsp[(5) - (8)].c)); Free((yyvsp[(5) - (8)].c)); Operation_P->Type = OPERATION_GENERATE; Operation_P->Case.Generate.GroupIndex = i; if((yyvsp[(6) - (8)].i) >= -1) Operation_P->Rank = (yyvsp[(6) - (8)].i); else { Message::Warning("Negative MPI Rank"); Operation_P->Rank = -1; } ;} break; case 457: #line 4836 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (8)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (8)].c)); Free((yyvsp[(3) - (8)].c)); Operation_P->DefineSystemIndex = i; if((i = List_ISearchSeq(Problem_S.Group, (yyvsp[(5) - (8)].c), fcmp_Group_Name)) < 0) vyyerror("Unknown Group: %s", (yyvsp[(5) - (8)].c)); Free((yyvsp[(5) - (8)].c)); Operation_P->Type = OPERATION_GENERATEJAC; Operation_P->Case.Generate.GroupIndex = i; if((yyvsp[(6) - (8)].i) >= -1) Operation_P->Rank = (yyvsp[(6) - (8)].i); else { Message::Warning("Negative MPI Rank"); Operation_P->Rank = -1; } ;} break; case 458: #line 4857 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (8)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (8)].c)); Free((yyvsp[(3) - (8)].c)); Operation_P->DefineSystemIndex = i; Operation_P->Type = OPERATION_GENERATERHS; Operation_P->Case.Generate.GroupIndex = (yyvsp[(5) - (8)].i); if((yyvsp[(6) - (8)].i) >= -1) Operation_P->Rank = (yyvsp[(6) - (8)].i); else { Message::Warning("Negative MPI Rank"); Operation_P->Rank = -1; } ;} break; case 459: #line 4875 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SOLVEAGAINWITHOTHER; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (8)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (8)].c)); Free((yyvsp[(3) - (8)].c)); Operation_P->DefineSystemIndex = i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(5) - (8)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(5) - (8)].c)); Free((yyvsp[(5) - (8)].c)); Operation_P->Case.SolveAgainWithOther.DefineSystemIndex = i; if((yyvsp[(6) - (8)].i) >= -1) Operation_P->Rank = (yyvsp[(6) - (8)].i); else { Message::Warning("Negative MPI Rank"); Operation_P->Rank = -1; } ;} break; case 460: #line 4901 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TensorProductSolve.SystemIndex = List_Create(4, 4, sizeof(int)); for(int j = 0; j < List_Nbr((yyvsp[(4) - (17)].l)); j++){ char *sys; List_Read((yyvsp[(4) - (17)].l), j, &sys); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, sys, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", sys); Free(sys); List_Add(Operation_P->Case.TensorProductSolve.SystemIndex, &i); } List_Delete((yyvsp[(4) - (17)].l)); Operation_P->Case.TensorProductSolve.ExpectationIndex = List_Create(4, 4, sizeof(int)); for(int j = 0; j < List_Nbr((yyvsp[(8) - (17)].l)); j++){ char *sys; List_Read((yyvsp[(8) - (17)].l), j, &sys); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, sys, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", sys); Free(sys); List_Add(Operation_P->Case.TensorProductSolve.ExpectationIndex, &i); } List_Delete((yyvsp[(8) - (17)].l)); Operation_P->Case.TensorProductSolve.LocalMatrixIndex = (yyvsp[(11) - (17)].l); Operation_P->Case.TensorProductSolve.ExpansionCoef = (yyvsp[(14) - (17)].l); Operation_P->Type = OPERATION_TENSORPRODUCTSOLVE; ;} break; case 461: #line 4935 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = NONE; ;} break; case 462: #line 4944 "ProParser.y" { Operation_P->Case.Print.Expression = List_Copy(ListOfInt_L); ;} break; case 463: #line 4949 "ProParser.y" { int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(1) - (1)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(1) - (1)].c)); Free((yyvsp[(1) - (1)].c)); Operation_P->DefineSystemIndex = i; ;} break; case 464: #line 4961 "ProParser.y" { Operation_P->Case.Print.FileOut = NULL; Operation_P->Case.Print.TimeStep = NULL; Operation_P->Case.Print.DofNumber = NULL; ;} break; case 466: #line 4971 "ProParser.y" { Operation_P->Case.Print.FileOut = (yyvsp[(3) - (3)].c); ;} break; case 467: #line 4974 "ProParser.y" { Operation_P->Case.Print.TimeStep = List_Create(List_Nbr((yyvsp[(3) - (3)].l)), 1, sizeof(int)); for(int i = 0; i < List_Nbr((yyvsp[(3) - (3)].l)); i++){ double d; List_Read((yyvsp[(3) - (3)].l),i,&d); int j = (int)d; List_Add(Operation_P->Case.Print.TimeStep, &j); } List_Delete((yyvsp[(3) - (3)].l)); ;} break; case 468: #line 4986 "ProParser.y" { Operation_P->Case.Print.DofNumber = List_Create(List_Nbr((yyvsp[(2) - (2)].l)), 1, sizeof(int)); for(int i = 0; i < List_Nbr((yyvsp[(2) - (2)].l)); i++) { double d; List_Read((yyvsp[(2) - (2)].l), i, &d); int j = (int)d; List_Add(Operation_P->Case.Print.DofNumber, &j); } List_Delete((yyvsp[(2) - (2)].l)); ;} break; case 469: #line 5001 "ProParser.y" { Operation_P->Case.TimeLoopAdaptive.LTEtarget = -1.; Operation_P->Case.TimeLoopAdaptive.DTimeMaxScal = -1.; Operation_P->Case.TimeLoopAdaptive.DTimeScal_NotConverged = -1.; ;} break; case 470: #line 5008 "ProParser.y" { Operation_P->Case.TimeLoopAdaptive.LTEtarget = (yyvsp[(2) - (2)].d); Operation_P->Case.TimeLoopAdaptive.DTimeMaxScal = -1.; Operation_P->Case.TimeLoopAdaptive.DTimeScal_NotConverged = -1.; ;} break; case 471: #line 5015 "ProParser.y" { Operation_P->Case.TimeLoopAdaptive.LTEtarget = (yyvsp[(2) - (4)].d); Operation_P->Case.TimeLoopAdaptive.DTimeMaxScal = (yyvsp[(4) - (4)].d); Operation_P->Case.TimeLoopAdaptive.DTimeScal_NotConverged = -1.; ;} break; case 472: #line 5022 "ProParser.y" { Operation_P->Case.TimeLoopAdaptive.LTEtarget = (yyvsp[(2) - (6)].d); Operation_P->Case.TimeLoopAdaptive.DTimeMaxScal = (yyvsp[(4) - (6)].d); Operation_P->Case.TimeLoopAdaptive.DTimeScal_NotConverged = (yyvsp[(6) - (6)].d); ;} break; case 473: #line 5032 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopAdaptive.TimeLoopAdaptiveSystems_L = NULL; Operation_P->Case.TimeLoopAdaptive.TimeLoopAdaptivePOs_L = NULL; ;} break; case 474: #line 5040 "ProParser.y" { Operation_P->Case.TimeLoopAdaptive.TimeLoopAdaptiveSystems_L = (yyvsp[(4) - (5)].l); ;} break; case 475: #line 5045 "ProParser.y" { Operation_P->Case.TimeLoopAdaptive.TimeLoopAdaptivePOs_L = (yyvsp[(4) - (5)].l); ;} break; case 476: #line 5054 "ProParser.y" { (yyval.l) = List_Create(4, 4, sizeof(struct TimeLoopAdaptiveSystem)); ;} break; case 477: #line 5059 "ProParser.y" { int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (10)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (10)].c)); TimeLoopAdaptiveSystem_S.SystemIndex = i; TimeLoopAdaptiveSystem_S.SystemLTEreltol = (yyvsp[(5) - (10)].d); TimeLoopAdaptiveSystem_S.SystemLTEabstol = (yyvsp[(7) - (10)].d); TimeLoopAdaptiveSystem_S.NormType = Get_DefineForString(ErrorNorm_Type, (yyvsp[(9) - (10)].c), &FlagError); if(FlagError){ vyyerror("Unknown error norm type of TimeLoopAdaptive system %s", (yyvsp[(3) - (10)].c)); Get_Valid_SXD(ChangeOfState_Type); } TimeLoopAdaptiveSystem_S.NormTypeString = (yyvsp[(9) - (10)].c); List_Add((yyval.l) = (yyvsp[(1) - (10)].l), &TimeLoopAdaptiveSystem_S); Free((yyvsp[(3) - (10)].c)); ;} break; case 478: #line 5079 "ProParser.y" { (yyval.l) = List_Create(4, 4, sizeof(struct LoopErrorPostOperation)); ;} break; case 479: #line 5084 "ProParser.y" { TimeLoopAdaptivePO_S.PostOperationName = (yyvsp[(3) - (10)].c); TimeLoopAdaptivePO_S.PostOperationReltol = (yyvsp[(5) - (10)].d); TimeLoopAdaptivePO_S.PostOperationAbstol = (yyvsp[(7) - (10)].d); TimeLoopAdaptivePO_S.NormType = Get_DefineForString(ErrorNorm_Type, (yyvsp[(9) - (10)].c), &FlagError); if(FlagError){ vyyerror("Unknown error norm type of TimeLoopAdaptive PostOperation %s", (yyvsp[(3) - (10)].c)); Get_Valid_SXD(ChangeOfState_Type); } TimeLoopAdaptivePO_S.NormTypeString = (yyvsp[(9) - (10)].c); List_Add((yyval.l) = (yyvsp[(1) - (10)].l), &TimeLoopAdaptivePO_S); ;} break; case 480: #line 5100 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeLoop.IterativeLoopSystems_L = NULL; Operation_P->Case.IterativeLoop.IterativeLoopPOs_L = NULL; ;} break; case 481: #line 5108 "ProParser.y" { Operation_P->Case.IterativeLoop.IterativeLoopSystems_L = (yyvsp[(4) - (5)].l); ;} break; case 482: #line 5113 "ProParser.y" { Operation_P->Case.IterativeLoop.IterativeLoopPOs_L = (yyvsp[(4) - (5)].l); ;} break; case 483: #line 5122 "ProParser.y" { (yyval.l) = List_Create(4, 4, sizeof(struct IterativeLoopSystem)); ;} break; case 484: #line 5127 "ProParser.y" { int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(3) - (11)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(3) - (11)].c)); IterativeLoopSystem_S.SystemIndex = i; IterativeLoopSystem_S.SystemILreltol = (yyvsp[(5) - (11)].d); IterativeLoopSystem_S.SystemILabstol = (yyvsp[(7) - (11)].d); IterativeLoopSystem_S.NormOf = Get_DefineForString(NormOf_Type, (yyvsp[(9) - (11)].c), &FlagError); if(FlagError){ vyyerror("Unknown object for error norm of IterativeLoop system: %s", (yyvsp[(3) - (11)].c)); Get_Valid_SXD(ChangeOfState_Type); } IterativeLoopSystem_S.NormOfString = (yyvsp[(9) - (11)].c); IterativeLoopSystem_S.NormType = Get_DefineForString(ErrorNorm_Type, (yyvsp[(10) - (11)].c), &FlagError); if(FlagError){ vyyerror("Unknown error norm type of IterativeLoop system: %s", (yyvsp[(3) - (11)].c)); Get_Valid_SXD(ChangeOfState_Type); } IterativeLoopSystem_S.NormTypeString = (yyvsp[(10) - (11)].c); List_Add((yyval.l) = (yyvsp[(1) - (11)].l), &IterativeLoopSystem_S); Free((yyvsp[(3) - (11)].c)); ;} break; case 485: #line 5154 "ProParser.y" { (yyval.l) = List_Create(4, 4, sizeof(struct LoopErrorPostOperation)); ;} break; case 486: #line 5159 "ProParser.y" { IterativeLoopPO_S.PostOperationName = (yyvsp[(3) - (10)].c); IterativeLoopPO_S.PostOperationReltol = (yyvsp[(5) - (10)].d); IterativeLoopPO_S.PostOperationAbstol = (yyvsp[(7) - (10)].d); IterativeLoopPO_S.NormType = Get_DefineForString(ErrorNorm_Type, (yyvsp[(9) - (10)].c), &FlagError); if(FlagError){ vyyerror("Unknown error norm type of IterativeLoopN PostOperation %s", (yyvsp[(3) - (10)].c)); Get_Valid_SXD(ChangeOfState_Type); } IterativeLoopPO_S.NormTypeString = (yyvsp[(9) - (10)].c); List_Add((yyval.l) = (yyvsp[(1) - (10)].l), &IterativeLoopPO_S); ;} break; case 487: #line 5179 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopTheta.Time0 = 0.; Operation_P->Case.TimeLoopTheta.TimeMax = 1.; Operation_P->Case.TimeLoopTheta.DTimeIndex = -1; Operation_P->Case.TimeLoopTheta.ThetaIndex = -1; Operation_P->Case.TimeLoopTheta.Operation = NULL; ;} break; case 489: #line 5195 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopTheta.Time0 = (yyvsp[(2) - (3)].d); ;} break; case 490: #line 5199 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopTheta.TimeMax = (yyvsp[(2) - (3)].d); ;} break; case 491: #line 5203 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopTheta.DTimeIndex = (yyvsp[(2) - (3)].i); ;} break; case 492: #line 5207 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopTheta.ThetaIndex = (yyvsp[(2) - (3)].i); ;} break; case 493: #line 5212 "ProParser.y" { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopTheta.Operation = (yyvsp[(3) - (4)].l); ;} break; case 494: #line 5223 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopNewmark.Time0 = 0.; Operation_P->Case.TimeLoopNewmark.TimeMax = 1.; Operation_P->Case.TimeLoopNewmark.DTimeIndex = -1; Operation_P->Case.TimeLoopNewmark.Beta = 0.25; Operation_P->Case.TimeLoopNewmark.Gamma = 0.5; Operation_P->Case.TimeLoopNewmark.Operation = NULL; ;} break; case 496: #line 5240 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopNewmark.Time0 = (yyvsp[(2) - (3)].d); ;} break; case 497: #line 5244 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopNewmark.TimeMax = (yyvsp[(2) - (3)].d); ;} break; case 498: #line 5248 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopNewmark.DTimeIndex = (yyvsp[(2) - (3)].i); ;} break; case 499: #line 5252 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopNewmark.Beta = (yyvsp[(2) - (3)].d); ;} break; case 500: #line 5256 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopNewmark.Gamma = (yyvsp[(2) - (3)].d); ;} break; case 501: #line 5261 "ProParser.y" { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopNewmark.Operation = (yyvsp[(3) - (4)].l); ;} break; case 502: #line 5272 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeLoop.NbrMaxIteration = 20; Operation_P->Case.IterativeLoop.Criterion = 1.e-3; Operation_P->Case.IterativeLoop.RelaxationFactorIndex = -1; Operation_P->Case.IterativeLoop.Flag = 0; Operation_P->Case.IterativeLoop.Operation = NULL; ;} break; case 504: #line 5287 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeLoop.NbrMaxIteration = (int)(yyvsp[(2) - (3)].d); ;} break; case 505: #line 5291 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeLoop.Criterion = (yyvsp[(2) - (3)].d); ;} break; case 506: #line 5295 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeLoop.RelaxationFactorIndex = (yyvsp[(2) - (3)].i); ;} break; case 507: #line 5299 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeLoop.Flag = (int)(yyvsp[(2) - (3)].d); ;} break; case 508: #line 5303 "ProParser.y" { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeLoop.Operation = (yyvsp[(3) - (4)].l); ;} break; case 509: #line 5314 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeTimeReduction.NbrMaxIteration = 20; Operation_P->Case.IterativeTimeReduction.DivisionCoefficient = 2.; Operation_P->Case.IterativeTimeReduction.Criterion = 1.e-3; Operation_P->Case.IterativeTimeReduction.Flag = 0; Current_System = Operation_P->DefineSystemIndex = -1; Operation_P->Case.IterativeTimeReduction.ChangeOfState = NULL; Operation_P->Case.IterativeTimeReduction.Operation = NULL; Operation_P->Case.IterativeTimeReduction.OperationEnd = NULL; ;} break; case 511: #line 5332 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeTimeReduction.NbrMaxIteration = (int)(yyvsp[(2) - (3)].d); ;} break; case 512: #line 5336 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeTimeReduction.DivisionCoefficient = (yyvsp[(2) - (3)].d); ;} break; case 513: #line 5340 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeTimeReduction.Criterion = (yyvsp[(2) - (3)].d); ;} break; case 514: #line 5344 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeTimeReduction.Flag = (int)(yyvsp[(2) - (3)].d); ;} break; case 515: #line 5349 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, (yyvsp[(2) - (3)].c), fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", (yyvsp[(2) - (3)].c)); Free((yyvsp[(2) - (3)].c)); Current_System = Operation_P->DefineSystemIndex = i; ;} break; case 516: #line 5360 "ProParser.y" { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeTimeReduction.ChangeOfState = (yyvsp[(3) - (4)].l); ;} break; case 517: #line 5366 "ProParser.y" { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeTimeReduction.Operation = (yyvsp[(3) - (4)].l); ;} break; case 518: #line 5372 "ProParser.y" { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeTimeReduction.OperationEnd = (yyvsp[(3) - (4)].l); ;} break; case 519: #line 5382 "ProParser.y" { (yyval.l) = List_Create(3, 3, sizeof (struct ChangeOfState)); ;} break; case 520: #line 5385 "ProParser.y" { List_Add((yyval.l) = (yyvsp[(1) - (4)].l), &ChangeOfState_S); ;} break; case 521: #line 5390 "ProParser.y" { ChangeOfState_S.Type = CHANGEOFSTATE_CHANGESIGN; ChangeOfState_S.QuantityIndex = -1; ChangeOfState_S.FormulationIndex = -1; ChangeOfState_S.InIndex = -1; ChangeOfState_S.Criterion = 1.e-2; ChangeOfState_S.ExpressionIndex = ChangeOfState_S.ExpressionIndex2 = -1; ChangeOfState_S.FlagIndex = -1; ChangeOfState_S.ActiveList[0] = NULL; ChangeOfState_S.ActiveList[1] = NULL; ;} break; case 523: #line 5408 "ProParser.y" { ChangeOfState_S.Type = Get_DefineForString(ChangeOfState_Type, (yyvsp[(2) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of ChangeOfState: %s", (yyvsp[(2) - (3)].c)); Get_Valid_SXD(ChangeOfState_Type); } Free((yyvsp[(2) - (3)].c)); ;} break; case 524: #line 5418 "ProParser.y" { if(Current_System >= 0) { List_T *ListOfInt_Lnew = ((struct DefineSystem *)List_Pointer(Resolution_S.DefineSystem, Current_System))->FormulationIndex; int *ListOfInt_P =(int *)List_Pointer(ListOfInt_Lnew, 0); int i = 0, j; for(j = 0; j < List_Nbr(ListOfInt_Lnew); j++) { Formulation_S.DefineQuantity = ((struct Formulation *) List_Pointer(Problem_S.Formulation, ListOfInt_P[j]))->DefineQuantity; if((i = List_ISearchSeq(Formulation_S.DefineQuantity, (yyvsp[(2) - (3)].c), fcmp_DefineQuantity_Name)) >= 0) break; } if(j= 0) j = ((struct DefineQuantity *) List_Pointer (((struct Formulation *) List_Pointer(Problem_S.Formulation, PostProcessing_S.FormulationIndex))->DefineQuantity, PostQuantityTerm_S.QuantityIndexTable[i])) -> Type; if(PostQuantityTerm_S.Type == 0) PostQuantityTerm_S.Type = j; else if(PostQuantityTerm_S.Type != j) vyyerror("Mixed discrete Quantity types in term (should be split in separate terms)"); } if(PostQuantityTerm_S.Type == 0) PostQuantityTerm_S.Type = LOCALQUANTITY; } ;} break; case 554: #line 5653 "ProParser.y" { /* force the Type */ PostQuantityTerm_S.Type = Get_DefineForString(DefineQuantity_Type, (yyvsp[(2) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown type of Operation: %s", (yyvsp[(2) - (3)].c)); Get_Valid_SXD(DefineQuantity_Type); } Free((yyvsp[(2) - (3)].c)); ;} break; case 555: #line 5664 "ProParser.y" { PostQuantityTerm_S.InIndex = Num_Group(&Group_S, (char*)"PQ_In", (yyvsp[(2) - (3)].i)); ;} break; case 556: #line 5669 "ProParser.y" { int i; if((i = List_ISearchSeq(Problem_S.JacobianMethod, (yyvsp[(2) - (3)].c), fcmp_JacobianMethod_Name)) < 0) vyyerror("Unknown Jacobian method: %s",(yyvsp[(2) - (3)].c)); else PostQuantityTerm_S.JacobianMethodIndex = i; Free((yyvsp[(2) - (3)].c)); ;} break; case 557: #line 5680 "ProParser.y" { int i; if((i = List_ISearchSeq(Problem_S.IntegrationMethod, (yyvsp[(2) - (3)].c), fcmp_IntegrationMethod_Name)) < 0) vyyerror("Unknown Integration method: %s",(yyvsp[(2) - (3)].c)); else PostQuantityTerm_S.IntegrationMethodIndex = i; Free((yyvsp[(2) - (3)].c)); ;} break; case 558: #line 5699 "ProParser.y" { if(!Problem_S.PostOperation) Problem_S.PostOperation = List_Create(10, 5, sizeof (struct PostOperation)); ;} break; case 560: #line 5711 "ProParser.y" { List_Add(Problem_S.PostOperation, &PostOperation_S); ;} break; case 562: #line 5718 "ProParser.y" { PostOperation_S.Name = NULL; PostOperation_S.AppendString = NULL; PostOperation_S.Format = FORMAT_GMSH; PostOperation_S.PostProcessingIndex = -1; PostOperation_S.ResampleTime = false; ;} break; case 564: #line 5731 "ProParser.y" { Check_NameOfStructNotExist("PostOperation", Problem_S.PostOperation, (yyvsp[(2) - (3)].c), fcmp_PostOperation_Name); PostOperation_S.Name = (yyvsp[(2) - (3)].c); ;} break; case 565: #line 5738 "ProParser.y" { int i; if((i = List_ISearchSeq(Problem_S.PostProcessing, (yyvsp[(2) - (3)].c), fcmp_PostProcessing_Name)) < 0) vyyerror("Unknown PostProcessing: %s", (yyvsp[(2) - (3)].c)); else { PostOperation_S.PostProcessingIndex = i; List_Read(Problem_S.PostProcessing, i, &InteractivePostProcessing_S); } Free((yyvsp[(2) - (3)].c)); ;} break; case 566: #line 5751 "ProParser.y" { PostOperation_S.Format = Get_DefineForString(PostSubOperation_Format, (yyvsp[(2) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown PostProcessing Format: %s", (yyvsp[(2) - (3)].c)); Get_Valid_SXD(PostSubOperation_Format); } Free((yyvsp[(2) - (3)].c)); ;} break; case 567: #line 5762 "ProParser.y" { PostOperation_S.AppendString = (yyvsp[(2) - (3)].c); ;} break; case 568: #line 5767 "ProParser.y" { PostOperation_S.ResampleTime = true; PostOperation_S.ResampleTimeStart = (yyvsp[(3) - (9)].d); PostOperation_S.ResampleTimeStop = (yyvsp[(5) - (9)].d); PostOperation_S.ResampleTimeStep = (yyvsp[(7) - (9)].d); ;} break; case 569: #line 5775 "ProParser.y" { PostOperation_S.PostSubOperation = (yyvsp[(3) - (4)].l); ;} break; case 570: #line 5781 "ProParser.y" { PostOperation_S.PostProcessingIndex = -1; PostOperation_S.AppendString = NULL; PostOperation_S.Format = FORMAT_GMSH; int i; if((i = List_ISearchSeq(Problem_S.PostProcessing, (yyvsp[(4) - (4)].c), fcmp_PostProcessing_Name)) < 0) vyyerror("Unknown PostProcessing: %s", (yyvsp[(4) - (4)].c)); else { PostOperation_S.PostProcessingIndex = i; List_Read(Problem_S.PostProcessing, i, &InteractivePostProcessing_S); if(!Problem_S.PostOperation) Problem_S.PostOperation = List_Create(5, 5, sizeof (struct PostOperation)); PostOperation_S.Name = (yyvsp[(2) - (4)].c); } Free((yyvsp[(4) - (4)].c)); ;} break; case 571: #line 5799 "ProParser.y" { PostOperation_S.PostSubOperation = (yyvsp[(7) - (8)].l); if(PostOperation_S.PostProcessingIndex >= 0) List_Add(Problem_S.PostOperation, &PostOperation_S); ;} break; case 572: #line 5809 "ProParser.y" { (yyval.l) = List_Create(5, 5, sizeof (struct PostSubOperation)); ;} break; case 573: #line 5812 "ProParser.y" { PostSubOperation_S.Format = -1; ;} break; case 574: #line 5816 "ProParser.y" { if(PostSubOperation_S.Type != POP_NONE) { if(PostSubOperation_S.Format < 0) PostSubOperation_S.Format = PostOperation_S.Format; List_Add((yyval.l) = (yyvsp[(1) - (3)].l), &PostSubOperation_S); } ;} break; case 575: #line 5829 "ProParser.y" { vyyerror("Plot has been superseded by Print (Plot OnRegion becomes Print OnElementsOf)"); ;} break; case 576: #line 5834 "ProParser.y" { PostSubOperation_S.Type = POP_PRINT; ;} break; case 577: #line 5839 "ProParser.y" { PostSubOperation_S.Type = POP_EXPRESSION; PostSubOperation_S.Case.Expression.String = (yyvsp[(3) - (8)].c); PostSubOperation_S.Case.Expression.String2 = NULL; PostSubOperation_S.Case.Expression.ExpressionIndex = (yyvsp[(5) - (8)].i); PostSubOperation_S.PostQuantityIndex[0] = -1; ;} break; case 578: #line 5848 "ProParser.y" { PostSubOperation_S.Type = POP_EXPRESSION; PostSubOperation_S.Case.Expression.String = (yyvsp[(3) - (11)].c); PostSubOperation_S.Case.Expression.String2 = (yyvsp[(7) - (11)].c); PostSubOperation_S.Case.Expression.ExpressionIndex = -1; PostSubOperation_S.PostQuantityIndex[0] = -1; ;} break; case 579: #line 5857 "ProParser.y" { PostSubOperation_S.Type = POP_EXPRESSION; PostSubOperation_S.Case.Expression.String = (yyvsp[(3) - (6)].c); PostSubOperation_S.Case.Expression.String2 = NULL; PostSubOperation_S.Case.Expression.ExpressionIndex = -1; PostSubOperation_S.PostQuantityIndex[0] = -1; ;} break; case 580: #line 5866 "ProParser.y" { PostSubOperation_S.Type = POP_GROUP; PostSubOperation_S.Case.Group.ExtendedGroupIndex = Num_Group(&Group_S, (char*)"PO_Group", (yyvsp[(3) - (3)].i)); PostSubOperation_S.PostQuantityIndex[0] = -1; ;} break; case 581: #line 5872 "ProParser.y" { PostSubOperation_S.Case.Group.GroupIndex = Num_Group(&Group_S, (char*)"PO_Group", (yyvsp[(7) - (10)].i)); ;} break; case 582: #line 5877 "ProParser.y" { PostSubOperation_S.Type = POP_NONE; ;} break; case 583: #line 5886 "ProParser.y" { int i; if((i = List_ISearchSeq(InteractivePostProcessing_S.PostQuantity, (yyvsp[(1) - (3)].c), fcmp_PostQuantity_Name)) < 0) vyyerror("Unknown PostProcessing Quantity: %s", (yyvsp[(1) - (3)].c)); PostSubOperation_S.PostQuantityIndex[0] = i; PostSubOperation_S.PostQuantityIndex[1] = -1; PostSubOperation_S.PostQuantitySupport[0] = (yyvsp[(2) - (3)].i); PostSubOperation_S.PostQuantitySupport[1] = -1; Free((yyvsp[(1) - (3)].c)); ;} break; case 584: #line 5899 "ProParser.y" { int i; if((i = List_ISearchSeq(InteractivePostProcessing_S.PostQuantity, (yyvsp[(1) - (6)].c), fcmp_PostQuantity_Name)) < 0) vyyerror("Unknown PostProcessing Quantity: %s", (yyvsp[(1) - (6)].c)); PostSubOperation_S.PostQuantityIndex[0] = i; PostSubOperation_S.PostQuantitySupport[0] = (yyvsp[(2) - (6)].i); int j = -1; if((j = List_ISearchSeq(InteractivePostProcessing_S.PostQuantity, (yyvsp[(4) - (6)].c), fcmp_PostQuantity_Name)) < 0) vyyerror("Unknown PostProcessing Quantity: %s", (yyvsp[(4) - (6)].c)); PostSubOperation_S.PostQuantityIndex[1] = j; PostSubOperation_S.PostQuantitySupport[1] = (yyvsp[(5) - (6)].i); if(((yyvsp[(2) - (6)].i) < 0 && (yyvsp[(5) - (6)].i) < 0) || ((yyvsp[(2) - (6)].i) >= 0 && (yyvsp[(5) - (6)].i) >= 0)) { vyyerror("Postprocessing Quantities '%s' and '%s' of same type (%s)", (yyvsp[(1) - (6)].c), (yyvsp[(4) - (6)].c), ((yyvsp[(2) - (6)].i)>0)? "with Support":"without Support"); } Free((yyvsp[(1) - (6)].c)); Free((yyvsp[(4) - (6)].c)); ;} break; case 585: #line 5923 "ProParser.y" { PostSubOperation_S.CombinationType = MULTIPLICATION; ;} break; case 586: #line 5924 "ProParser.y" { PostSubOperation_S.CombinationType = DIVISION; ;} break; case 587: #line 5925 "ProParser.y" { PostSubOperation_S.CombinationType = ADDITION; ;} break; case 588: #line 5926 "ProParser.y" { PostSubOperation_S.CombinationType = SOUSTRACTION; ;} break; case 589: #line 5932 "ProParser.y" { (yyval.i) = -1; ;} break; case 590: #line 5934 "ProParser.y" { (yyval.i) = Num_Group(&Group_S, (char*)"PO_Support", (yyvsp[(2) - (3)].i)); ;} break; case 591: #line 5940 "ProParser.y" { PostSubOperation_S.SubType = PRINT_ONREGION; PostSubOperation_S.Case.OnRegion.RegionIndex = -1; ;} break; case 592: #line 5946 "ProParser.y" { PostSubOperation_S.SubType = PRINT_ONREGION; PostSubOperation_S.Case.OnRegion.RegionIndex = Num_Group(&Group_S, (char*)"PO_OnRegion", (yyvsp[(2) - (2)].i)); ;} break; case 593: #line 5953 "ProParser.y" { PostSubOperation_S.SubType = PRINT_ONELEMENTSOF; PostSubOperation_S.Case.OnRegion.RegionIndex = Num_Group(&Group_S, (char*)"PO_OnElementsOf", (yyvsp[(2) - (2)].i)); ;} break; case 594: #line 5962 "ProParser.y" { PostSubOperation_S.SubType = PRINT_ONSECTION_2D; if(List_Nbr((yyvsp[(4) - (12)].l)) != 3 || List_Nbr((yyvsp[(7) - (12)].l)) != 3 || List_Nbr((yyvsp[(10) - (12)].l)) != 3) vyyerror("Expected {3}{3}{3} coordinates, got {%d}{%d}{%d}", List_Nbr((yyvsp[(4) - (12)].l)), List_Nbr((yyvsp[(7) - (12)].l)), List_Nbr((yyvsp[(10) - (12)].l))); else{ List_Read((yyvsp[(4) - (12)].l), 0, &PostSubOperation_S.Case.OnSection.x[0]); List_Read((yyvsp[(4) - (12)].l), 1, &PostSubOperation_S.Case.OnSection.y[0]); List_Read((yyvsp[(4) - (12)].l), 2, &PostSubOperation_S.Case.OnSection.z[0]); List_Read((yyvsp[(7) - (12)].l), 0, &PostSubOperation_S.Case.OnSection.x[1]); List_Read((yyvsp[(7) - (12)].l), 1, &PostSubOperation_S.Case.OnSection.y[1]); List_Read((yyvsp[(7) - (12)].l), 2, &PostSubOperation_S.Case.OnSection.z[1]); List_Read((yyvsp[(10) - (12)].l), 0, &PostSubOperation_S.Case.OnSection.x[2]); List_Read((yyvsp[(10) - (12)].l), 1, &PostSubOperation_S.Case.OnSection.y[2]); List_Read((yyvsp[(10) - (12)].l), 2, &PostSubOperation_S.Case.OnSection.z[2]); } List_Delete((yyvsp[(4) - (12)].l)); List_Delete((yyvsp[(7) - (12)].l)); List_Delete((yyvsp[(10) - (12)].l)); ;} break; case 595: #line 5984 "ProParser.y" { PostSubOperation_S.SubType = PRINT_ONGRID; PostSubOperation_S.Case.OnRegion.RegionIndex = Num_Group(&Group_S, (char*)"PO_OnGrid", (yyvsp[(2) - (2)].i)); ;} break; case 596: #line 5992 "ProParser.y" { PostSubOperation_S.SubType = PRINT_ONGRID_PARAM; PostSubOperation_S.Case.OnParamGrid.ExpressionIndex[0] = (yyvsp[(3) - (15)].i); PostSubOperation_S.Case.OnParamGrid.ExpressionIndex[1] = (yyvsp[(5) - (15)].i); PostSubOperation_S.Case.OnParamGrid.ExpressionIndex[2] = (yyvsp[(7) - (15)].i); PostSubOperation_S.Case.OnParamGrid.ParameterValue[0] = (yyvsp[(10) - (15)].l); PostSubOperation_S.Case.OnParamGrid.ParameterValue[1] = (yyvsp[(12) - (15)].l); PostSubOperation_S.Case.OnParamGrid.ParameterValue[2] = (yyvsp[(14) - (15)].l); ;} break; case 597: #line 6003 "ProParser.y" { PostSubOperation_S.SubType = PRINT_ONGRID_0D; if(List_Nbr((yyvsp[(3) - (4)].l)) != 3) vyyerror("Expected {3} coordinates, got {%d}", List_Nbr((yyvsp[(3) - (4)].l))); else{ List_Read((yyvsp[(3) - (4)].l), 0, &PostSubOperation_S.Case.OnGrid.x[0]); List_Read((yyvsp[(3) - (4)].l), 1, &PostSubOperation_S.Case.OnGrid.y[0]); List_Read((yyvsp[(3) - (4)].l), 2, &PostSubOperation_S.Case.OnGrid.z[0]); } List_Delete((yyvsp[(3) - (4)].l)); ;} break; case 598: #line 6017 "ProParser.y" { PostSubOperation_S.SubType = PRINT_ONGRID_1D; if(List_Nbr((yyvsp[(4) - (12)].l)) != 3 || List_Nbr((yyvsp[(7) - (12)].l)) != 3) vyyerror("Expected {3}{3} coordinates, got {%d}{%d}", List_Nbr((yyvsp[(4) - (12)].l)), List_Nbr((yyvsp[(7) - (12)].l))); else{ List_Read((yyvsp[(4) - (12)].l), 0, &PostSubOperation_S.Case.OnGrid.x[0]); List_Read((yyvsp[(4) - (12)].l), 1, &PostSubOperation_S.Case.OnGrid.y[0]); List_Read((yyvsp[(4) - (12)].l), 2, &PostSubOperation_S.Case.OnGrid.z[0]); List_Read((yyvsp[(7) - (12)].l), 0, &PostSubOperation_S.Case.OnGrid.x[1]); List_Read((yyvsp[(7) - (12)].l), 1, &PostSubOperation_S.Case.OnGrid.y[1]); List_Read((yyvsp[(7) - (12)].l), 2, &PostSubOperation_S.Case.OnGrid.z[1]); } PostSubOperation_S.Case.OnGrid.n[0] = (int)(yyvsp[(11) - (12)].d); List_Delete((yyvsp[(4) - (12)].l)); List_Delete((yyvsp[(7) - (12)].l)); ;} break; case 599: #line 6038 "ProParser.y" { PostSubOperation_S.SubType = PRINT_ONGRID_2D; if(List_Nbr((yyvsp[(4) - (17)].l)) != 3 || List_Nbr((yyvsp[(7) - (17)].l)) != 3 || List_Nbr((yyvsp[(10) - (17)].l)) != 3) vyyerror("Expected {3}{3}{3} coordinates, got {%d}{%d}{%d}", List_Nbr((yyvsp[(4) - (17)].l)), List_Nbr((yyvsp[(7) - (17)].l)), List_Nbr((yyvsp[(10) - (17)].l))); else{ List_Read((yyvsp[(4) - (17)].l), 0, &PostSubOperation_S.Case.OnGrid.x[0]); List_Read((yyvsp[(4) - (17)].l), 1, &PostSubOperation_S.Case.OnGrid.y[0]); List_Read((yyvsp[(4) - (17)].l), 2, &PostSubOperation_S.Case.OnGrid.z[0]); List_Read((yyvsp[(7) - (17)].l), 0, &PostSubOperation_S.Case.OnGrid.x[1]); List_Read((yyvsp[(7) - (17)].l), 1, &PostSubOperation_S.Case.OnGrid.y[1]); List_Read((yyvsp[(7) - (17)].l), 2, &PostSubOperation_S.Case.OnGrid.z[1]); List_Read((yyvsp[(10) - (17)].l), 0, &PostSubOperation_S.Case.OnGrid.x[2]); List_Read((yyvsp[(10) - (17)].l), 1, &PostSubOperation_S.Case.OnGrid.y[2]); List_Read((yyvsp[(10) - (17)].l), 2, &PostSubOperation_S.Case.OnGrid.z[2]); } PostSubOperation_S.Case.OnGrid.n[0] = (int)(yyvsp[(14) - (17)].d); PostSubOperation_S.Case.OnGrid.n[1] = (int)(yyvsp[(16) - (17)].d); List_Delete((yyvsp[(4) - (17)].l)); List_Delete((yyvsp[(7) - (17)].l)); List_Delete((yyvsp[(10) - (17)].l)); ;} break; case 600: #line 6065 "ProParser.y" { PostSubOperation_S.SubType = PRINT_ONGRID_3D; if(List_Nbr((yyvsp[(4) - (22)].l)) != 3 || List_Nbr((yyvsp[(7) - (22)].l)) != 3 || List_Nbr((yyvsp[(10) - (22)].l)) != 3 || List_Nbr((yyvsp[(13) - (22)].l)) != 3) vyyerror("Expected {3}{3}{3}{3} coordinates, got {%d}{%d}{%d}{%d}", List_Nbr((yyvsp[(4) - (22)].l)), List_Nbr((yyvsp[(7) - (22)].l)), List_Nbr((yyvsp[(10) - (22)].l)), List_Nbr((yyvsp[(13) - (22)].l))); else{ List_Read((yyvsp[(4) - (22)].l), 0, &PostSubOperation_S.Case.OnGrid.x[0]); List_Read((yyvsp[(4) - (22)].l), 1, &PostSubOperation_S.Case.OnGrid.y[0]); List_Read((yyvsp[(4) - (22)].l), 2, &PostSubOperation_S.Case.OnGrid.z[0]); List_Read((yyvsp[(7) - (22)].l), 0, &PostSubOperation_S.Case.OnGrid.x[1]); List_Read((yyvsp[(7) - (22)].l), 1, &PostSubOperation_S.Case.OnGrid.y[1]); List_Read((yyvsp[(7) - (22)].l), 2, &PostSubOperation_S.Case.OnGrid.z[1]); List_Read((yyvsp[(10) - (22)].l), 0, &PostSubOperation_S.Case.OnGrid.x[2]); List_Read((yyvsp[(10) - (22)].l), 1, &PostSubOperation_S.Case.OnGrid.y[2]); List_Read((yyvsp[(10) - (22)].l), 2, &PostSubOperation_S.Case.OnGrid.z[2]); List_Read((yyvsp[(13) - (22)].l), 0, &PostSubOperation_S.Case.OnGrid.x[3]); List_Read((yyvsp[(13) - (22)].l), 1, &PostSubOperation_S.Case.OnGrid.y[3]); List_Read((yyvsp[(13) - (22)].l), 2, &PostSubOperation_S.Case.OnGrid.z[3]); } PostSubOperation_S.Case.OnGrid.n[0] = (int)(yyvsp[(17) - (22)].d); PostSubOperation_S.Case.OnGrid.n[1] = (int)(yyvsp[(19) - (22)].d); PostSubOperation_S.Case.OnGrid.n[2] = (int)(yyvsp[(21) - (22)].d); List_Delete((yyvsp[(4) - (22)].l)); List_Delete((yyvsp[(7) - (22)].l)); List_Delete((yyvsp[(10) - (22)].l)); List_Delete((yyvsp[(13) - (22)].l)); ;} break; case 601: #line 6097 "ProParser.y" { PostSubOperation_S.SubType = PRINT_WITHARGUMENT; PostSubOperation_S.Case.WithArgument.RegionIndex = Num_Group(&Group_S, (char*)"PO_On", (yyvsp[(2) - (12)].i)); int i; if((i = List_ISearchSeq(Problem_S.Expression, (yyvsp[(4) - (12)].c), fcmp_Expression_Name)) < 0) vyyerror("Unknown Name of Expression: %s", (yyvsp[(4) - (12)].c)); Free((yyvsp[(4) - (12)].c)); PostSubOperation_S.Case.WithArgument.ArgumentIndex = i; PostSubOperation_S.Case.WithArgument.x[0] = (yyvsp[(6) - (12)].d); PostSubOperation_S.Case.WithArgument.x[1] = (yyvsp[(8) - (12)].d); PostSubOperation_S.Case.WithArgument.n = (int)(yyvsp[(11) - (12)].d); ;} break; case 602: #line 6117 "ProParser.y" { PostSubOperation_S.FileOut = NULL; PostSubOperation_S.Depth = 1; PostSubOperation_S.Smoothing = 0; PostSubOperation_S.Skin = 0; PostSubOperation_S.Comma = 0; PostSubOperation_S.Dimension = _ALL; PostSubOperation_S.Adapt = 0; PostSubOperation_S.Target = -1.; PostSubOperation_S.HarmonicToTime = 1; PostSubOperation_S.FrozenTimeStepList = 0; PostSubOperation_S.TimeStep_L = List_Create(10,10,sizeof(int));; PostSubOperation_S.Frequency_L = List_Create(10,10,sizeof(double));; PostSubOperation_S.Value_L = List_Create(10,10,sizeof(double));; PostSubOperation_S.Iso = 0; PostSubOperation_S.Iso_L = List_Create(10,10,sizeof(double));; PostSubOperation_S.Sort = 0; PostSubOperation_S.NoNewLine = 0; PostSubOperation_S.NoTitle = 0; PostSubOperation_S.DecomposeInSimplex = 0; PostSubOperation_S.NewCoordinates = 0; PostSubOperation_S.NewCoordinatesFile = NULL; PostSubOperation_S.ChangeOfCoordinates[0] = -1; PostSubOperation_S.ChangeOfCoordinates[1] = -1; PostSubOperation_S.ChangeOfCoordinates[2] = -1; PostSubOperation_S.ChangeOfValues = NULL; PostSubOperation_S.Legend = LEGEND_NONE; PostSubOperation_S.LegendPosition[0] = 0.; PostSubOperation_S.LegendPosition[1] = 0.; PostSubOperation_S.LegendPosition[2] = 0.; PostSubOperation_S.EvaluationPoints = NULL; PostSubOperation_S.StoreInRegister = -1; PostSubOperation_S.StoreInField = -1; PostSubOperation_S.LastTimeStepOnly = 0; PostSubOperation_S.AppendTimeStepToFileName = 0; PostSubOperation_S.OverrideTimeStepValue = -1; PostSubOperation_S.NoMesh = 0; PostSubOperation_S.SendToServer = NULL; PostSubOperation_S.Color = NULL; PostSubOperation_S.ValueIndex = 0; PostSubOperation_S.ValueName = NULL; PostSubOperation_S.Label = NULL; ;} break; case 604: #line 6165 "ProParser.y" { if(!PostOperation_S.AppendString){ PostSubOperation_S.FileOut = (yyvsp[(3) - (3)].c); } else{ PostSubOperation_S.FileOut = (char *)Malloc((strlen((yyvsp[(3) - (3)].c))+strlen(PostOperation_S.AppendString)+1)*sizeof(char)); strcpy(PostSubOperation_S.FileOut, (yyvsp[(3) - (3)].c)); strcat(PostSubOperation_S.FileOut, PostOperation_S.AppendString); Free((yyvsp[(3) - (3)].c)); } PostSubOperation_S.CatFile = 0; ;} break; case 605: #line 6179 "ProParser.y" { if(!PostOperation_S.AppendString){ PostSubOperation_S.FileOut = (yyvsp[(4) - (4)].c); } else{ PostSubOperation_S.FileOut = (char *)Malloc((strlen((yyvsp[(4) - (4)].c))+strlen(PostOperation_S.AppendString)+1)*sizeof(char)); strcpy(PostSubOperation_S.FileOut, (yyvsp[(4) - (4)].c)); strcat(PostSubOperation_S.FileOut, PostOperation_S.AppendString); Free((yyvsp[(4) - (4)].c)); } PostSubOperation_S.CatFile = 1; ;} break; case 606: #line 6193 "ProParser.y" { if(!PostOperation_S.AppendString){ PostSubOperation_S.FileOut = (yyvsp[(4) - (4)].c); } else{ PostSubOperation_S.FileOut = (char *)Malloc((strlen((yyvsp[(4) - (4)].c))+strlen(PostOperation_S.AppendString)+1)*sizeof(char)); strcpy(PostSubOperation_S.FileOut, (yyvsp[(4) - (4)].c)); strcat(PostSubOperation_S.FileOut, PostOperation_S.AppendString); Free((yyvsp[(4) - (4)].c)); } PostSubOperation_S.CatFile = 2; ;} break; case 607: #line 6207 "ProParser.y" { PostSubOperation_S.Depth = (int)(yyvsp[(3) - (3)].d); ;} break; case 608: #line 6211 "ProParser.y" { PostSubOperation_S.Skin = 1; ;} break; case 609: #line 6215 "ProParser.y" { PostSubOperation_S.Smoothing = 1; ;} break; case 610: #line 6219 "ProParser.y" { PostSubOperation_S.HarmonicToTime = (int)(yyvsp[(3) - (3)].d); ;} break; case 611: #line 6223 "ProParser.y" { PostSubOperation_S.Format = Get_DefineForString(PostSubOperation_Format, (yyvsp[(3) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown PostProcessing Format: %s", (yyvsp[(3) - (3)].c)); Get_Valid_SXD(PostSubOperation_Format); } Free((yyvsp[(3) - (3)].c)); ;} break; case 612: #line 6233 "ProParser.y" { PostSubOperation_S.Comma = 1; ;} break; case 613: #line 6237 "ProParser.y" { PostSubOperation_S.ValueIndex = (yyvsp[(3) - (3)].d); ;} break; case 614: #line 6241 "ProParser.y" { PostSubOperation_S.ValueName = (yyvsp[(3) - (3)].c); ;} break; case 615: #line 6245 "ProParser.y" { PostSubOperation_S.Label = (yyvsp[(3) - (3)].c); ;} break; case 616: #line 6249 "ProParser.y" { if((int)(yyvsp[(3) - (3)].d) >= 1 && (int)(yyvsp[(3) - (3)].d) <= 3) PostSubOperation_S.Dimension = (int)(yyvsp[(3) - (3)].d); else vyyerror("Wrong Dimension in Print"); ;} break; case 617: #line 6256 "ProParser.y" { PostSubOperation_S.FrozenTimeStepList = 1; for(int i = 0; i < List_Nbr((yyvsp[(3) - (3)].l)); i++){ double d; List_Read((yyvsp[(3) - (3)].l),i,&d); int j = (int)d; List_Add(PostSubOperation_S.TimeStep_L, &j); } List_Delete((yyvsp[(3) - (3)].l)); ;} break; case 618: #line 6267 "ProParser.y" { PostSubOperation_S.Adapt = Get_DefineForString(PostSubOperation_AdaptationType, (yyvsp[(3) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown Adaptation method: %s", (yyvsp[(3) - (3)].c)); Get_Valid_SXD(PostSubOperation_AdaptationType); } ;} break; case 619: #line 6276 "ProParser.y" { PostSubOperation_S.Sort = Get_DefineForString(PostSubOperation_SortType, (yyvsp[(3) - (3)].c), &FlagError); if(FlagError){ vyyerror("Unknown Sort method: %s", (yyvsp[(3) - (3)].c)); Get_Valid_SXD(PostSubOperation_SortType); } ;} break; case 620: #line 6285 "ProParser.y" { if((yyvsp[(3) - (3)].d) >= 0.) PostSubOperation_S.Target = (yyvsp[(3) - (3)].d); else vyyerror("Bad Target value"); ;} break; case 621: #line 6292 "ProParser.y" { for(int i = 0; i < List_Nbr((yyvsp[(3) - (3)].l)); i++){ double d; List_Read((yyvsp[(3) - (3)].l),i,&d); List_Add(PostSubOperation_S.Value_L, &d); } List_Delete((yyvsp[(3) - (3)].l)); ;} break; case 622: #line 6301 "ProParser.y" { PostSubOperation_S.Iso = (int)(yyvsp[(3) - (3)].d); ;} break; case 623: #line 6305 "ProParser.y" { PostSubOperation_S.Iso = -1; for(int i = 0; i < List_Nbr((yyvsp[(4) - (5)].l)); i++){ double d; List_Read((yyvsp[(4) - (5)].l),i,&d); List_Add(PostSubOperation_S.Iso_L, &d); } List_Delete((yyvsp[(4) - (5)].l)); ;} break; case 624: #line 6315 "ProParser.y" { PostSubOperation_S.NoNewLine = 1; ;} break; case 625: #line 6319 "ProParser.y" { PostSubOperation_S.NoTitle = 1; ;} break; case 626: #line 6323 "ProParser.y" { PostSubOperation_S.DecomposeInSimplex = 1; ;} break; case 627: #line 6327 "ProParser.y" { for(int i = 0; i < List_Nbr((yyvsp[(3) - (3)].l)); i++){ double d; List_Read((yyvsp[(3) - (3)].l),i,&d); List_Add(PostSubOperation_S.Frequency_L, &d); } List_Delete((yyvsp[(3) - (3)].l)); ;} break; case 628: #line 6336 "ProParser.y" { PostSubOperation_S.ChangeOfCoordinates[0] = (yyvsp[(4) - (9)].i); PostSubOperation_S.ChangeOfCoordinates[1] = (yyvsp[(6) - (9)].i); PostSubOperation_S.ChangeOfCoordinates[2] = (yyvsp[(8) - (9)].i); ;} break; case 629: #line 6342 "ProParser.y" { PostSubOperation_S.ChangeOfValues = List_Copy(ListOfInt_L); ;} break; case 630: #line 6346 "ProParser.y" { PostSubOperation_S.Legend = LEGEND_TIME; PostSubOperation_S.LegendPosition[0] = 1.e5; PostSubOperation_S.LegendPosition[1] = 30.; /* (align<<16)|(font<<8)|(fontsize) */ PostSubOperation_S.LegendPosition[2] = 66574; ;} break; case 631: #line 6354 "ProParser.y" { PostSubOperation_S.Legend = LEGEND_TIME; PostSubOperation_S.LegendPosition[0] = (yyvsp[(4) - (9)].d); PostSubOperation_S.LegendPosition[1] = (yyvsp[(6) - (9)].d); PostSubOperation_S.LegendPosition[2] = (yyvsp[(8) - (9)].d); ;} break; case 632: #line 6361 "ProParser.y" { PostSubOperation_S.Legend = LEGEND_FREQUENCY; PostSubOperation_S.LegendPosition[0] = 1.e5; PostSubOperation_S.LegendPosition[1] = 30.; /* (align<<16)|(font<<8)|(fontsize) */ PostSubOperation_S.LegendPosition[2] = 66574; ;} break; case 633: #line 6369 "ProParser.y" { PostSubOperation_S.Legend = LEGEND_FREQUENCY; PostSubOperation_S.LegendPosition[0] = (yyvsp[(4) - (9)].d); PostSubOperation_S.LegendPosition[1] = (yyvsp[(6) - (9)].d); PostSubOperation_S.LegendPosition[2] = (yyvsp[(8) - (9)].d); ;} break; case 634: #line 6376 "ProParser.y" { PostSubOperation_S.Legend = LEGEND_EIGENVALUES; PostSubOperation_S.LegendPosition[0] = 1.e5; PostSubOperation_S.LegendPosition[1] = 30.; /* (align<<16)|(font<<8)|(fontsize) */ PostSubOperation_S.LegendPosition[2] = 66574; ;} break; case 635: #line 6384 "ProParser.y" { PostSubOperation_S.Legend = LEGEND_EIGENVALUES; PostSubOperation_S.LegendPosition[0] = (yyvsp[(4) - (9)].d); PostSubOperation_S.LegendPosition[1] = (yyvsp[(6) - (9)].d); PostSubOperation_S.LegendPosition[2] = (yyvsp[(8) - (9)].d); ;} break; case 636: #line 6391 "ProParser.y" { if(List_Nbr((yyvsp[(4) - (5)].l))%3 != 0) vyyerror("Expected 3n coordinates, got %d", List_Nbr((yyvsp[(4) - (5)].l))); else { PostSubOperation_S.EvaluationPoints = (yyvsp[(4) - (5)].l); } ;} break; case 637: #line 6399 "ProParser.y" { PostSubOperation_S.StoreInRegister = (yyvsp[(3) - (3)].i) - 1; ;} break; case 638: #line 6403 "ProParser.y" { PostSubOperation_S.StoreInField = (yyvsp[(3) - (3)].d); ;} break; case 639: #line 6407 "ProParser.y" { PostSubOperation_S.LastTimeStepOnly = 1; ;} break; case 640: #line 6411 "ProParser.y" { PostSubOperation_S.AppendTimeStepToFileName = 1; ;} break; case 641: #line 6415 "ProParser.y" { PostSubOperation_S.AppendTimeStepToFileName = (yyvsp[(3) - (3)].d); ;} break; case 642: #line 6419 "ProParser.y" { PostSubOperation_S.OverrideTimeStepValue = (yyvsp[(3) - (3)].d); ;} break; case 643: #line 6423 "ProParser.y" { PostSubOperation_S.NoMesh = 1; ;} break; case 644: #line 6427 "ProParser.y" { PostSubOperation_S.SendToServer = (yyvsp[(3) - (3)].c); ;} break; case 645: #line 6431 "ProParser.y" { PostSubOperation_S.Color = (yyvsp[(3) - (3)].c); ;} break; case 646: #line 6435 "ProParser.y" { PostSubOperation_S.NewCoordinates = 1; PostSubOperation_S.NewCoordinatesFile = (yyvsp[(3) - (3)].c); ;} break; case 647: #line 6449 "ProParser.y" { LoopControlVariablesTab[ImbricatedLoop][0] = (yyvsp[(3) - (6)].d); LoopControlVariablesTab[ImbricatedLoop][1] = (yyvsp[(5) - (6)].d); LoopControlVariablesTab[ImbricatedLoop][2] = 1.0; LoopControlVariablesNameTab[ImbricatedLoop] = (char*)""; fgetpos(getdp_yyin, &FposImbricatedLoopsTab[ImbricatedLoop]); LinenoImbricatedLoopsTab[ImbricatedLoop] = getdp_yylinenum; if((yyvsp[(3) - (6)].d) > (yyvsp[(5) - (6)].d)) skipUntil("For", "EndFor"); else ImbricatedLoop++; if(ImbricatedLoop > MAX_RECUR_LOOPS-1){ vyyerror("Reached maximum number of imbricated loops"); ImbricatedLoop = MAX_RECUR_LOOPS-1; } ;} break; case 648: #line 6466 "ProParser.y" { LoopControlVariablesTab[ImbricatedLoop][0] = (yyvsp[(3) - (8)].d); LoopControlVariablesTab[ImbricatedLoop][1] = (yyvsp[(5) - (8)].d); LoopControlVariablesTab[ImbricatedLoop][2] = (yyvsp[(7) - (8)].d); LoopControlVariablesNameTab[ImbricatedLoop] = (char*)""; fgetpos(getdp_yyin, &FposImbricatedLoopsTab[ImbricatedLoop]); LinenoImbricatedLoopsTab[ImbricatedLoop] = getdp_yylinenum; if(((yyvsp[(7) - (8)].d) > 0. && (yyvsp[(3) - (8)].d) > (yyvsp[(5) - (8)].d)) || ((yyvsp[(7) - (8)].d) < 0. && (yyvsp[(3) - (8)].d) < (yyvsp[(5) - (8)].d))) skipUntil("For", "EndFor"); else ImbricatedLoop++; if(ImbricatedLoop > MAX_RECUR_LOOPS-1){ vyyerror("Reached maximum number of imbricated loops"); ImbricatedLoop = MAX_RECUR_LOOPS-1; } ;} break; case 649: #line 6483 "ProParser.y" { LoopControlVariablesTab[ImbricatedLoop][0] = (yyvsp[(5) - (8)].d); LoopControlVariablesTab[ImbricatedLoop][1] = (yyvsp[(7) - (8)].d); LoopControlVariablesTab[ImbricatedLoop][2] = 1.0; LoopControlVariablesNameTab[ImbricatedLoop] = (yyvsp[(2) - (8)].c); Constant_S.Name = (yyvsp[(2) - (8)].c); Constant_S.Type = VAR_FLOAT; Constant_S.Value.Float = (yyvsp[(5) - (8)].d); Tree_Replace(ConstantTable_L, &Constant_S); fgetpos(getdp_yyin, &FposImbricatedLoopsTab[ImbricatedLoop]); /* hack_fsetpos_printf(); */ LinenoImbricatedLoopsTab[ImbricatedLoop] = getdp_yylinenum; if((yyvsp[(5) - (8)].d) > (yyvsp[(7) - (8)].d)) skipUntil("For", "EndFor"); else ImbricatedLoop++; if(ImbricatedLoop > MAX_RECUR_LOOPS-1){ vyyerror("Reached maximum number of imbricated loops"); ImbricatedLoop = MAX_RECUR_LOOPS-1; } ;} break; case 650: #line 6505 "ProParser.y" { LoopControlVariablesTab[ImbricatedLoop][0] = (yyvsp[(5) - (10)].d); LoopControlVariablesTab[ImbricatedLoop][1] = (yyvsp[(7) - (10)].d); LoopControlVariablesTab[ImbricatedLoop][2] = (yyvsp[(9) - (10)].d); LoopControlVariablesNameTab[ImbricatedLoop] = (yyvsp[(2) - (10)].c); Constant_S.Name = (yyvsp[(2) - (10)].c); Constant_S.Type = VAR_FLOAT; Constant_S.Value.Float = (yyvsp[(5) - (10)].d); Tree_Replace(ConstantTable_L, &Constant_S); fgetpos(getdp_yyin, &FposImbricatedLoopsTab[ImbricatedLoop]); LinenoImbricatedLoopsTab[ImbricatedLoop] = getdp_yylinenum; if(((yyvsp[(9) - (10)].d) > 0. && (yyvsp[(5) - (10)].d) > (yyvsp[(7) - (10)].d)) || ((yyvsp[(9) - (10)].d) < 0. && (yyvsp[(5) - (10)].d) < (yyvsp[(7) - (10)].d))) skipUntil("For", "EndFor"); else ImbricatedLoop++; if(ImbricatedLoop > MAX_RECUR_LOOPS-1){ vyyerror("Reached maximum number of imbricated loops"); ImbricatedLoop = MAX_RECUR_LOOPS-1; } ;} break; case 651: #line 6526 "ProParser.y" { if(ImbricatedLoop <= 0){ vyyerror("Invalid For/EndFor loop"); ImbricatedLoop = 0; } else{ double x0 = LoopControlVariablesTab[ImbricatedLoop-1][0]; double x1 = LoopControlVariablesTab[ImbricatedLoop-1][1]; double step = LoopControlVariablesTab[ImbricatedLoop-1][2]; int do_next = (step > 0.) ? (x0+step <= x1) : (x0+step >= x1); if(do_next){ LoopControlVariablesTab[ImbricatedLoop-1][0] += LoopControlVariablesTab[ImbricatedLoop-1][2]; if(strlen(LoopControlVariablesNameTab[ImbricatedLoop-1])){ Constant_S.Name = LoopControlVariablesNameTab[ImbricatedLoop-1]; Constant_S.Type = VAR_FLOAT; Constant_S.Value.Float = LoopControlVariablesTab[ImbricatedLoop-1][0]; if(!Tree_Search(ConstantTable_L, &Constant_S)) vyyerror("Unknown For/EndFor loop control variable %s", Constant_S.Name); Tree_Replace(ConstantTable_L, &Constant_S); } fsetpos(getdp_yyin, &FposImbricatedLoopsTab[ImbricatedLoop-1]); /* fsetpos() seems to position the file just after the For but with one additional character (the one after EndFor) at the beginning. I do not understand why there is such a mixing of two separate data. hack_fsetpos() removes the useless additional character. */ hack_fsetpos(); /* hack_fsetpos_printf(); */ getdp_yylinenum = LinenoImbricatedLoopsTab[ImbricatedLoop-1]; } else{ ImbricatedLoop--; } } ;} break; case 652: #line 6564 "ProParser.y" { if(!(yyvsp[(3) - (4)].d)) skipUntil("If", "EndIf"); ;} break; case 653: #line 6568 "ProParser.y" { ;} break; case 657: #line 6587 "ProParser.y" { Constant_S.Name = (yyvsp[(1) - (4)].c); if(List_Nbr((yyvsp[(3) - (4)].l)) == 1){ Constant_S.Type = VAR_FLOAT; List_Read((yyvsp[(3) - (4)].l), 0, &Constant_S.Value.Float); List_Delete((yyvsp[(3) - (4)].l)); } else{ Constant_S.Type = VAR_LISTOFFLOAT; Constant_S.Value.ListOfFloat = (yyvsp[(3) - (4)].l); } Tree_Replace(ConstantTable_L, &Constant_S); ;} break; case 658: #line 6602 "ProParser.y" { Constant_S.Name = (yyvsp[(1) - (7)].c); Constant *c = (Constant*)Tree_PQuery(ConstantTable_L, &Constant_S); if(c && (c->Type == VAR_LISTOFFLOAT)){ if(List_Nbr((yyvsp[(3) - (7)].l)) == List_Nbr((yyvsp[(6) - (7)].l))){ for(int i = 0; i < List_Nbr((yyvsp[(3) - (7)].l)); i++){ double d; List_Read((yyvsp[(3) - (7)].l), i, &d); int idx = (int)d; if(idx >= 0 && idx < List_Nbr(c->Value.ListOfFloat)){ double *pd = (double*)List_Pointer(c->Value.ListOfFloat, idx); double d2 = *(double*)List_Pointer((yyvsp[(6) - (7)].l), i); *pd = d2; } else vyyerror("Index %d out of range", idx); } } else vyyerror("Bad list sizes for affectation %d != %d", List_Nbr((yyvsp[(3) - (7)].l)), List_Nbr((yyvsp[(6) - (7)].l))); } else vyyerror("Unknown list Constant: %s", (yyvsp[(1) - (7)].c)); List_Delete((yyvsp[(3) - (7)].l)); List_Delete((yyvsp[(6) - (7)].l)); ;} break; case 659: #line 6630 "ProParser.y" { Constant_S.Name = (yyvsp[(1) - (5)].c); Constant *c = (Constant*)Tree_PQuery(ConstantTable_L, &Constant_S); if(c){ if(c->Type == VAR_FLOAT && List_Nbr((yyvsp[(4) - (5)].l)) == 1){ double d; List_Read((yyvsp[(4) - (5)].l), 0, &d); c->Value.Float += d; } else if(c->Type == VAR_LISTOFFLOAT){ for(int i = 0; i < List_Nbr((yyvsp[(4) - (5)].l)); i++) List_Add(c->Value.ListOfFloat, List_Pointer((yyvsp[(4) - (5)].l), i)); } else vyyerror("Cannot append list to float"); } else vyyerror("Unknown Constant: %s", (yyvsp[(1) - (5)].c)); List_Delete((yyvsp[(4) - (5)].l)); ;} break; case 660: #line 6652 "ProParser.y" { Constant_S.Name = (yyvsp[(1) - (5)].c); Constant *c = (Constant*)Tree_PQuery(ConstantTable_L, &Constant_S); if(c){ if(c->Type == VAR_FLOAT && List_Nbr((yyvsp[(4) - (5)].l)) == 1){ double d; List_Read((yyvsp[(4) - (5)].l), 0, &d); c->Value.Float -= d; } else if(c->Type == VAR_LISTOFFLOAT){ std::vector tmp; for(int i = 0; i < List_Nbr(c->Value.ListOfFloat); i++){ double d; List_Read(c->Value.ListOfFloat, i, &d); tmp.push_back(d); } for(int i = 0; i < List_Nbr((yyvsp[(4) - (5)].l)); i++){ double d; List_Read((yyvsp[(4) - (5)].l), i, &d); std::vector::iterator it = std::find(tmp.begin(), tmp.end(), d); if(it != tmp.end()) tmp.erase(it); } List_Reset(c->Value.ListOfFloat); for(unsigned int i = 0; i < tmp.size(); i++) List_Add(c->Value.ListOfFloat, &tmp[i]); } else vyyerror("Cannot erase list from float"); } else vyyerror("Unknown Constant: %s", (yyvsp[(1) - (5)].c)); List_Delete((yyvsp[(4) - (5)].l)); ;} break; case 661: #line 6687 "ProParser.y" { Constant_S.Name = (yyvsp[(1) - (4)].c); Constant_S.Type = VAR_CHAR; Constant_S.Value.Char = (yyvsp[(3) - (4)].c); Tree_Replace(ConstantTable_L, &Constant_S); ;} break; case 662: #line 6694 "ProParser.y" { Constant_S.Name = (yyvsp[(1) - (7)].c); Constant_S.Type = VAR_CHAR; Constant_S.Value.Char = (yyvsp[(5) - (7)].c); Tree_Replace(ConstantTable_L, &Constant_S); ;} break; case 663: #line 6701 "ProParser.y" { Constant_S.Name = (yyvsp[(1) - (7)].c); Constant_S.Type = VAR_CHAR; Constant_S.Value.Char = (yyvsp[(5) - (7)].c); Tree_Replace(ConstantTable_L, &Constant_S); ;} break; case 664: #line 6708 "ProParser.y" { Constant_S.Name = (yyvsp[(1) - (4)].c); Constant_S.Type = VAR_CHAR; Constant_S.Value.Char = (yyvsp[(3) - (4)].c); Tree_Replace(ConstantTable_L, &Constant_S); ;} break; case 665: #line 6715 "ProParser.y" { Constant_S.Name = (yyvsp[(1) - (7)].c); Constant_S.Type = VAR_LISTOFFLOAT; Message::Barrier(); FILE *File; if(!(File = FOpen((yyvsp[(5) - (7)].c), "r"))){ Message::Warning("Could not open file '%s'", (yyvsp[(5) - (7)].c)); Constant_S.Value.ListOfFloat = NULL; } else{ Constant_S.Value.ListOfFloat = List_Create(100,100,sizeof(double)); double d; while(!feof(File)) if(fscanf(File, "%lf", &d) != EOF) List_Add(Constant_S.Value.ListOfFloat, &d); fclose(File); } Tree_Replace(ConstantTable_L, &Constant_S); ;} break; case 666: #line 6736 "ProParser.y" { Message::Direct((yyvsp[(3) - (5)].c)); ;} break; case 667: #line 6741 "ProParser.y" { Message::Direct((yyvsp[(3) - (5)].c)); ;} break; case 668: #line 6746 "ProParser.y" { Constant_S.Name = (yyvsp[(2) - (3)].c); if(!Tree_Query(ConstantTable_L, &Constant_S)) vyyerror("Unknown Constant: %s", (yyvsp[(2) - (3)].c)); else if(Constant_S.Type != VAR_LISTOFFLOAT) Message::Direct("%s: %g", (yyvsp[(2) - (3)].c), Constant_S.Value.Float); else Message::Direct("%s: Dimension %d", (yyvsp[(2) - (3)].c), List_Nbr(Constant_S.Value.ListOfFloat)); for(int i = 0; i < List_Nbr(Constant_S.Value.ListOfFloat); i++) { double d; List_Read(Constant_S.Value.ListOfFloat, i, &d); Message::Direct(" (%d) %g", i, d); } ;} break; case 669: #line 6763 "ProParser.y" { Message::Direct("Line number: %d", getdp_yylinenum); ;} break; case 670: #line 6769 "ProParser.y" { char tmpstr[256]; int i = Print_ListOfDouble((yyvsp[(3) - (7)].c), (yyvsp[(5) - (7)].l), tmpstr); if(i < 0) vyyerror("Too few arguments in Printf"); else if(i > 0) vyyerror("Too many arguments (%d) in Printf", i); else Message::Direct(tmpstr); List_Delete((yyvsp[(5) - (7)].l)); ;} break; case 671: #line 6782 "ProParser.y" { char tmpstr[256]; int i = Print_ListOfDouble((yyvsp[(3) - (7)].c), (yyvsp[(5) - (7)].l), tmpstr); if(i < 0) vyyerror("Too few arguments in Printf"); else if(i > 0) vyyerror("Too many arguments (%d) in Printf", i); else Message::Direct(tmpstr); List_Delete((yyvsp[(5) - (7)].l)); ;} break; case 672: #line 6796 "ProParser.y" { Message::Info("? "); char tmpstr[256]; fgets(tmpstr, sizeof(tmpstr), stdin); Constant_S.Value.Float = atof(tmpstr); Constant_S.Name = (yyvsp[(3) - (5)].c); Constant_S.Type = VAR_FLOAT; Tree_Replace(ConstantTable_L, &Constant_S); ;} break; case 673: #line 6807 "ProParser.y" { Message::Info("? "); char tmpstr[256]; fgets(tmpstr, sizeof(tmpstr), stdin); Constant_S.Value.Float = atof(tmpstr); Constant_S.Name = (yyvsp[(3) - (5)].c); Constant_S.Type = VAR_FLOAT; Tree_Replace(ConstantTable_L, &Constant_S); ;} break; case 674: #line 6819 "ProParser.y" { Message::Info("[=%g] ? ",(yyvsp[(6) - (8)].d)); char tmpstr[256]; fgets(tmpstr, sizeof(tmpstr), stdin); if(!strcmp(tmpstr,"\n")) Constant_S.Value.Float = (yyvsp[(6) - (8)].d); else Constant_S.Value.Float = atof(tmpstr); Constant_S.Name = (yyvsp[(3) - (8)].c); Constant_S.Type = VAR_FLOAT; Tree_Replace(ConstantTable_L, &Constant_S); ;} break; case 675: #line 6834 "ProParser.y" { Message::Info("[=%g] ? ",(yyvsp[(5) - (7)].d)); char tmpstr[256]; fgets(tmpstr, sizeof(tmpstr), stdin); if(!strcmp(tmpstr,"\n")) Constant_S.Value.Float = (yyvsp[(5) - (7)].d); else Constant_S.Value.Float = atof(tmpstr); Constant_S.Name = (yyvsp[(3) - (7)].c); Constant_S.Type = VAR_FLOAT; Tree_Replace(ConstantTable_L, &Constant_S); ;} break; case 676: #line 6849 "ProParser.y" { Print_Constants(); ;} break; case 677: #line 6856 "ProParser.y" { (yyval.l) = List_Create(20,20,sizeof(doubleXstring)); doubleXstring v = {(yyvsp[(1) - (3)].d), (yyvsp[(3) - (3)].c)}; List_Add((yyval.l), &v); ;} break; case 678: #line 6862 "ProParser.y" { doubleXstring v = {(yyvsp[(3) - (5)].d), (yyvsp[(5) - (5)].c)}; List_Add((yyval.l), &v); ;} break; case 681: #line 6875 "ProParser.y" { std::string key((yyvsp[(2) - (3)].c)); for(int i = 0; i < List_Nbr((yyvsp[(3) - (3)].l)); i++){ double v; List_Read((yyvsp[(3) - (3)].l), i, &v); FloatOptions_S[key].push_back(v); } Free((yyvsp[(2) - (3)].c)); List_Delete((yyvsp[(3) - (3)].l)); ;} break; case 682: #line 6887 "ProParser.y" { std::string key((yyvsp[(2) - (5)].c)); for(int i = 0; i < List_Nbr((yyvsp[(4) - (5)].l)); i++){ doubleXstring v; List_Read((yyvsp[(4) - (5)].l), i, &v); FloatOptions_S[key].push_back(v.d); CharOptions_S[key].push_back(v.s); } Free((yyvsp[(2) - (5)].c)); for(int i = 0; i < List_Nbr((yyvsp[(4) - (5)].l)); i++) Free(((doubleXstring*)List_Pointer((yyvsp[(4) - (5)].l), i))->s); List_Delete((yyvsp[(4) - (5)].l)); ;} break; case 683: #line 6902 "ProParser.y" { std::string key((yyvsp[(2) - (3)].c)); std::string val((yyvsp[(3) - (3)].c)); CharOptions_S[key].push_back(val); Free((yyvsp[(2) - (3)].c)); Free((yyvsp[(3) - (3)].c)); ;} break; case 686: #line 6918 "ProParser.y" { std::string key((yyvsp[(2) - (3)].c)); double val = (yyvsp[(3) - (3)].d); FloatOptions_S[key].push_back(val); Free((yyvsp[(2) - (3)].c)); ;} break; case 687: #line 6926 "ProParser.y" { std::string key((yyvsp[(2) - (3)].c)); std::string val((yyvsp[(3) - (3)].c)); CharOptions_S[key].push_back(val); Free((yyvsp[(2) - (3)].c)); Free((yyvsp[(3) - (3)].c)); ;} break; case 688: #line 6935 "ProParser.y" { std::string key((yyvsp[(2) - (5)].c)); for(int i = 0; i < List_Nbr((yyvsp[(4) - (5)].l)); i++){ char *s; List_Read((yyvsp[(4) - (5)].l), i, &s); std::string val(s); Free(s); CharOptions_S[key].push_back(val); } Free((yyvsp[(2) - (5)].c)); List_Delete((yyvsp[(4) - (5)].l)); ;} break; case 690: #line 6953 "ProParser.y" { Constant_S.Name = (yyvsp[(3) - (3)].c); Constant_S.Type = VAR_FLOAT; Constant_S.Value.Float = 0.; FloatOptions_S.clear(); CharOptions_S.clear(); if(!Tree_Search(ConstantTable_L, &Constant_S)){ Tree_Replace(ConstantTable_L, &Constant_S); } ;} break; case 691: #line 6961 "ProParser.y" { Constant_S.Type = VAR_FLOAT ; Constant_S.Value.Float = 0. ; FloatOptions_S.clear(); CharOptions_S.clear(); for (int k = 0 ; k < (int)(yyvsp[(5) - (6)].d) ; k++) { char tmpstr[256]; sprintf(tmpstr, "%s_%d", (yyvsp[(3) - (6)].c), k+1) ; Constant_S.Name = tmpstr ; if (!Tree_Search(ConstantTable_L, &Constant_S)) { Constant_S.Name = strSave(tmpstr); Tree_Replace(ConstantTable_L, &Constant_S) ; } } Free((yyvsp[(3) - (6)].c)) ; ;} break; case 692: #line 6977 "ProParser.y" { Constant_S.Name = (yyvsp[(3) - (5)].c); Constant_S.Type = VAR_FLOAT; Constant_S.Value.Float = (yyvsp[(5) - (5)].d); FloatOptions_S.clear(); CharOptions_S.clear(); if(!Tree_Search(ConstantTable_L, &Constant_S)){ Message::ExchangeOnelabParameter(&Constant_S, FloatOptions_S, CharOptions_S); Tree_Replace(ConstantTable_L, &Constant_S); } ;} break; case 693: #line 6986 "ProParser.y" { FloatOptions_S.clear(); CharOptions_S.clear(); ;} break; case 694: #line 6988 "ProParser.y" { Constant_S.Name = (yyvsp[(3) - (9)].c); Constant_S.Type = VAR_FLOAT; Constant_S.Value.Float = (yyvsp[(6) - (9)].d); if(!Tree_Search(ConstantTable_L, &Constant_S)){ Message::ExchangeOnelabParameter(&Constant_S, FloatOptions_S, CharOptions_S); Tree_Replace(ConstantTable_L, &Constant_S); } ;} break; case 695: #line 6996 "ProParser.y" { Constant_S.Name = (yyvsp[(3) - (5)].c); Constant_S.Type = VAR_CHAR; Constant_S.Value.Char = (yyvsp[(5) - (5)].c); FloatOptions_S.clear(); CharOptions_S.clear(); if(!Tree_Search(ConstantTable_L, &Constant_S)){ Message::ExchangeOnelabParameter(&Constant_S, FloatOptions_S, CharOptions_S); Tree_Replace(ConstantTable_L, &Constant_S); } ;} break; case 696: #line 7005 "ProParser.y" { FloatOptions_S.clear(); CharOptions_S.clear(); ;} break; case 697: #line 7007 "ProParser.y" { Constant_S.Name = (yyvsp[(3) - (9)].c); Constant_S.Type = VAR_CHAR; Constant_S.Value.Char = (yyvsp[(6) - (9)].c); if(!Tree_Search(ConstantTable_L, &Constant_S)){ Message::ExchangeOnelabParameter(&Constant_S, FloatOptions_S, CharOptions_S); Tree_Replace(ConstantTable_L, &Constant_S); } ;} break; case 699: #line 7020 "ProParser.y" { // undefine the onelab parameter std::string name((yyvsp[(3) - (3)].c)); Message::UndefineOnelabParameter(name); Free((yyvsp[(3) - (3)].c)); ;} break; case 700: #line 7028 "ProParser.y" { // undefine the onelab parameter and the getdp constant std::string name((yyvsp[(3) - (3)].c)); Message::UndefineOnelabParameter(name); Constant_S.Name = (yyvsp[(3) - (3)].c); Tree_Suppress(ConstantTable_L, &Constant_S); Free((yyvsp[(3) - (3)].c)); ;} break; case 701: #line 7042 "ProParser.y" { (yyval.c) = (char*)"Exp"; ;} break; case 702: #line 7043 "ProParser.y" { (yyval.c) = (char*)"Log"; ;} break; case 703: #line 7044 "ProParser.y" { (yyval.c) = (char*)"Log10"; ;} break; case 704: #line 7045 "ProParser.y" { (yyval.c) = (char*)"Sqrt"; ;} break; case 705: #line 7046 "ProParser.y" { (yyval.c) = (char*)"Sin"; ;} break; case 706: #line 7047 "ProParser.y" { (yyval.c) = (char*)"Asin"; ;} break; case 707: #line 7048 "ProParser.y" { (yyval.c) = (char*)"Cos"; ;} break; case 708: #line 7049 "ProParser.y" { (yyval.c) = (char*)"Acos"; ;} break; case 709: #line 7050 "ProParser.y" { (yyval.c) = (char*)"Tan"; ;} break; case 710: #line 7051 "ProParser.y" { (yyval.c) = (char*)"Atan"; ;} break; case 711: #line 7052 "ProParser.y" { (yyval.c) = (char*)"Atan2"; ;} break; case 712: #line 7053 "ProParser.y" { (yyval.c) = (char*)"Sinh"; ;} break; case 713: #line 7054 "ProParser.y" { (yyval.c) = (char*)"Cosh"; ;} break; case 714: #line 7055 "ProParser.y" { (yyval.c) = (char*)"Tanh"; ;} break; case 715: #line 7056 "ProParser.y" { (yyval.c) = (char*)"Fabs"; ;} break; case 716: #line 7057 "ProParser.y" { (yyval.c) = (char*)"Floor"; ;} break; case 717: #line 7058 "ProParser.y" { (yyval.c) = (char*)"Ceil"; ;} break; case 718: #line 7059 "ProParser.y" { (yyval.c) = (char*)"Round"; ;} break; case 719: #line 7060 "ProParser.y" { (yyval.c) = (char*)"Sign"; ;} break; case 720: #line 7061 "ProParser.y" { (yyval.c) = (char*)"Fmod"; ;} break; case 721: #line 7062 "ProParser.y" { (yyval.c) = (char*)"Modulo"; ;} break; case 722: #line 7063 "ProParser.y" { (yyval.c) = (char*)"Hypot"; ;} break; case 723: #line 7064 "ProParser.y" { (yyval.c) = (char*)"Rand"; ;} break; case 724: #line 7068 "ProParser.y" { (yyval.c) = (yyvsp[(1) - (1)].c); ;} break; case 725: #line 7069 "ProParser.y" { (yyval.c) = (yyvsp[(1) - (1)].c); ;} break; case 726: #line 7073 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (1)].d); ;} break; case 727: #line 7074 "ProParser.y" { (yyval.d) = (yyvsp[(2) - (3)].d); ;} break; case 728: #line 7075 "ProParser.y" { (yyval.d) = -(yyvsp[(2) - (2)].d); ;} break; case 729: #line 7076 "ProParser.y" { (yyval.d) = !(yyvsp[(2) - (2)].d); ;} break; case 730: #line 7077 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (3)].d) - (yyvsp[(3) - (3)].d); ;} break; case 731: #line 7078 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (3)].d) + (yyvsp[(3) - (3)].d); ;} break; case 732: #line 7079 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (3)].d) * (yyvsp[(3) - (3)].d); ;} break; case 733: #line 7080 "ProParser.y" { (yyval.d) = (int)(yyvsp[(1) - (3)].d) | (int)(yyvsp[(3) - (3)].d); ;} break; case 734: #line 7081 "ProParser.y" { (yyval.d) = (int)(yyvsp[(1) - (3)].d) & (int)(yyvsp[(3) - (3)].d); ;} break; case 735: #line 7082 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (3)].d) / (yyvsp[(3) - (3)].d); ;} break; case 736: #line 7083 "ProParser.y" { (yyval.d) = (int)(yyvsp[(1) - (3)].d) % (int)(yyvsp[(3) - (3)].d); ;} break; case 737: #line 7084 "ProParser.y" { (yyval.d) = pow((yyvsp[(1) - (3)].d),(yyvsp[(3) - (3)].d)); ;} break; case 738: #line 7085 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (3)].d) < (yyvsp[(3) - (3)].d); ;} break; case 739: #line 7086 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (3)].d) > (yyvsp[(3) - (3)].d); ;} break; case 740: #line 7087 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (3)].d) <= (yyvsp[(3) - (3)].d); ;} break; case 741: #line 7088 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (3)].d) >= (yyvsp[(3) - (3)].d); ;} break; case 742: #line 7089 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (3)].d) == (yyvsp[(3) - (3)].d); ;} break; case 743: #line 7090 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (3)].d) != (yyvsp[(3) - (3)].d); ;} break; case 744: #line 7091 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (3)].d) && (yyvsp[(3) - (3)].d); ;} break; case 745: #line 7092 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (3)].d) || (yyvsp[(3) - (3)].d); ;} break; case 746: #line 7093 "ProParser.y" { (yyval.d) = exp((yyvsp[(3) - (4)].d)); ;} break; case 747: #line 7094 "ProParser.y" { (yyval.d) = log((yyvsp[(3) - (4)].d)); ;} break; case 748: #line 7095 "ProParser.y" { (yyval.d) = log10((yyvsp[(3) - (4)].d)); ;} break; case 749: #line 7096 "ProParser.y" { (yyval.d) = sqrt((yyvsp[(3) - (4)].d)); ;} break; case 750: #line 7097 "ProParser.y" { (yyval.d) = sin((yyvsp[(3) - (4)].d)); ;} break; case 751: #line 7098 "ProParser.y" { (yyval.d) = asin((yyvsp[(3) - (4)].d)); ;} break; case 752: #line 7099 "ProParser.y" { (yyval.d) = cos((yyvsp[(3) - (4)].d)); ;} break; case 753: #line 7100 "ProParser.y" { (yyval.d) = acos((yyvsp[(3) - (4)].d)); ;} break; case 754: #line 7101 "ProParser.y" { (yyval.d) = tan((yyvsp[(3) - (4)].d)); ;} break; case 755: #line 7102 "ProParser.y" { (yyval.d) = atan((yyvsp[(3) - (4)].d)); ;} break; case 756: #line 7103 "ProParser.y" { (yyval.d) = atan2((yyvsp[(3) - (6)].d),(yyvsp[(5) - (6)].d)); ;} break; case 757: #line 7104 "ProParser.y" { (yyval.d) = sinh((yyvsp[(3) - (4)].d)); ;} break; case 758: #line 7105 "ProParser.y" { (yyval.d) = cosh((yyvsp[(3) - (4)].d)); ;} break; case 759: #line 7106 "ProParser.y" { (yyval.d) = tanh((yyvsp[(3) - (4)].d)); ;} break; case 760: #line 7107 "ProParser.y" { (yyval.d) = fabs((yyvsp[(3) - (4)].d)); ;} break; case 761: #line 7108 "ProParser.y" { (yyval.d) = floor((yyvsp[(3) - (4)].d)); ;} break; case 762: #line 7109 "ProParser.y" { (yyval.d) = ceil((yyvsp[(3) - (4)].d)); ;} break; case 763: #line 7110 "ProParser.y" { (yyval.d) = floor((yyvsp[(3) - (4)].d) + 0.5); ;} break; case 764: #line 7111 "ProParser.y" { (yyval.d) = (((yyvsp[(3) - (4)].d) > 0.) ? 1. : ((yyvsp[(3) - (4)].d) < 0.) ? -1. : 0.); ;} break; case 765: #line 7112 "ProParser.y" { (yyval.d) = fmod((yyvsp[(3) - (6)].d),(yyvsp[(5) - (6)].d)); ;} break; case 766: #line 7113 "ProParser.y" { (yyval.d) = fmod((yyvsp[(3) - (6)].d),(yyvsp[(5) - (6)].d)); ;} break; case 767: #line 7114 "ProParser.y" { (yyval.d) = sqrt((yyvsp[(3) - (6)].d)*(yyvsp[(3) - (6)].d)+(yyvsp[(5) - (6)].d)*(yyvsp[(5) - (6)].d)); ;} break; case 768: #line 7115 "ProParser.y" { (yyval.d) = (yyvsp[(3) - (4)].d) * (double)rand() / (double)RAND_MAX; ;} break; case 769: #line 7117 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (5)].d)? (yyvsp[(3) - (5)].d) : (yyvsp[(5) - (5)].d); ;} break; case 770: #line 7119 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (1)].i); ;} break; case 771: #line 7121 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (1)].i); ;} break; case 772: #line 7123 "ProParser.y" { Message::Direct("Value (line %ld) --> %.16g", getdp_yylinenum, (yyvsp[(1) - (2)].d)); ;} break; case 773: #line 7128 "ProParser.y" { (yyval.d) = (yyvsp[(1) - (1)].d); ;} break; case 774: #line 7129 "ProParser.y" { (yyval.d) = (double)(yyvsp[(1) - (1)].i); ;} break; case 775: #line 7130 "ProParser.y" { (yyval.d) = 3.1415926535897932; ;} break; case 776: #line 7131 "ProParser.y" { (yyval.d) = (double)_0D; ;} break; case 777: #line 7132 "ProParser.y" { (yyval.d) = (double)_1D; ;} break; case 778: #line 7133 "ProParser.y" { (yyval.d) = (double)_2D; ;} break; case 779: #line 7134 "ProParser.y" { (yyval.d) = (double)_3D; ;} break; case 780: #line 7135 "ProParser.y" { (yyval.d) = Message::GetCommRank(); ;} break; case 781: #line 7136 "ProParser.y" { (yyval.d) = Message::GetCommSize(); ;} break; case 782: #line 7138 "ProParser.y" { Constant_S.Name = (yyvsp[(1) - (1)].c); if(!Tree_Query(ConstantTable_L, &Constant_S)) { vyyerror("Unknown Constant: %s", (yyvsp[(1) - (1)].c)); (yyval.d) = 0.; } else { if(Constant_S.Type == VAR_FLOAT) (yyval.d) = Constant_S.Value.Float; else { vyyerror("Single value Constant needed: %s", (yyvsp[(1) - (1)].c)); (yyval.d) = 0.; } } Free((yyvsp[(1) - (1)].c)); ;} break; case 783: #line 7152 "ProParser.y" { Constant_S.Name = (yyvsp[(2) - (4)].c); int ret = 0; if(!Tree_Query(ConstantTable_L, &Constant_S)) vyyerror("Unknown Constant: %s", (yyvsp[(2) - (4)].c)); else{ if(Constant_S.Type != VAR_LISTOFFLOAT) vyyerror("Multi value Constant needed: %s", (yyvsp[(2) - (4)].c)); else ret = List_Nbr(Constant_S.Value.ListOfFloat); } (yyval.d) = ret; Free((yyvsp[(2) - (4)].c)); ;} break; case 784: #line 7167 "ProParser.y" { Constant_S.Name = (yyvsp[(1) - (4)].c); double ret = 0.; if(!Tree_Query(ConstantTable_L, &Constant_S)) vyyerror("Unknown Constant: %s", (yyvsp[(1) - (4)].c)); else{ if(Constant_S.Type != VAR_LISTOFFLOAT) vyyerror("Multi value Constant needed: %s", (yyvsp[(1) - (4)].c)); else{ int j = (int)(yyvsp[(3) - (4)].d); if(j >= 0 && j < List_Nbr(Constant_S.Value.ListOfFloat)) List_Read(Constant_S.Value.ListOfFloat, j, &ret); else vyyerror("Index %d out of range", j); } } (yyval.d) = ret; Free((yyvsp[(1) - (4)].c)); ;} break; case 785: #line 7191 "ProParser.y" { (yyval.l) = NULL; ;} break; case 786: #line 7194 "ProParser.y" { (yyval.l) = List_Create(1,1,sizeof(double)); ;} break; case 787: #line 7197 "ProParser.y" { (yyval.l) = List_Create(1,1,sizeof(double)); List_Add((yyval.l), &((yyvsp[(1) - (1)].d))); ;} break; case 788: #line 7203 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (1)].l); ;} break; case 789: #line 7206 "ProParser.y" { (yyval.l) = (yyvsp[(2) - (3)].l); ;} break; case 790: #line 7213 "ProParser.y" { (yyval.l) = List_Create(20,20,sizeof(double)); List_Add((yyval.l), &((yyvsp[(1) - (1)].d))); ;} break; case 791: #line 7219 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (1)].l); ;} break; case 792: #line 7222 "ProParser.y" { List_Add((yyval.l), &((yyvsp[(3) - (3)].d))); ;} break; case 793: #line 7225 "ProParser.y" { for(int i = 0; i < List_Nbr((yyvsp[(3) - (3)].l)); i++){ double d; List_Read((yyvsp[(3) - (3)].l), i, &d); List_Add((yyval.l), &d); } List_Delete((yyvsp[(3) - (3)].l)); ;} break; case 794: #line 7238 "ProParser.y" { (yyval.l) = List_Create(2, 1, sizeof(List_T*)); List_Add((yyval.l), &((yyvsp[(1) - (1)].l))); ;} break; case 795: #line 7244 "ProParser.y" { List_Add((yyval.l), &((yyvsp[(3) - (3)].l))); ;} break; case 796: #line 7252 "ProParser.y" { (yyval.l) = (yyvsp[(2) - (2)].l); for(int i = 0; i < List_Nbr((yyval.l)); i++){ double *pd = (double*)List_Pointer((yyval.l), i); *pd *= -1.0; } ;} break; case 797: #line 7261 "ProParser.y" { (yyval.l) = (yyvsp[(3) - (3)].l); for(int i = 0; i < List_Nbr((yyval.l)); i++){ double *pd = (double*)List_Pointer((yyval.l), i); *pd *= (yyvsp[(1) - (3)].d); } ;} break; case 798: #line 7270 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (3)].l); for(int i = 0; i < List_Nbr((yyval.l)); i++){ double *pd = (double*)List_Pointer((yyval.l), i); *pd *= (yyvsp[(3) - (3)].d); } ;} break; case 799: #line 7279 "ProParser.y" { (yyval.l) = (yyvsp[(3) - (3)].l); for(int i = 0; i < List_Nbr((yyval.l)); i++){ double *pd = (double*)List_Pointer((yyval.l), i); if(*pd) *pd = (yyvsp[(1) - (3)].d) / *pd; } ;} break; case 800: #line 7288 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (3)].l); for(int i = 0; i < List_Nbr((yyval.l)); i++){ double *pd = (double*)List_Pointer((yyval.l), i); if((yyvsp[(3) - (3)].d)) *pd /= (yyvsp[(3) - (3)].d); } ;} break; case 801: #line 7297 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (3)].l); for(int i = 0; i < List_Nbr((yyval.l)); i++){ double *pd = (double*)List_Pointer((yyval.l), i); *pd = pow(*pd, (yyvsp[(3) - (3)].d)); } ;} break; case 802: #line 7306 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (3)].l); if(List_Nbr((yyval.l)) == List_Nbr((yyvsp[(3) - (3)].l))){ for(int i = 0; i < List_Nbr((yyval.l)); i++){ double *pd = (double*)List_Pointer((yyval.l), i); double d = *(double*)List_Pointer((yyvsp[(3) - (3)].l), i); *pd += d; } } else vyyerror("Wrong list sizes %d != %d", List_Nbr((yyval.l)), List_Nbr((yyvsp[(3) - (3)].l))); List_Delete((yyvsp[(3) - (3)].l)); ;} break; case 803: #line 7321 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (3)].l); if(List_Nbr((yyval.l)) == List_Nbr((yyvsp[(3) - (3)].l))){ for(int i = 0; i < List_Nbr((yyval.l)); i++){ double *pd = (double*)List_Pointer((yyval.l), i); double d = *(double*)List_Pointer((yyvsp[(3) - (3)].l), i); *pd -= d; } } else vyyerror("Wrong list sizes %d != %d", List_Nbr((yyval.l)), List_Nbr((yyvsp[(3) - (3)].l))); List_Delete((yyvsp[(3) - (3)].l)); ;} break; case 804: #line 7336 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (3)].l); if(List_Nbr((yyval.l)) == List_Nbr((yyvsp[(3) - (3)].l))){ for(int i = 0; i < List_Nbr((yyval.l)); i++){ double *pd = (double*)List_Pointer((yyval.l), i); double d = *(double*)List_Pointer((yyvsp[(3) - (3)].l), i); *pd *= d; } } else vyyerror("Wrong list sizes %d != %d", List_Nbr((yyval.l)), List_Nbr((yyvsp[(3) - (3)].l))); List_Delete((yyvsp[(3) - (3)].l)); ;} break; case 805: #line 7351 "ProParser.y" { (yyval.l) = (yyvsp[(1) - (3)].l); if(List_Nbr((yyval.l)) == List_Nbr((yyvsp[(3) - (3)].l))){ for(int i = 0; i < List_Nbr((yyval.l)); i++){ double *pd = (double*)List_Pointer((yyval.l), i); double d = *(double*)List_Pointer((yyvsp[(3) - (3)].l), i); if(d) *pd /= d; } } else vyyerror("Wrong list sizes %d != %d", List_Nbr((yyval.l)), List_Nbr((yyvsp[(3) - (3)].l))); List_Delete((yyvsp[(3) - (3)].l)); ;} break; case 806: #line 7366 "ProParser.y" { (yyval.l) = List_Create(20,20,sizeof(double)); for(double d = (yyvsp[(1) - (3)].d); ((yyvsp[(1) - (3)].d) < (yyvsp[(3) - (3)].d)) ? (d <= (yyvsp[(3) - (3)].d)) : (d >= (yyvsp[(3) - (3)].d)); ((yyvsp[(1) - (3)].d) < (yyvsp[(3) - (3)].d)) ? (d += 1.) : (d -= 1.)) List_Add((yyval.l), &d); ;} break; case 807: #line 7374 "ProParser.y" { (yyval.l) = List_Create(20,20,sizeof(double)); if(!(yyvsp[(5) - (5)].d) || ((yyvsp[(1) - (5)].d)<(yyvsp[(3) - (5)].d) && (yyvsp[(5) - (5)].d)<0) || ((yyvsp[(1) - (5)].d)>(yyvsp[(3) - (5)].d) && (yyvsp[(5) - (5)].d)>0)){ vyyerror("Wrong increment in '%g : %g : %g'", (yyvsp[(1) - (5)].d), (yyvsp[(3) - (5)].d), (yyvsp[(5) - (5)].d)); List_Add((yyval.l), &((yyvsp[(1) - (5)].d))); } else for(double d = (yyvsp[(1) - (5)].d); ((yyvsp[(5) - (5)].d) > 0) ? (d <= (yyvsp[(3) - (5)].d)) : (d >= (yyvsp[(3) - (5)].d)); d += (yyvsp[(5) - (5)].d)) List_Add((yyval.l), &d); ;} break; case 808: #line 7386 "ProParser.y" { (yyval.l) = List_Create(20,20,sizeof(double)); Constant_S.Name = (yyvsp[(1) - (3)].c); if(!Tree_Query(ConstantTable_L, &Constant_S)) vyyerror("Unknown Constant: %s", (yyvsp[(1) - (3)].c)); else if(Constant_S.Type != VAR_LISTOFFLOAT) /* vyyerror("Multi value Constant needed: %s", $1); */ List_Add((yyval.l), &Constant_S.Value.Float); else for(int i = 0; i < List_Nbr(Constant_S.Value.ListOfFloat); i++) { double d; List_Read(Constant_S.Value.ListOfFloat, i, &d); List_Add((yyval.l), &d); } ;} break; case 809: #line 7405 "ProParser.y" { (yyval.l) = List_Create(20,20,sizeof(double)); Constant_S.Name = (yyvsp[(1) - (3)].c); if(!Tree_Query(ConstantTable_L, &Constant_S)) vyyerror("Unknown Constant: %s", (yyvsp[(1) - (3)].c)); else if(Constant_S.Type != VAR_LISTOFFLOAT) /* vyyerror("Multi value Constant needed: %s", $1); */ List_Add((yyval.l), &Constant_S.Value.Float); else for(int i = 0; i < List_Nbr(Constant_S.Value.ListOfFloat); i++) { double d; List_Read(Constant_S.Value.ListOfFloat, i, &d); List_Add((yyval.l), &d); } ;} break; case 810: #line 7423 "ProParser.y" { (yyval.l) = List_Create(20,20,sizeof(double)); Constant_S.Name = (yyvsp[(1) - (6)].c); if(!Tree_Query(ConstantTable_L, &Constant_S)) vyyerror("Unknown Constant: %s", (yyvsp[(1) - (6)].c)); else if(Constant_S.Type != VAR_LISTOFFLOAT) vyyerror("Multi value Constant needed: %s", (yyvsp[(1) - (6)].c)); else for(int i = 0; i < List_Nbr((yyvsp[(4) - (6)].l)); i++) { int j = (int)(*(double*)List_Pointer((yyvsp[(4) - (6)].l), i)); if(j >= 0 && j < List_Nbr(Constant_S.Value.ListOfFloat)){ double d; List_Read(Constant_S.Value.ListOfFloat, j, &d); List_Add((yyval.l), &d); } else{ vyyerror("Index %d out of range", j); double d = 0.; List_Add((yyval.l), &d); } } Free((yyvsp[(4) - (6)].l)); ;} break; case 811: #line 7450 "ProParser.y" { (yyval.l) = List_Create(20,20,sizeof(double)); Constant_S.Name = (yyvsp[(3) - (4)].c); if(!Tree_Query(ConstantTable_L, &Constant_S)) vyyerror("Unknown Constant: %s", (yyvsp[(3) - (4)].c)); else if(Constant_S.Type != VAR_LISTOFFLOAT) vyyerror("Multi value Constant needed: %s", (yyvsp[(3) - (4)].c)); else for(int i = 0; i < List_Nbr(Constant_S.Value.ListOfFloat); i++) { double d; List_Read(Constant_S.Value.ListOfFloat, i, &d); List_Add((yyval.l), &d); } ;} break; case 812: #line 7467 "ProParser.y" { (yyval.l) = List_Create(20,20,sizeof(double)); Constant1_S.Name = (yyvsp[(3) - (6)].c); Constant2_S.Name = (yyvsp[(5) - (6)].c); if(!Tree_Query(ConstantTable_L, &Constant1_S)) { vyyerror("Unknown Constant: %s", (yyvsp[(3) - (6)].c)); } else if(Constant1_S.Type != VAR_LISTOFFLOAT) { vyyerror("Multi value Constant needed: %s", (yyvsp[(3) - (6)].c)); } else { if(!Tree_Query(ConstantTable_L, &Constant2_S)) { vyyerror("Unknown Constant: %s", (yyvsp[(5) - (6)].c)); } else if(Constant2_S.Type != VAR_LISTOFFLOAT) { vyyerror("Multi value Constant needed: %s", (yyvsp[(5) - (6)].c)); } else { if(List_Nbr(Constant1_S.Value.ListOfFloat) != List_Nbr(Constant2_S.Value.ListOfFloat)) { vyyerror("Different dimensions of Multi value Constants: " "%s {%d}, %s {%d}", (yyvsp[(3) - (6)].c), List_Nbr(Constant1_S.Value.ListOfFloat), (yyvsp[(5) - (6)].c), List_Nbr(Constant2_S.Value.ListOfFloat)); } else { for(int i = 0; i < List_Nbr(Constant1_S.Value.ListOfFloat); i++) { double d; List_Read(Constant1_S.Value.ListOfFloat, i, &d); List_Add((yyval.l), &d); List_Read(Constant2_S.Value.ListOfFloat, i, &d); List_Add((yyval.l), &d); } } } } ;} break; case 813: #line 7507 "ProParser.y" { (yyval.l) = List_Create(20,20,sizeof(double)); for(int i = 0; i < (int)(yyvsp[(7) - (8)].d); i++) { double d = (yyvsp[(3) - (8)].d) + ((yyvsp[(5) - (8)].d)-(yyvsp[(3) - (8)].d))*(double)i/((yyvsp[(7) - (8)].d)-1); List_Add((yyval.l), &d); } ;} break; case 814: #line 7516 "ProParser.y" { (yyval.l) = List_Create(20,20,sizeof(double)); for(int i = 0; i < (int)(yyvsp[(7) - (8)].d); i++) { double d = pow(10,(yyvsp[(3) - (8)].d) + ((yyvsp[(5) - (8)].d)-(yyvsp[(3) - (8)].d))*(double)i/((yyvsp[(7) - (8)].d)-1)); List_Add((yyval.l), &d); } ;} break; case 815: #line 7529 "ProParser.y" { char tmpstr[256]; sprintf(tmpstr, "_%d", (int)(yyvsp[(4) - (5)].d)); (yyval.c) = (char *)Malloc((strlen((yyvsp[(1) - (5)].c))+strlen(tmpstr)+1)*sizeof(char)); strcpy((yyval.c), (yyvsp[(1) - (5)].c)); strcat((yyval.c), tmpstr); Free((yyvsp[(1) - (5)].c)); ;} break; case 816: #line 7538 "ProParser.y" { char tmpstr[256]; sprintf(tmpstr, "_%d", (int)(yyvsp[(4) - (5)].d)); (yyval.c) = (char *)Malloc((strlen((yyvsp[(1) - (5)].c))+strlen(tmpstr)+1)*sizeof(char)) ; strcpy((yyval.c), (yyvsp[(1) - (5)].c)) ; strcat((yyval.c), tmpstr) ; Free((yyvsp[(1) - (5)].c)); ;} break; case 817: #line 7551 "ProParser.y" { (yyval.c) = (yyvsp[(1) - (1)].c); ;} break; case 818: #line 7554 "ProParser.y" { (yyval.c) = (yyvsp[(1) - (1)].c); ;} break; case 819: #line 7561 "ProParser.y" { (yyval.l) = List_Create(20,20,sizeof(char*)); List_Add((yyval.l), &((yyvsp[(1) - (1)].c))); ;} break; case 820: #line 7567 "ProParser.y" { List_Add((yyval.l), &((yyvsp[(3) - (3)].c))); ;} break; case 821: #line 7572 "ProParser.y" { (yyval.c) = (yyvsp[(1) - (1)].c); ;} break; case 822: #line 7575 "ProParser.y" { (yyval.c) = (yyvsp[(1) - (1)].c); ;} break; case 823: #line 7580 "ProParser.y" { int size = 0; for(int i = 0; i < List_Nbr((yyvsp[(3) - (4)].l)); i++) size += strlen(*(char**)List_Pointer((yyvsp[(3) - (4)].l), i)) + 1; (yyval.c) = (char*)Malloc(size * sizeof(char)); (yyval.c)[0] = '\0'; for(int i = 0; i < List_Nbr((yyvsp[(3) - (4)].l)); i++){ char *s; List_Read((yyvsp[(3) - (4)].l), i, &s); strcat((yyval.c), s); //Free(s);//FIXME if(i != List_Nbr((yyvsp[(3) - (4)].l)) - 1) strcat((yyval.c), "\n"); } List_Delete((yyvsp[(3) - (4)].l)); ;} break; case 824: #line 7598 "ProParser.y" { (yyval.c) = (yyvsp[(3) - (4)].c); ;} break; case 825: #line 7603 "ProParser.y" { (yyval.c) = (yyvsp[(3) - (4)].c); ;} break; case 826: #line 7609 "ProParser.y" { char tmpstr[256]; int i = Print_ListOfDouble((yyvsp[(3) - (6)].c),(yyvsp[(5) - (6)].l),tmpstr); if(i<0){ vyyerror("Too few arguments in Sprintf"); (yyval.c) = (yyvsp[(3) - (6)].c); } else if(i>0){ vyyerror("Too many arguments (%d) in Sprintf", i); (yyval.c) = (yyvsp[(3) - (6)].c); } else{ (yyval.c) = (char*)Malloc((strlen(tmpstr)+1)*sizeof(char)); strcpy((yyval.c), tmpstr); Free((yyvsp[(3) - (6)].c)); } List_Delete((yyvsp[(5) - (6)].l)); ;} break; case 827: #line 7629 "ProParser.y" { char tmpstr[256]; int i = Print_ListOfDouble((yyvsp[(3) - (6)].c),(yyvsp[(5) - (6)].l),tmpstr); if(i<0){ vyyerror("Too few arguments in Sprintf"); (yyval.c) = (yyvsp[(3) - (6)].c); } else if(i>0){ vyyerror("Too many arguments (%d) in Sprintf", i); (yyval.c) = (yyvsp[(3) - (6)].c); } else{ (yyval.c) = (char*)Malloc((strlen(tmpstr)+1)*sizeof(char)); strcpy((yyval.c), tmpstr); Free((yyvsp[(3) - (6)].c)); } List_Delete((yyvsp[(5) - (6)].l)); ;} break; case 828: #line 7649 "ProParser.y" { time_t date_info; time(&date_info); (yyval.c) = (char *)Malloc((strlen(ctime(&date_info))+1)*sizeof(char)); strcpy((yyval.c), ctime(&date_info)); (yyval.c)[strlen((yyval.c))-1] = 0; ;} break; case 829: #line 7661 "ProParser.y" { (yyval.c) = (yyvsp[(1) - (1)].c); ;} break; case 830: #line 7664 "ProParser.y" { Constant_S.Name = (yyvsp[(1) - (1)].c); if(!Tree_Query(ConstantTable_L, &Constant_S)) { vyyerror("Unknown Constant: %s", (yyvsp[(1) - (1)].c)); (yyval.c) = NULL; } else { if(Constant_S.Type == VAR_CHAR) (yyval.c) = Constant_S.Value.Char; else { vyyerror("String Constant needed: %s", (yyvsp[(1) - (1)].c)); (yyval.c) = NULL; } } Free((yyvsp[(1) - (1)].c)); ;} break; case 831: #line 7683 "ProParser.y" { (yyval.l) = List_Create(20,20,sizeof(char*)); List_Add((yyval.l), &((yyvsp[(1) - (1)].c))); ;} break; case 832: #line 7688 "ProParser.y" { List_Add((yyval.l), &((yyvsp[(3) - (3)].c))); ;} break; case 833: #line 7694 "ProParser.y" { if((yyvsp[(3) - (6)].c) != NULL && (yyvsp[(5) - (6)].c) != NULL) { (yyval.c) = (char *)Malloc((strlen((yyvsp[(3) - (6)].c))+strlen((yyvsp[(5) - (6)].c))+1)*sizeof(char)); strcpy((yyval.c), (yyvsp[(3) - (6)].c)); strcat((yyval.c), (yyvsp[(5) - (6)].c)); } else { vyyerror("Undefined argument for StrCat function"); (yyval.c) = NULL; } ;} break; case 834: #line 7704 "ProParser.y" { if((yyvsp[(3) - (6)].c) != NULL && (yyvsp[(5) - (6)].c) != NULL) { (yyval.c) = (char *)Malloc((strlen((yyvsp[(3) - (6)].c))+strlen((yyvsp[(5) - (6)].c))+1)*sizeof(char)); strcpy((yyval.c), (yyvsp[(3) - (6)].c)); strcat((yyval.c), (yyvsp[(5) - (6)].c)); } else { vyyerror("Undefined argument for StrCat function"); (yyval.c) = NULL; } ;} break; case 835: #line 7718 "ProParser.y" { if ((yyvsp[(3) - (6)].c) != NULL && (yyvsp[(5) - (6)].c) != NULL) { (yyval.i) = strcmp((yyvsp[(3) - (6)].c), (yyvsp[(5) - (6)].c)); } else { vyyerror("Undefined argument for StrCmp function") ; (yyval.i) = 1 ; } ;} break; case 836: #line 7731 "ProParser.y" { int i; if ( (i = List_ISearchSeq(Problem_S.Group, (yyvsp[(3) - (4)].c), fcmp_Group_Name)) >= 0 ) { (yyval.i) = List_Nbr(((struct Group *)List_Pointer(Problem_S.Group, i)) ->InitialList) ; } else { vyyerror("Unknown Group: %s", (yyvsp[(3) - (4)].c)) ; (yyval.i) = 0 ; } ;} break; /* Line 1267 of yacc.c. */ #line 14110 "ProParser.tab.cpp" default: break; } YY_SYMBOL_PRINT ("-> $$ =", yyr1[yyn], &yyval, &yyloc); YYPOPSTACK (yylen); yylen = 0; YY_STACK_PRINT (yyss, yyssp); *++yyvsp = yyval; /* Now `shift' the result of the reduction. Determine what state that goes to, based on the state we popped back to and the rule number reduced by. */ yyn = yyr1[yyn]; yystate = yypgoto[yyn - YYNTOKENS] + *yyssp; if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == *yyssp) yystate = yytable[yystate]; else yystate = yydefgoto[yyn - YYNTOKENS]; goto yynewstate; /*------------------------------------. | yyerrlab -- here on detecting error | `------------------------------------*/ yyerrlab: /* If not already recovering from an error, report this error. */ if (!yyerrstatus) { ++yynerrs; #if ! YYERROR_VERBOSE yyerror (YY_("syntax error")); #else { YYSIZE_T yysize = yysyntax_error (0, yystate, yychar); if (yymsg_alloc < yysize && yymsg_alloc < YYSTACK_ALLOC_MAXIMUM) { YYSIZE_T yyalloc = 2 * yysize; if (! (yysize <= yyalloc && yyalloc <= YYSTACK_ALLOC_MAXIMUM)) yyalloc = YYSTACK_ALLOC_MAXIMUM; if (yymsg != yymsgbuf) YYSTACK_FREE (yymsg); yymsg = (char *) YYSTACK_ALLOC (yyalloc); if (yymsg) yymsg_alloc = yyalloc; else { yymsg = yymsgbuf; yymsg_alloc = sizeof yymsgbuf; } } if (0 < yysize && yysize <= yymsg_alloc) { (void) yysyntax_error (yymsg, yystate, yychar); yyerror (yymsg); } else { yyerror (YY_("syntax error")); if (yysize != 0) goto yyexhaustedlab; } } #endif } if (yyerrstatus == 3) { /* If just tried and failed to reuse look-ahead token after an error, discard it. */ if (yychar <= YYEOF) { /* Return failure if at end of input. */ if (yychar == YYEOF) YYABORT; } else { yydestruct ("Error: discarding", yytoken, &yylval); yychar = YYEMPTY; } } /* Else will try to reuse look-ahead token after shifting the error token. */ goto yyerrlab1; /*---------------------------------------------------. | yyerrorlab -- error raised explicitly by YYERROR. | `---------------------------------------------------*/ yyerrorlab: /* Pacify compilers like GCC when the user code never invokes YYERROR and the label yyerrorlab therefore never appears in user code. */ if (/*CONSTCOND*/ 0) goto yyerrorlab; /* Do not reclaim the symbols of the rule which action triggered this YYERROR. */ YYPOPSTACK (yylen); yylen = 0; YY_STACK_PRINT (yyss, yyssp); yystate = *yyssp; goto yyerrlab1; /*-------------------------------------------------------------. | yyerrlab1 -- common code for both syntax error and YYERROR. | `-------------------------------------------------------------*/ yyerrlab1: yyerrstatus = 3; /* Each real token shifted decrements this. */ for (;;) { yyn = yypact[yystate]; if (yyn != YYPACT_NINF) { yyn += YYTERROR; if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) { yyn = yytable[yyn]; if (0 < yyn) break; } } /* Pop the current state because it cannot handle the error token. */ if (yyssp == yyss) YYABORT; yydestruct ("Error: popping", yystos[yystate], yyvsp); YYPOPSTACK (1); yystate = *yyssp; YY_STACK_PRINT (yyss, yyssp); } if (yyn == YYFINAL) YYACCEPT; *++yyvsp = yylval; /* Shift the error token. */ YY_SYMBOL_PRINT ("Shifting", yystos[yyn], yyvsp, yylsp); yystate = yyn; goto yynewstate; /*-------------------------------------. | yyacceptlab -- YYACCEPT comes here. | `-------------------------------------*/ yyacceptlab: yyresult = 0; goto yyreturn; /*-----------------------------------. | yyabortlab -- YYABORT comes here. | `-----------------------------------*/ yyabortlab: yyresult = 1; goto yyreturn; #ifndef yyoverflow /*-------------------------------------------------. | yyexhaustedlab -- memory exhaustion comes here. | `-------------------------------------------------*/ yyexhaustedlab: yyerror (YY_("memory exhausted")); yyresult = 2; /* Fall through. */ #endif yyreturn: if (yychar != YYEOF && yychar != YYEMPTY) yydestruct ("Cleanup: discarding lookahead", yytoken, &yylval); /* Do not reclaim the symbols of the rule which action triggered this YYABORT or YYACCEPT. */ YYPOPSTACK (yylen); YY_STACK_PRINT (yyss, yyssp); while (yyssp != yyss) { yydestruct ("Cleanup: popping", yystos[*yyssp], yyvsp); YYPOPSTACK (1); } #ifndef yyoverflow if (yyss != yyssa) YYSTACK_FREE (yyss); #endif #if YYERROR_VERBOSE if (yymsg != yymsgbuf) YYSTACK_FREE (yymsg); #endif /* Make sure YYID is used. */ return YYID (yyresult); } #line 7743 "ProParser.y" // This is a hack... Bison redefines 'const' if !__cplusplus and !__STDC__ #ifdef const #undef const #endif void Alloc_ParserVariables() { if(!ConstantTable_L) { ConstantTable_L = Tree_Create(sizeof(struct Constant), fcmp_Constant); for(std::map::iterator it = CommandLineNumbers.begin(); it != CommandLineNumbers.end(); it++){ Message::Info("Adding number %s = %g", it->first.c_str(), it->second); Constant_S.Name = strdup(it->first.c_str()); Constant_S.Type = VAR_FLOAT; Constant_S.Value.Float = it->second; Tree_Add(ConstantTable_L, &Constant_S); } for(std::map::iterator it = CommandLineStrings.begin(); it != CommandLineStrings.end(); it++){ Message::Info("Adding string %s = \"%s\"", it->first.c_str(), it->second.c_str()); Constant_S.Name = strdup(it->first.c_str()); Constant_S.Type = VAR_CHAR; Constant_S.Value.Char = strdup(it->second.c_str()); Tree_Add(ConstantTable_L, &Constant_S); } ListOfInt_L = List_Create(20, 10, sizeof(int)); ListOfPointer_L = List_Create(10, 10, sizeof(void *)); ListOfPointer2_L= List_Create(10, 10, sizeof(void *)); ListOfChar_L = List_Create(128, 128, sizeof(char)); ListOfFormulation = List_Create(5,5, sizeof(int)); ListOfBasisFunction = List_Create(5,5, sizeof(List_T *)); ListOfEntityIndex = List_Create(5,5, sizeof(int)); } } void Free_ParserVariables() { Tree_Delete(ConstantTable_L); ConstantTable_L = 0; List_Delete(ListOfInt_L); ListOfInt_L = 0; List_Delete(ListOfPointer_L); ListOfPointer_L = 0; List_Delete(ListOfPointer2_L); ListOfPointer2_L = 0; List_Delete(ListOfChar_L); ListOfChar_L = 0; List_Delete(ListOfFormulation); ListOfFormulation = 0; List_Delete(ListOfBasisFunction); ListOfBasisFunction = 0; List_Delete(ListOfEntityIndex); ListOfEntityIndex = 0; strcpy(getdp_yyname, ""); strcpy(getdp_yyincludename, ""); getdp_yylinenum = 0; getdp_yycolnum = 0; getdp_yyincludenum = 0; getdp_yyerrorlevel = 0; CommandLineNumbers.clear(); CommandLineStrings.clear(); } /* A d d _ G r o u p & C o . */ int Add_Group(struct Group *Group_P, char *Name, bool Flag_Add, int Flag_Plus, int Num_Index) { if(!Problem_S.Group) Problem_S.Group = List_Create(50, 50, sizeof (struct Group)); char tmpstr[256]; switch (Flag_Plus) { case 1 : sprintf(tmpstr, "_%s_%d", Name, List_Nbr(Problem_S.Group)); Group_P->Name = strSave(tmpstr); break; case 2 : sprintf(tmpstr, "%s_%d", Name, Num_Index); Group_P->Name = strSave(tmpstr); break; default : Group_P->Name = Name; } int i; if((i = List_ISearchSeq(Problem_S.Group, Group_P->Name, fcmp_Group_Name)) < 0) { i = Group_P->Num = List_Nbr(Problem_S.Group); Group_P->ExtendedList = NULL; Group_P->ExtendedSuppList = NULL; List_Add(Problem_S.Group, Group_P); } else if(Flag_Add) { List_T *InitialList = ((struct Group *)List_Pointer(Problem_S.Group, i))->InitialList; for(int j = 0; j < List_Nbr(Group_P->InitialList); j++) { List_Add(InitialList, (int *)List_Pointer(Group_P->InitialList, j)); } } else List_Write(Problem_S.Group, i, Group_P); return i; } int Num_Group(struct Group *Group_P, char *Name, int Num_Group) { if (Num_Group >= 0) /* OK */; else if(Num_Group == -1) Num_Group = Add_Group(Group_P, Name, false, 1, 0); else vyyerror("Bad Group right hand side"); return Num_Group; } void Fill_GroupInitialListFromString(List_T *list, const char *str) { bool found = false; // try to find a group with name "str" for(int i = 0; i < List_Nbr(Problem_S.Group); i++){ struct Group *Group_P = (struct Group*)List_Pointer(Problem_S.Group, i); if(!strcmp(str, Group_P->Name)){ List_Copy(Group_P->InitialList, list); found = true; break; } } // try to find a constant with name "str" Constant_S.Name = (char*)str; Constant *Constant_P = (Constant*)Tree_PQuery(ConstantTable_L, &Constant_S); if(Constant_P){ switch(Constant_P->Type){ case VAR_FLOAT: { int num = (int)Constant_P->Value.Float; List_Add(list, &num); } found = true; break; case VAR_LISTOFFLOAT: for(int j = 0; j < List_Nbr(Constant_P->Value.ListOfFloat); j++){ double d; List_Read(Constant_P->Value.ListOfFloat, j, &d); int num = (int)d; List_Add(list, &num); } found = true; break; } } // if not, try to convert "str" to an integer if(!found){ int num = atoi(str); if(num > 0){ List_Add(list, &num); found = true; } } if(!found) vyyerror("Unknown Group '%s'", str); } /* A d d _ E x p r e s s i o n */ int Add_Expression(struct Expression *Expression_P, char *Name, int Flag_Plus) { if(!Problem_S.Expression) Problem_S.Expression = List_Create(50, 50, sizeof (struct Expression)); switch (Flag_Plus) { case 1 : char tmpstr[256]; sprintf(tmpstr, "_%s_%d", Name, List_Nbr(Problem_S.Expression)) ; Expression_P->Name = strSave(tmpstr) ; break ; case 2 : Expression_P->Name = strSave(Name) ; break ; default : Expression_P->Name = Name ; } int i; if((i = List_ISearchSeq (Problem_S.Expression, Name, fcmp_Expression_Name)) < 0) { i = List_Nbr(Problem_S.Expression); List_Add(Problem_S.Expression, Expression_P); } else List_Write(Problem_S.Expression, i, Expression_P); return i; } bool Is_ExpressionPieceWiseDefined(int index) { struct Expression *e = (struct Expression *)List_Pointer(Problem_S.Expression, index); if(e->Type == PIECEWISEFUNCTION) return true; else if(e->Type == WHOLEQUANTITY){ for(int i = 0; i < List_Nbr(e->Case.WholeQuantity); i++){ struct WholeQuantity *w = (struct WholeQuantity *)List_Pointer(e->Case.WholeQuantity, i); if(w->Type == WQ_EXPRESSION) return Is_ExpressionPieceWiseDefined(w->Case.Expression.Index); } } return false; } /* L i s t e I n d e x d e s D e f i n e Q u a n t i t y */ void Pro_DefineQuantityIndex_1(List_T *WholeQuantity_L, int TraceGroupIndex, std::vector > &pairs) { struct WholeQuantity *WholeQuantity_P; WholeQuantity_P = (List_Nbr(WholeQuantity_L) > 0)? (struct WholeQuantity*)List_Pointer(WholeQuantity_L, 0) : NULL; for(int i = 0; i < List_Nbr(WholeQuantity_L); i++) switch ((WholeQuantity_P+i)->Type) { case WQ_OPERATORANDQUANTITY : case WQ_OPERATORANDQUANTITYEVAL : case WQ_SOLIDANGLE : case WQ_ORDER : { std::pair p((WholeQuantity_P+i)->Case.OperatorAndQuantity.Index, TraceGroupIndex); if(std::find(pairs.begin(), pairs.end(), p) == pairs.end()) pairs.push_back(p); } break; case WQ_MHTRANSFORM : Pro_DefineQuantityIndex_1 ((WholeQuantity_P+i)->Case.MHTransform.WholeQuantity, TraceGroupIndex, pairs); case WQ_TIMEDERIVATIVE : Pro_DefineQuantityIndex_1 ((WholeQuantity_P+i)->Case.TimeDerivative.WholeQuantity, TraceGroupIndex, pairs); break; case WQ_ATANTERIORTIMESTEP : Pro_DefineQuantityIndex_1 ((WholeQuantity_P+i)->Case.AtAnteriorTimeStep.WholeQuantity, TraceGroupIndex, pairs); break; case WQ_CAST : Pro_DefineQuantityIndex_1 ((WholeQuantity_P+i)->Case.Cast.WholeQuantity, TraceGroupIndex, pairs); break; case WQ_TRACE : Pro_DefineQuantityIndex_1 ((WholeQuantity_P+i)->Case.Trace.WholeQuantity, (WholeQuantity_P+i)->Case.Trace.InIndex, pairs); break; case WQ_TEST : Pro_DefineQuantityIndex_1 ((WholeQuantity_P+i)->Case.Test.WholeQuantity_True, TraceGroupIndex, pairs); Pro_DefineQuantityIndex_1 ((WholeQuantity_P+i)->Case.Test.WholeQuantity_False, TraceGroupIndex, pairs); break; } std::sort(pairs.begin(), pairs.end()); } void Pro_DefineQuantityIndex(List_T *WholeQuantity_L, int DefineQuantityIndexEqu, int *NbrQuantityIndex, int **QuantityIndexTable, int **QuantityTraceGroupIndexTable) { std::vector > pairs; /* special case for the Equ part (right of the comma) FIXME: change this when we allow a full WholeQuantity expression there */ Pro_DefineQuantityIndex_1(WholeQuantity_L, -1, pairs); if(DefineQuantityIndexEqu >= 0){ std::pair p(DefineQuantityIndexEqu, -1); pairs.push_back(p); } *NbrQuantityIndex = pairs.size(); *QuantityIndexTable = (int *)Malloc(pairs.size() * sizeof(int)); *QuantityTraceGroupIndexTable = (int *)Malloc(pairs.size() * sizeof(int)); for(unsigned int i = 0; i < pairs.size(); i++){ (*QuantityIndexTable)[i] = pairs[i].first; (*QuantityTraceGroupIndexTable)[i] = pairs[i].second; } } /* C h e c k _ N a m e O f S t r u c t N o t E x i s t */ void Check_NameOfStructNotExist(const char *Struct, List_T *List_L, void *data, int (*fcmp)(const void *a, const void *b)) { if(List_ISearchSeq(List_L, data, fcmp) >= 0) vyyerror("Redefinition of %s %s", Struct, (char*)data); } /* P r i n t _ C o n s t a n t */ int Print_ListOfDouble(char *format, List_T *list, char *buffer) { char tmp1[256], tmp2[256]; int j = 0; while(format[j] != '%') j++; strncpy(buffer, format, j); buffer[j] = '\0'; for(int i = 0; i < List_Nbr(list); i++){ int k = j; j++; if(j < (int)strlen(format)){ if(format[j] == '%'){ strcat(buffer, "%"); j++; } while(format[j] != '%' && j < (int)strlen(format)) j++; if(k != j){ strncpy(tmp1, &(format[k]),j-k); tmp1[j-k] = '\0'; sprintf(tmp2, tmp1, *(double*)List_Pointer(list,i)); strcat(buffer, tmp2); } } else{ return List_Nbr(list) - i; break; } } if(j != (int)strlen(format)) return -1; return 0; } void Print_Constants() { struct Constant *Constant_P; Message::Check("Constants:\n"); List_T *tmp = Tree2List(ConstantTable_L); for(int i = 0; i < List_Nbr(tmp); i++){ Constant_P = (struct Constant*)List_Pointer(tmp, i); switch(Constant_P->Type){ case VAR_FLOAT: Message::Check("%s = %g;\n", Constant_P->Name, Constant_P->Value.Float); break; case VAR_LISTOFFLOAT: { std::string str(Constant_P->Name); str += " = {"; for(int j = 0; j < List_Nbr(Constant_P->Value.ListOfFloat); j++){ if(j) str += ","; double d; List_Read(Constant_P->Value.ListOfFloat, j, &d); char tmp[32]; sprintf(tmp, "%g", d); str += tmp; } str += "};\n"; Message::Check(str.c_str()); } break; case VAR_CHAR: Message::Check("%s = \"%s\";\n", Constant_P->Name, Constant_P->Value.Char); break; } } List_Delete(tmp); } /* E r r o r h a n d l i n g */ void yyerror(const char *s) { extern char *getdp_yytext; Message::Error("'%s', line %ld : %s (%s)", getdp_yyname, getdp_yylinenum, s, getdp_yytext); getdp_yyerrorlevel = 1; } void vyyerror(const char *fmt, ...) { char str[256]; va_list args; va_start(args, fmt); vsprintf(str, fmt, args); va_end(args); Message::Error("'%s', line %ld : %s", getdp_yyname, getdp_yylinenum, str); getdp_yyerrorlevel = 1; } getdp-2.4.2-source/Interface/ProParser.tab.hpp000644 001750 001750 00000035717 12221300353 022677 0ustar00geuzainegeuzaine000000 000000 /* A Bison parser, made by GNU Bison 2.3. */ /* Skeleton interface for Bison's Yacc-like parsers in C Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ /* As a special exception, you may create a larger work that contains part or all of the Bison parser skeleton and distribute that work under terms of your choice, so long as that work isn't itself a parser generator using the skeleton or a modified version thereof as a parser skeleton. Alternatively, if you modify or redistribute the parser skeleton itself, you may (at your option) remove this special exception, which will cause the skeleton and the resulting Bison output files to be licensed under the GNU General Public License without this special exception. This special exception was added by the Free Software Foundation in version 2.2 of Bison. */ /* Tokens. */ #ifndef YYTOKENTYPE # define YYTOKENTYPE /* Put the tokens into the symbol table, so that GDB and other debuggers know about them. */ enum yytokentype { tINT = 258, tFLOAT = 259, tSTRING = 260, tBIGSTR = 261, tEND = 262, tDOTS = 263, tStrCat = 264, tSprintf = 265, tPrintf = 266, tRead = 267, tPrintConstants = 268, tStrCmp = 269, tNbrRegions = 270, tFor = 271, tEndFor = 272, tIf = 273, tElse = 274, tEndIf = 275, tFlag = 276, tInclude = 277, tConstant = 278, tList = 279, tListAlt = 280, tLinSpace = 281, tLogSpace = 282, tListFromFile = 283, tChangeCurrentPosition = 284, tDefineConstant = 285, tUndefineConstant = 286, tPi = 287, tMPI_Rank = 288, tMPI_Size = 289, t0D = 290, t1D = 291, t2D = 292, t3D = 293, tExp = 294, tLog = 295, tLog10 = 296, tSqrt = 297, tSin = 298, tAsin = 299, tCos = 300, tAcos = 301, tTan = 302, tAtan = 303, tAtan2 = 304, tSinh = 305, tCosh = 306, tTanh = 307, tFabs = 308, tFloor = 309, tCeil = 310, tRound = 311, tSign = 312, tFmod = 313, tModulo = 314, tHypot = 315, tRand = 316, tSolidAngle = 317, tTrace = 318, tOrder = 319, tCrossProduct = 320, tDofValue = 321, tMHTransform = 322, tMHJacNL = 323, tGroup = 324, tDefineGroup = 325, tAll = 326, tInSupport = 327, tMovingBand2D = 328, tDefineFunction = 329, tConstraint = 330, tRegion = 331, tSubRegion = 332, tRegionRef = 333, tSubRegionRef = 334, tFilter = 335, tCoefficient = 336, tValue = 337, tTimeFunction = 338, tBranch = 339, tNameOfResolution = 340, tJacobian = 341, tCase = 342, tMetricTensor = 343, tIntegration = 344, tMatrix = 345, tType = 346, tSubType = 347, tCriterion = 348, tGeoElement = 349, tNumberOfPoints = 350, tMaxNumberOfPoints = 351, tNumberOfDivisions = 352, tMaxNumberOfDivisions = 353, tStoppingCriterion = 354, tFunctionSpace = 355, tName = 356, tBasisFunction = 357, tNameOfCoef = 358, tFunction = 359, tdFunction = 360, tSubFunction = 361, tSubdFunction = 362, tSupport = 363, tEntity = 364, tSubSpace = 365, tNameOfBasisFunction = 366, tGlobalQuantity = 367, tEntityType = 368, tEntitySubType = 369, tNameOfConstraint = 370, tFormulation = 371, tQuantity = 372, tNameOfSpace = 373, tIndexOfSystem = 374, tSymmetry = 375, tGalerkin = 376, tdeRham = 377, tGlobalTerm = 378, tGlobalEquation = 379, tDt = 380, tDtDof = 381, tDtDt = 382, tDtDtDof = 383, tJacNL = 384, tDtDofJacNL = 385, tNeverDt = 386, tDtNL = 387, tAtAnteriorTimeStep = 388, tIn = 389, tFull_Matrix = 390, tResolution = 391, tDefineSystem = 392, tNameOfFormulation = 393, tNameOfMesh = 394, tFrequency = 395, tSolver = 396, tOriginSystem = 397, tDestinationSystem = 398, tOperation = 399, tOperationEnd = 400, tSetTime = 401, tDTime = 402, tSetFrequency = 403, tFourierTransform = 404, tFourierTransformJ = 405, tLanczos = 406, tEigenSolve = 407, tEigenSolveJac = 408, tPerturbation = 409, tUpdate = 410, tUpdateConstraint = 411, tBreak = 412, tEvaluate = 413, tSelectCorrection = 414, tAddCorrection = 415, tMultiplySolution = 416, tAddOppositeFullSolution = 417, tSolveAgainWithOther = 418, tTimeLoopTheta = 419, tTimeLoopNewmark = 420, tTimeLoopRungeKutta = 421, tTimeLoopAdaptive = 422, tTime0 = 423, tTimeMax = 424, tTheta = 425, tBeta = 426, tGamma = 427, tIterativeLoop = 428, tIterativeLoopN = 429, tIterativeLinearSolver = 430, tNbrMaxIteration = 431, tRelaxationFactor = 432, tIterativeTimeReduction = 433, tSetCommSelf = 434, tSetCommWorld = 435, tBarrier = 436, tDivisionCoefficient = 437, tChangeOfState = 438, tChangeOfCoordinates = 439, tChangeOfCoordinates2 = 440, tSystemCommand = 441, tGmshRead = 442, tGmshClearAll = 443, tDeleteFile = 444, tCreateDir = 445, tGenerateOnly = 446, tGenerateOnlyJac = 447, tSolveJac_AdaptRelax = 448, tTensorProductSolve = 449, tSaveSolutionExtendedMH = 450, tSaveSolutionMHtoTime = 451, tSaveSolutionWithEntityNum = 452, tInitMovingBand2D = 453, tMeshMovingBand2D = 454, tGenerate_MH_Moving = 455, tGenerate_MH_Moving_Separate = 456, tAdd_MH_Moving = 457, tGenerateGroup = 458, tGenerateJacGroup = 459, tGenerateRHSGroup = 460, tSaveMesh = 461, tDeformeMesh = 462, tDummyFrequency = 463, tPostProcessing = 464, tNameOfSystem = 465, tPostOperation = 466, tNameOfPostProcessing = 467, tUsingPost = 468, tAppend = 469, tResampleTime = 470, tPlot = 471, tPrint = 472, tPrintGroup = 473, tEcho = 474, tWrite = 475, tAdapt = 476, tOnGlobal = 477, tOnRegion = 478, tOnElementsOf = 479, tOnGrid = 480, tOnSection = 481, tOnPoint = 482, tOnLine = 483, tOnPlane = 484, tOnBox = 485, tWithArgument = 486, tFile = 487, tDepth = 488, tDimension = 489, tComma = 490, tTimeStep = 491, tHarmonicToTime = 492, tValueIndex = 493, tValueName = 494, tFormat = 495, tHeader = 496, tFooter = 497, tSkin = 498, tSmoothing = 499, tTarget = 500, tSort = 501, tIso = 502, tNoNewLine = 503, tNoTitle = 504, tDecomposeInSimplex = 505, tChangeOfValues = 506, tTimeLegend = 507, tFrequencyLegend = 508, tEigenvalueLegend = 509, tEvaluationPoints = 510, tStoreInRegister = 511, tStoreInField = 512, tLastTimeStepOnly = 513, tAppendTimeStepToFileName = 514, tOverrideTimeStepValue = 515, tNoMesh = 516, tSendToServer = 517, tColor = 518, tStr = 519, tDate = 520, tNewCoordinates = 521, tDEF = 522, tOR = 523, tAND = 524, tAPPROXEQUAL = 525, tNOTEQUAL = 526, tEQUAL = 527, tGREATERGREATER = 528, tLESSLESS = 529, tGREATEROREQUAL = 530, tLESSOREQUAL = 531, tCROSSPRODUCT = 532, UNARYPREC = 533, tSHOW = 534 }; #endif /* Tokens. */ #define tINT 258 #define tFLOAT 259 #define tSTRING 260 #define tBIGSTR 261 #define tEND 262 #define tDOTS 263 #define tStrCat 264 #define tSprintf 265 #define tPrintf 266 #define tRead 267 #define tPrintConstants 268 #define tStrCmp 269 #define tNbrRegions 270 #define tFor 271 #define tEndFor 272 #define tIf 273 #define tElse 274 #define tEndIf 275 #define tFlag 276 #define tInclude 277 #define tConstant 278 #define tList 279 #define tListAlt 280 #define tLinSpace 281 #define tLogSpace 282 #define tListFromFile 283 #define tChangeCurrentPosition 284 #define tDefineConstant 285 #define tUndefineConstant 286 #define tPi 287 #define tMPI_Rank 288 #define tMPI_Size 289 #define t0D 290 #define t1D 291 #define t2D 292 #define t3D 293 #define tExp 294 #define tLog 295 #define tLog10 296 #define tSqrt 297 #define tSin 298 #define tAsin 299 #define tCos 300 #define tAcos 301 #define tTan 302 #define tAtan 303 #define tAtan2 304 #define tSinh 305 #define tCosh 306 #define tTanh 307 #define tFabs 308 #define tFloor 309 #define tCeil 310 #define tRound 311 #define tSign 312 #define tFmod 313 #define tModulo 314 #define tHypot 315 #define tRand 316 #define tSolidAngle 317 #define tTrace 318 #define tOrder 319 #define tCrossProduct 320 #define tDofValue 321 #define tMHTransform 322 #define tMHJacNL 323 #define tGroup 324 #define tDefineGroup 325 #define tAll 326 #define tInSupport 327 #define tMovingBand2D 328 #define tDefineFunction 329 #define tConstraint 330 #define tRegion 331 #define tSubRegion 332 #define tRegionRef 333 #define tSubRegionRef 334 #define tFilter 335 #define tCoefficient 336 #define tValue 337 #define tTimeFunction 338 #define tBranch 339 #define tNameOfResolution 340 #define tJacobian 341 #define tCase 342 #define tMetricTensor 343 #define tIntegration 344 #define tMatrix 345 #define tType 346 #define tSubType 347 #define tCriterion 348 #define tGeoElement 349 #define tNumberOfPoints 350 #define tMaxNumberOfPoints 351 #define tNumberOfDivisions 352 #define tMaxNumberOfDivisions 353 #define tStoppingCriterion 354 #define tFunctionSpace 355 #define tName 356 #define tBasisFunction 357 #define tNameOfCoef 358 #define tFunction 359 #define tdFunction 360 #define tSubFunction 361 #define tSubdFunction 362 #define tSupport 363 #define tEntity 364 #define tSubSpace 365 #define tNameOfBasisFunction 366 #define tGlobalQuantity 367 #define tEntityType 368 #define tEntitySubType 369 #define tNameOfConstraint 370 #define tFormulation 371 #define tQuantity 372 #define tNameOfSpace 373 #define tIndexOfSystem 374 #define tSymmetry 375 #define tGalerkin 376 #define tdeRham 377 #define tGlobalTerm 378 #define tGlobalEquation 379 #define tDt 380 #define tDtDof 381 #define tDtDt 382 #define tDtDtDof 383 #define tJacNL 384 #define tDtDofJacNL 385 #define tNeverDt 386 #define tDtNL 387 #define tAtAnteriorTimeStep 388 #define tIn 389 #define tFull_Matrix 390 #define tResolution 391 #define tDefineSystem 392 #define tNameOfFormulation 393 #define tNameOfMesh 394 #define tFrequency 395 #define tSolver 396 #define tOriginSystem 397 #define tDestinationSystem 398 #define tOperation 399 #define tOperationEnd 400 #define tSetTime 401 #define tDTime 402 #define tSetFrequency 403 #define tFourierTransform 404 #define tFourierTransformJ 405 #define tLanczos 406 #define tEigenSolve 407 #define tEigenSolveJac 408 #define tPerturbation 409 #define tUpdate 410 #define tUpdateConstraint 411 #define tBreak 412 #define tEvaluate 413 #define tSelectCorrection 414 #define tAddCorrection 415 #define tMultiplySolution 416 #define tAddOppositeFullSolution 417 #define tSolveAgainWithOther 418 #define tTimeLoopTheta 419 #define tTimeLoopNewmark 420 #define tTimeLoopRungeKutta 421 #define tTimeLoopAdaptive 422 #define tTime0 423 #define tTimeMax 424 #define tTheta 425 #define tBeta 426 #define tGamma 427 #define tIterativeLoop 428 #define tIterativeLoopN 429 #define tIterativeLinearSolver 430 #define tNbrMaxIteration 431 #define tRelaxationFactor 432 #define tIterativeTimeReduction 433 #define tSetCommSelf 434 #define tSetCommWorld 435 #define tBarrier 436 #define tDivisionCoefficient 437 #define tChangeOfState 438 #define tChangeOfCoordinates 439 #define tChangeOfCoordinates2 440 #define tSystemCommand 441 #define tGmshRead 442 #define tGmshClearAll 443 #define tDeleteFile 444 #define tCreateDir 445 #define tGenerateOnly 446 #define tGenerateOnlyJac 447 #define tSolveJac_AdaptRelax 448 #define tTensorProductSolve 449 #define tSaveSolutionExtendedMH 450 #define tSaveSolutionMHtoTime 451 #define tSaveSolutionWithEntityNum 452 #define tInitMovingBand2D 453 #define tMeshMovingBand2D 454 #define tGenerate_MH_Moving 455 #define tGenerate_MH_Moving_Separate 456 #define tAdd_MH_Moving 457 #define tGenerateGroup 458 #define tGenerateJacGroup 459 #define tGenerateRHSGroup 460 #define tSaveMesh 461 #define tDeformeMesh 462 #define tDummyFrequency 463 #define tPostProcessing 464 #define tNameOfSystem 465 #define tPostOperation 466 #define tNameOfPostProcessing 467 #define tUsingPost 468 #define tAppend 469 #define tResampleTime 470 #define tPlot 471 #define tPrint 472 #define tPrintGroup 473 #define tEcho 474 #define tWrite 475 #define tAdapt 476 #define tOnGlobal 477 #define tOnRegion 478 #define tOnElementsOf 479 #define tOnGrid 480 #define tOnSection 481 #define tOnPoint 482 #define tOnLine 483 #define tOnPlane 484 #define tOnBox 485 #define tWithArgument 486 #define tFile 487 #define tDepth 488 #define tDimension 489 #define tComma 490 #define tTimeStep 491 #define tHarmonicToTime 492 #define tValueIndex 493 #define tValueName 494 #define tFormat 495 #define tHeader 496 #define tFooter 497 #define tSkin 498 #define tSmoothing 499 #define tTarget 500 #define tSort 501 #define tIso 502 #define tNoNewLine 503 #define tNoTitle 504 #define tDecomposeInSimplex 505 #define tChangeOfValues 506 #define tTimeLegend 507 #define tFrequencyLegend 508 #define tEigenvalueLegend 509 #define tEvaluationPoints 510 #define tStoreInRegister 511 #define tStoreInField 512 #define tLastTimeStepOnly 513 #define tAppendTimeStepToFileName 514 #define tOverrideTimeStepValue 515 #define tNoMesh 516 #define tSendToServer 517 #define tColor 518 #define tStr 519 #define tDate 520 #define tNewCoordinates 521 #define tDEF 522 #define tOR 523 #define tAND 524 #define tAPPROXEQUAL 525 #define tNOTEQUAL 526 #define tEQUAL 527 #define tGREATERGREATER 528 #define tLESSLESS 529 #define tGREATEROREQUAL 530 #define tLESSOREQUAL 531 #define tCROSSPRODUCT 532 #define UNARYPREC 533 #define tSHOW 534 #if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED typedef union YYSTYPE #line 140 "ProParser.y" { char *c; int i; double d; List_T *l; struct TwoInt t; } /* Line 1529 of yacc.c. */ #line 615 "ProParser.tab.hpp" YYSTYPE; # define yystype YYSTYPE /* obsolescent; will be withdrawn */ # define YYSTYPE_IS_DECLARED 1 # define YYSTYPE_IS_TRIVIAL 1 #endif extern YYSTYPE getdp_yylval; getdp-2.4.2-source/Interface/ProParser.h000644 001750 001750 00000002221 12166744441 021574 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _PRO_PARSER_H_ #define _PRO_PARSER_H_ #include #include #include #include #include "ListUtils.h" struct Constant { char *Name; int Type; union { double Float; List_T *ListOfFloat; char *Char; } Value; }; #define VAR_FLOAT 1 #define VAR_LISTOFFLOAT 2 #define VAR_CHAR 3 extern FILE *getdp_yyin; extern char getdp_yyname[256]; extern char getdp_yyincludename[256]; extern long int getdp_yylinenum; extern int getdp_yycolnum; extern int getdp_yyincludenum; extern int getdp_yyerrorlevel; extern std::map CommandLineNumbers; extern std::map CommandLineStrings; int getdp_yyparse(); void getdp_yyrestart(FILE*); void Free_ParserVariables(); char *strSave(const char *string); void cStyleComments(); void cxxStyleComments(); void parseString(char endchar); void skipUntil(const char *skip, const char *until); void Print_Constants(); #endif getdp-2.4.2-source/Interface/ProDefines.h000644 001750 001750 00000161605 12211017577 021723 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _PRO_DEFINES_H_ #define _PRO_DEFINES_H_ #include "GetDPConfig.h" #include "ProDefine.h" #if defined(HAVE_LEGACY) #include "Gauss.h" #include "F.h" #include "BF.h" #include "GF.h" #include "Cal_Value.h" extern struct CurrentData Current; #endif struct StringXDefine Mesh_Format[] = { {"gmsh" , FORMAT_GMSH}, {"Gmsh" , FORMAT_GMSH}, {NULL , FORMAT_GMSH} } ; struct StringXDefine Field_Type[] = { {"Form0" , FORM0 }, {"Form1" , FORM1 }, {"Form2" , FORM2 }, {"Form3" , FORM3 }, {"Form0P" , FORM0P}, {"Form1P" , FORM1P}, {"Form2P" , FORM2P }, {"Form3P" , FORM3P}, {"Form0S" , FORM0S}, {"Form1S" , FORM1S}, {"Form2S" , FORM2S }, {"Form3S" , FORM3S}, {"Scalar" , SCALAR}, {"Vector" , VECTOR}, {"VectorP" , VECTORP}, {"Tensor" , TENSOR}, {"TensorSym" , TENSOR_SYM}, {"TensorDiag" , TENSOR_DIAG}, {NULL , FORM0} } ; struct StringXDefine FunctionForGroup_Type[] = { {"Region" , REGION}, {"Global" , GLOBAL}, {"NodesOf" , NODESOF}, {"EdgesOf" , EDGESOF}, {"FacetsOf" , FACETSOF}, {"VolumesOf" , VOLUMESOF}, {"ElementsOf" , ELEMENTSOF}, {"GroupsOfNodesOf" , GROUPSOFNODESOF}, {"GroupsOfEdgesOnNodesOf" , GROUPSOFEDGESONNODESOF}, {"GroupsOfEdgesOf" , GROUPSOFEDGESOF}, {"GroupsOfFacetsOf" , GROUPSOFFACETSOF}, {"EdgesOfTreeIn" , EDGESOFTREEIN}, {"FacetsOfTreeIn" , FACETSOFTREEIN}, {"DualNodesOf" , DUALNODESOF}, {"DualEdgesOf" , DUALEDGESOF}, {"DualFacetsOf" , DUALFACETSOF}, {"DualVolumesOf" , DUALVOLUMESOF}, {"BoundaryOfDualNodesOf" , BOUNDARYOFDUALNODESOF}, {"BoundaryOfDualEdgesOf" , BOUNDARYOFDUALEDGESOF}, {"BoundaryOfDualFacetsOf" , BOUNDARYOFDUALFACETSOF}, {"MovingBand2D" , MOVINGBAND2D}, {NULL , 0} } ; struct StringXDefine FunctionForGroup_SuppList[] = { {"Not" , SUPPLIST_NOT}, {"StartingOn" , SUPPLIST_STARTINGON}, {"OnOneSideOf" , SUPPLIST_ONONESIDEOF}, {"InSupport" , SUPPLIST_INSUPPORT}, {"ConnectedTo" , SUPPLIST_CONNECTEDTO}, {NULL , 0} } ; struct StringXDefine1Nbr Jacobian_Type[] = { {"Vol" , JACOBIAN_VOL , 0} , {"VolSphShell" , JACOBIAN_VOL_SPH_SHELL , -1} , {"VolRectShell" , JACOBIAN_VOL_RECT_SHELL , -1} , {"VolPlpdX" , JACOBIAN_VOL_PLPD_X , 2} , {"VolAxi" , JACOBIAN_VOL_AXI , 0} , {"VolAxiSphShell" , JACOBIAN_VOL_AXI_SPH_SHELL , -1} , {"VolAxiRectShell" , JACOBIAN_VOL_AXI_RECT_SHELL , -1} , {"VolAxiPlpdX" , JACOBIAN_VOL_AXI_PLPD_X , 2} , {"VolAxiSqu" , JACOBIAN_VOL_AXI_SQU , 0} , {"VolAxiSquSphShell" , JACOBIAN_VOL_AXI_SQU_SPH_SHELL , -1} , {"VolAxiSquRectShell", JACOBIAN_VOL_AXI_SQU_RECT_SHELL, -1} , {"Sur" , JACOBIAN_SUR , 0} , {"SurSphShell" , JACOBIAN_SUR_SPH_SHELL , -1} , {"SurRectShell" , JACOBIAN_SUR_RECT_SHELL , -1} , {"SurAxi" , JACOBIAN_SUR_AXI , 0} , {"Lin" , JACOBIAN_LIN , 0} , {NULL , JACOBIAN_VOL , 0} } ; struct StringXDefine Integration_Type[] = { {"Gauss" , GAUSS}, {"GaussLegendre" , GAUSSLEGENDRE}, {"Analytic" , ANALYTIC}, {NULL , GAUSS} } ; struct StringXDefine Integration_SubType[] = { {"Standard" , STANDARD}, {"Singular" , SINGULAR}, {"Adaptative" , ADAPTATIVE}, {NULL , STANDARD} } ; struct StringXDefine Element_Type[] = { {"Point" , POINT}, {"Line" , LINE}, {"Triangle" , TRIANGLE}, {"Quadrangle" , QUADRANGLE}, {"Tetrahedron" , TETRAHEDRON}, {"Hexahedron" , HEXAHEDRON}, {"Prism" , PRISM}, {"Pyramid" , PYRAMID}, {"Line2" , LINE_2}, {"Triangle2" , TRIANGLE_2}, {"Quadrangle2" , QUADRANGLE_2}, {"Quadrangle2_8N", QUADRANGLE_2_8N}, {NULL , TRIANGLE} } ; struct StringXDefine GlobalQuantity_Type[] = { {"AliasOf" , ALIASOF}, {"AssociatedWith" , ASSOCIATEDWITH}, {NULL , ALIASOF} } ; struct StringXDefine Constraint_Type[] = { {"Assign" , ASSIGN}, {"Init" , INIT}, {"AssignFromResolution" , ASSIGNFROMRESOLUTION}, {"InitFromResolution" , INITFROMRESOLUTION}, {"AssignLocalProjection", ASSIGN_LOCALPROJ}, {"InitLocalProjection" , INIT_LOCALPROJ}, {"Network" , NETWORK}, {"Link" , CST_LINK}, {"LinkCplx" , CST_LINKCPLX}, {NULL , ASSIGN} } ; struct StringXDefine Formulation_Type[] = { {"FemEquation" , FEMEQUATION}, {"BemEquation" , BEMEQUATION}, {"GlobalEquation" , GLOBALEQUATION}, {NULL , FEMEQUATION} } ; struct StringXDefine DefineQuantity_Type[] = { /* a supprimer */ {"LocalQuantity" , LOCALQUANTITY}, {"GlobalQuantity" , GLOBALQUANTITY}, {"IntegralQuantity" , INTEGRALQUANTITY}, {"Local" , LOCALQUANTITY}, {"Global" , GLOBALQUANTITY}, {"Integral" , INTEGRALQUANTITY}, {NULL , LOCALQUANTITY} } ; struct StringXDefine Operator_Type[] = { {"NoOp" , NOOP } , {"d" , EXTDER } , {"dInv" , EXTDERINV} , {"Grad" , GRAD } , {"GradInv" , GRADINV } , {"Curl" , CURL } , {"CurlInv" , CURLINV } , {"Rot" , CURL } , {"RotInv" , CURLINV } , {"Div" , DIV } , {"DivInv" , DIVINV } , // unused {"NSx" , NSx } , {"NSxd" , NSxEXTDER} , {"NSxGrad" , NSxGRAD } , {"NPxGrad" , NPxGRAD } , {"D1" , _D1 } , {"D2" , _D2 } , {NULL , NOOP } } ; struct StringXDefine QuantityFromFS_Type[] = { {"Dof" , QUANTITY_DOF } , {"BF" , QUANTITY_BF } , {"NoDof" , QUANTITY_NODOF } , {NULL , QUANTITY_SIMPLE } } ; struct StringXDefine DefineSystem_Type[] = { {"RealValue" , VAL_REAL}, {"Real" , VAL_REAL}, {"ComplexValue" , VAL_COMPLEX}, {"Complex" , VAL_COMPLEX}, {NULL , VAL_REAL} } ; struct StringXDefine Operation_Type[] = { {"Generate" , OPERATION_GENERATE}, {"GenerateOnly" , OPERATION_GENERATEONLY}, {"GenerateOnlyJac" , OPERATION_GENERATEONLYJAC}, {"Update" , OPERATION_UPDATE}, {"Solve" , OPERATION_SOLVE}, {"SolveAgain" , OPERATION_SOLVEAGAIN}, {"GenerateJac" , OPERATION_GENERATEJAC}, {"SolveJac" , OPERATION_SOLVEJAC}, {"SolveJacAgain" , OPERATION_SOLVEJACAGAIN}, {"GenerateRHS" , OPERATION_GENERATERHS}, {"SolveNL" , OPERATION_SOLVENL}, {"GenerateSeparate" , OPERATION_GENERATESEPARATE}, {"InitSolution" , OPERATION_INITSOLUTION}, {"InitSolution1" , OPERATION_INITSOLUTION1}, {"SaveSolution" , OPERATION_SAVESOLUTION}, {"SaveSolutions" , OPERATION_SAVESOLUTIONS}, {"ReadSolution" , OPERATION_READSOLUTION}, {"TransferSolution" , OPERATION_TRANSFERSOLUTION}, {"SolveJac_AdaptRelax" , OPERATION_SOLVEJACADAPTRELAX}, {"SaveSolutionExtendedMH" , OPERATION_SAVESOLUTIONEXTENDEDMH}, {"DummyDofs" , OPERATION_DUMMYDOFS}, {"InitCorrection" , OPERATION_INITCORRECTION}, {NULL , OPERATION_NONE} } ; struct StringXDefine ChangeOfState_Type[] = { {"ChangeSign" , CHANGEOFSTATE_CHANGESIGN}, {"ChangeLevel" , CHANGEOFSTATE_CHANGELEVEL}, {"ChangeReference" , CHANGEOFSTATE_CHANGEREFERENCE}, {"ChangeReference2" , CHANGEOFSTATE_CHANGEREFERENCE2}, {NULL , CHANGEOFSTATE_CHANGESIGN} } ; struct StringXDefine ErrorNorm_Type[] = { {"LinfNorm" , LINFNORM}, {"L1Norm" , L1NORM}, {"MeanL1Norm" , MEANL1NORM}, {"L2Norm" , L2NORM}, {"MeanL2Norm" , MEANL2NORM}, {NULL , LINFNORM} } ; struct StringXDefine NormOf_Type[] = { {"Solution" , SOLUTION}, {"Residual" , RESIDUAL}, {"RecalcResidual" , RECALCRESIDUAL}, {NULL , SOLUTION} } ; struct StringXPointer Current_Value[] = { #if defined(HAVE_LEGACY) {"Time" , &Current.Time}, {"DTime" , &Current.DTime}, {"Theta" , &Current.Theta}, {"TimeStep" , &Current.TimeStep}, {"Iteration", &Current.Iteration}, {"Iter" , &Current.Iteration}, {"TimeImag" , &Current.TimeImag}, {"Eigenvalue" , &Current.Time}, {"EigenvalueReal" , &Current.Time}, {"EigenvalueImag" , &Current.TimeImag}, {"Breakpoint" , &Current.Breakpoint}, {"X" , &Current.x}, {"Y" , &Current.y}, {"Z" , &Current.z}, {"XS" , &Current.xs},{"YS" , &Current.ys}, {"ZS" , &Current.zs}, {"XP" , &Current.xp},{"YP" , &Current.yp}, {"ZP" , &Current.zp}, {"U" , &Current.x}, {"V" , &Current.y}, {"W" , &Current.z}, {"US" , &Current.xs},{"VS" , &Current.ys}, {"WS" , &Current.zs}, {"A" , &Current.a} ,{"B" , &Current.b} , {"C" , &Current.c}, {"Val0" , &Current.Val[0]}, {"Val1" , &Current.Val[1]}, {"Val2" , &Current.Val[2]}, {"Val3" , &Current.Val[3]}, {"Val4" , &Current.Val[4]}, {"Val5" , &Current.Val[5]}, {"Val6" , &Current.Val[6]}, {"Val7" , &Current.Val[7]}, {"Val8" , &Current.Val[8]}, #endif {NULL , NULL} } ; struct StringXDefine PostQuantityTerm_EvaluationType[] = { {"Local" , LOCAL}, {"Term" , LOCAL}, {"Integral" , INTEGRAL}, {NULL , LOCAL} } ; struct StringXDefine PostSubOperation_CombinationType[] = { {"*" , MULTIPLICATION}, {"/" , DIVISION}, {"+" , ADDITION}, {"-" , SOUSTRACTION}, {NULL , MULTIPLICATION} } ; struct StringXDefine PostSubOperation_Format[] = { {"Table" , FORMAT_SPACE_TABLE }, {"SimpleTable" , FORMAT_SIMPLE_SPACE_TABLE }, {"NodeTable" , FORMAT_NODE_TABLE }, {"ValueOnly" , FORMAT_VALUE_ONLY }, {"TimeTable" , FORMAT_TIME_TABLE }, {"RegionTable" , FORMAT_REGION_TABLE }, {"RegionValue" , FORMAT_REGION_VALUE }, {"HarmonicToTimeTable" , FORMAT_TIME_TABLE }, // a supprimer {"FrequencyTable" , FORMAT_FREQUENCY_TABLE }, {"Gmsh" , FORMAT_GMSH}, {"GmshParsed" , FORMAT_GMSH_PARSED}, {"Unv" , FORMAT_UNV}, {"Gnuplot" , FORMAT_GNUPLOT }, {"Matlab" , FORMAT_MATLAB }, {"Adaptation" , FORMAT_ADAPT }, {NULL , FORMAT_GMSH } } ; struct StringXDefine PostSubOperation_FormatTag[] = { {"Time" , TAG_TIME}, {"TimeStep" , TAG_TIMESTEP}, {"Value" , TAG_VALUE}, {"X" , TAG_X}, {"Y" , TAG_Y}, {"Z" , TAG_Z}, {"Nodes" , TAG_NODES}, {"Type" , TAG_TYPE}, {"Version" , TAG_VERSION}, {"Date" , TAG_DATE}, {"Host" , TAG_HOST}, {"Filename" , TAG_FILENAME}, {"User" , TAG_USER}, {"Abscissa" , TAG_ABSCISSA}, {"Normal" , TAG_NORMAL}, {"Command" , TAG_COMMAND}, {NULL , 0} } ; struct StringXDefine PostSubOperation_AdaptationType[] = { {"P1" , P1}, {"H1" , H1}, {"H2" , H2}, {NULL , P1} } ; struct StringXDefine PostSubOperation_SortType[] = { {"Position" , SORT_BY_POSITION }, {"Connection" , SORT_BY_CONNECTIVITY }, {NULL , 0 } } ; /* ------------------------------------------------------------------------ */ /* Types (int) and their assigned functions */ /* ------------------------------------------------------------------------ */ #define CAST void(*)() struct DefineXFunction FunctionForGauss[] = { #if defined(HAVE_LEGACY) {POINT , (CAST)Gauss_Point}, {LINE , (CAST)Gauss_Line}, {TRIANGLE , (CAST)Gauss_Triangle}, {QUADRANGLE , (CAST)Gauss_Quadrangle}, {TETRAHEDRON , (CAST)Gauss_Tetrahedron}, {HEXAHEDRON , (CAST)Gauss_Hexahedron}, {PRISM , (CAST)Gauss_Prism}, {PYRAMID , (CAST)Gauss_Pyramid}, {LINE_2 , (CAST)Gauss_Line}, {TRIANGLE_2 , (CAST)Gauss_Triangle}, {QUADRANGLE_2 , (CAST)Gauss_Quadrangle}, {QUADRANGLE_2_8N, (CAST)Gauss_Quadrangle}, #endif {0 , 0} } ; struct DefineXFunction FunctionForSingularGauss[] = { #if defined(HAVE_LEGACY) {TRIANGLE , (CAST)GaussSingularR_Triangle}, {QUADRANGLE , (CAST)GaussSingularR_Quadrangle}, #endif {0 , 0} } ; struct DefineXFunction FunctionForGaussLegendre[] = { #if defined(HAVE_LEGACY) {POINT , (CAST)Gauss_Point}, {LINE , (CAST)Gauss_Line}, {TRIANGLE , (CAST)GaussLegendre_Triangle}, {QUADRANGLE , (CAST)GaussLegendre_Quadrangle}, {TETRAHEDRON , (CAST)GaussLegendre_Tetrahedron}, {HEXAHEDRON , (CAST)GaussLegendre_Hexahedron}, #endif {0 , 0} } ; #define POI POINT #define LIN LINE | LINE_2 #define TRI TRIANGLE | TRIANGLE_2 #define QUA QUADRANGLE | QUADRANGLE_2 | QUADRANGLE_2_8N #define TET TETRAHEDRON | TETRAHEDRON_2 #define HEX HEXAHEDRON | HEXAHEDRON_2 #define PRI PRISM | PRISM_2 #define PYR PYRAMID | PYRAMID_2 #define ALL POI|LIN|TRI|QUA|TET|HEX|PRI|PYR struct StringX3Function3Nbr BF_Function[] = { #if defined(HAVE_LEGACY) // H^1 Basis Functions and their gradients {"BF_Node", (CAST)BF_Node, (CAST)BF_GradNode, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_Node_1N", (CAST)BF_Node, (CAST)BF_GradNode, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_Node_2E", (CAST)BF_Node_2E, (CAST)BF_GradNode_2E, (CAST)BF_Zero, 2., ALL, 0 }, {"BF_Node_2F", (CAST)BF_Node_2F, (CAST)BF_GradNode_2F, (CAST)BF_Zero, 2., QUA|HEX/*|PRI|PYR*/, 0 }, {"BF_Node_2V", (CAST)BF_Node_2V, (CAST)BF_GradNode_2V, (CAST)BF_Zero, 2., HEX, 0 }, {"BF_Node_3E", (CAST)BF_Node_3E, (CAST)BF_GradNode_3E, (CAST)BF_Zero, 3., ALL, 0 }, {"BF_Node_3F", (CAST)BF_Node_3F, (CAST)BF_GradNode_3F, (CAST)BF_Zero, 3., TRI|QUA|TET|HEX|PRI|PYR, 0 }, {"BF_Node_3V", (CAST)BF_Node_3V, (CAST)BF_GradNode_3V, (CAST)BF_Zero, 3., HEX|PRI|PYR, 0 }, {"BF_GradNode", (CAST)BF_GradNode, (CAST)BF_Zero, (CAST)BF_Node, 0., ALL, 0 }, {"BF_GradNode_1N", (CAST)BF_GradNode, (CAST)BF_Zero, (CAST)BF_Node, 0., ALL, 0 }, {"BF_GradNode_2E", (CAST)BF_GradNode_2E, (CAST)BF_Zero, (CAST)BF_Node_2E, 1., ALL, 0 }, {"BF_GradNode_2F", (CAST)BF_GradNode_2F, (CAST)BF_Zero, (CAST)BF_Node_2F, 1., QUA|HEX/*|PRI|PYR*/, 0 }, {"BF_GradNode_2V", (CAST)BF_GradNode_2V, (CAST)BF_Zero, (CAST)BF_Node_2V, 1., HEX, 0 }, {"BF_GradNode_3E", (CAST)BF_GradNode_3E, (CAST)BF_Zero, (CAST)BF_Node_3E, 2., ALL, 0 }, {"BF_GradNode_3F", (CAST)BF_GradNode_3F, (CAST)BF_Zero, (CAST)BF_Node_3F, 2., TRI|QUA|TET|HEX|PRI|PYR, 0 }, {"BF_GradNode_3V", (CAST)BF_GradNode_3V, (CAST)BF_Zero, (CAST)BF_Node_3V, 2., HEX|PRI|PYR, 0 }, {"BF_GroupOfNodes", (CAST)BF_GroupOfNodes, (CAST)BF_GradGroupOfNodes, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_GroupOfNodes_1N", (CAST)BF_GroupOfNodes, (CAST)BF_GradGroupOfNodes, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_GroupOfNodes_2E", (CAST)BF_GroupOfNodes_2E, (CAST)BF_GradGroupOfNodes_2E, (CAST)BF_Zero, 2., ALL, 0 }, {"BF_GroupOfNodes_2F", (CAST)BF_GroupOfNodes_2F, (CAST)BF_GradGroupOfNodes_2F, (CAST)BF_Zero, 2., QUA|HEX/*|PRI|PYR*/, 0 }, {"BF_GroupOfNodes_2V", (CAST)BF_GroupOfNodes_2V, (CAST)BF_GradGroupOfNodes_2V, (CAST)BF_Zero, 2., HEX, 0 }, {"BF_GroupOfNodes_3E", (CAST)BF_GroupOfNodes_3E, (CAST)BF_GradGroupOfNodes_3E, (CAST)BF_Zero, 3., ALL, 0 }, {"BF_GroupOfNodes_3F", (CAST)BF_GroupOfNodes_3F, (CAST)BF_GradGroupOfNodes_3F, (CAST)BF_Zero, 3., HEX|PRI|TET|HEX|PRI|PYR, 0 }, {"BF_GroupOfNodes_3V", (CAST)BF_GroupOfNodes_3V, (CAST)BF_GradGroupOfNodes_3V, (CAST)BF_Zero, 3., HEX|PRI|PYR, 0 }, {"BF_GradGroupOfNodes", (CAST)BF_GradGroupOfNodes, (CAST)BF_Zero, (CAST)BF_GroupOfNodes, 0., ALL, 0 }, {"BF_GradGroupOfNodes_1N", (CAST)BF_GradGroupOfNodes, (CAST)BF_Zero, (CAST)BF_GroupOfNodes, 0., ALL, 0 }, {"BF_GradGroupOfNodes_2E", (CAST)BF_GradGroupOfNodes_2E, (CAST)BF_Zero, (CAST)BF_GroupOfNodes_2E, 1., ALL, 0 }, {"BF_GradGroupOfNodes_2F", (CAST)BF_GradGroupOfNodes_2F, (CAST)BF_Zero, (CAST)BF_GroupOfNodes_2F, 1., QUA|HEX/*|PRI|PYR*/, 0 }, {"BF_GradGroupOfNodes_2V", (CAST)BF_GradGroupOfNodes_2V, (CAST)BF_Zero, (CAST)BF_GroupOfNodes_2V, 1., HEX, 0 }, {"BF_GradGroupOfNodes_3E", (CAST)BF_GradGroupOfNodes_3E, (CAST)BF_Zero, (CAST)BF_GroupOfNodes_3E, 2., ALL, 0 }, {"BF_GradGroupOfNodes_3F", (CAST)BF_GradGroupOfNodes_3F, (CAST)BF_Zero, (CAST)BF_GroupOfNodes_3F, 2., HEX|PRI|TET|HEX|PRI|PYR, 0 }, {"BF_GradGroupOfNodes_3V", (CAST)BF_GradGroupOfNodes_2V, (CAST)BF_Zero, (CAST)BF_GroupOfNodes_3V, 2., HEX|PRI|PYR, 0 }, // H(curl) basis Functions and their curls {"BF_Edge", (CAST)BF_Edge, (CAST)BF_CurlEdge, (CAST)BF_Zero, 0.5, ALL, 1 }, {"BF_Edge_1E", (CAST)BF_Edge, (CAST)BF_CurlEdge, (CAST)BF_Zero, 0.5, ALL, 1 }, {"BF_Edge_2E", (CAST)BF_Edge_2E, (CAST)BF_CurlEdge_2E, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_Edge_2F", (CAST)BF_Edge_2F, (CAST)BF_CurlEdge_2F, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_Edge_2V", (CAST)BF_Edge_2V, (CAST)BF_CurlEdge_2V, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_Edge_3E", (CAST)BF_Edge_3E, (CAST)BF_CurlEdge_3E, (CAST)BF_Zero, 1.5, TRI|QUA|TET|HEX|PRI, 0 }, {"BF_Edge_3F_a", (CAST)BF_Edge_3F_a, (CAST)BF_CurlEdge_3F_a, (CAST)BF_Zero, 1.5, TRI|QUA|TET|HEX|PRI, 0 }, {"BF_Edge_3F_b", (CAST)BF_Edge_3F_b, (CAST)BF_CurlEdge_3F_b, (CAST)BF_Zero, 1.5, TRI|QUA|TET|HEX|PRI, 0 }, {"BF_Edge_3F_c", (CAST)BF_Edge_3F_c, (CAST)BF_CurlEdge_3F_c, (CAST)BF_Zero, 1.5, TRI|QUA|TET|HEX|PRI, 0 }, {"BF_Edge_3V", (CAST)BF_Edge_3V, (CAST)BF_CurlEdge_3V, (CAST)BF_Zero, 1.5, TRI|QUA|TET|HEX|PRI, 0 }, {"BF_Edge_4E", (CAST)BF_Edge_4E, (CAST)BF_CurlEdge_4E, (CAST)BF_Zero, 2., ALL, 0 }, {"BF_Edge_4F", (CAST)BF_Edge_4F, (CAST)BF_CurlEdge_4F, (CAST)BF_Zero, 2., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_Edge_4V", (CAST)BF_Edge_4V, (CAST)BF_CurlEdge_4V, (CAST)BF_Zero, 2., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_CurlEdge", (CAST)BF_CurlEdge, (CAST)BF_Zero, (CAST)BF_Edge, 0., ALL, 1 }, {"BF_CurlEdge_1E", (CAST)BF_CurlEdge, (CAST)BF_Zero, (CAST)BF_Edge, 0., ALL, 0 }, {"BF_CurlEdge_2E", (CAST)BF_CurlEdge_2E, (CAST)BF_Zero, (CAST)BF_Edge_2E, 0., ALL, 0 }, {"BF_CurlEdge_2F", (CAST)BF_CurlEdge_2F, (CAST)BF_Zero, (CAST)BF_Edge_2F, 0., ALL, 0 }, {"BF_CurlEdge_2V", (CAST)BF_CurlEdge_2V, (CAST)BF_Zero, (CAST)BF_Edge_2V, 0., ALL, 0 }, {"BF_CurlEdge_3E", (CAST)BF_CurlEdge_3E, (CAST)BF_Zero, (CAST)BF_Edge_3E, 1., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_CurlEdge_3F_a", (CAST)BF_CurlEdge_3F_a, (CAST)BF_Zero, (CAST)BF_Edge_3F_a, 1., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_CurlEdge_3F_b", (CAST)BF_CurlEdge_3F_b, (CAST)BF_Zero, (CAST)BF_Edge_3F_b, 1., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_CurlEdge_3F_c", (CAST)BF_CurlEdge_3F_c, (CAST)BF_Zero, (CAST)BF_Edge_3F_c, 1., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_CurlEdge_3V", (CAST)BF_CurlEdge_3V, (CAST)BF_Zero, (CAST)BF_Edge_3V, 1., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_CurlEdge_4E", (CAST)BF_CurlEdge_4E, (CAST)BF_Zero, (CAST)BF_Edge_4E, 1., ALL, 0 }, {"BF_CurlEdge_4F", (CAST)BF_CurlEdge_4F, (CAST)BF_Zero, (CAST)BF_Edge_4F, 1., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_CurlEdge_4V", (CAST)BF_CurlEdge_4V, (CAST)BF_Zero, (CAST)BF_Edge_4V, 1., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_GroupOfEdges", (CAST)BF_GroupOfEdges, (CAST)BF_CurlGroupOfEdges, (CAST)BF_Zero, 0.5, ALL, 1 }, {"BF_GroupOfEdges_1E", (CAST)BF_GroupOfEdges, (CAST)BF_CurlGroupOfEdges, (CAST)BF_Zero, 0.5, ALL, 0 }, {"BF_GroupOfEdges_2E", (CAST)BF_GroupOfEdges_2E, (CAST)BF_CurlGroupOfEdges_2E, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_GroupOfEdges_2F", (CAST)BF_GroupOfEdges_2F, (CAST)BF_CurlGroupOfEdges_2F, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_GroupOfEdges_2V", (CAST)BF_GroupOfEdges_2V, (CAST)BF_CurlGroupOfEdges_2V, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_GroupOfEdges_3E", (CAST)BF_GroupOfEdges_3E, (CAST)BF_CurlGroupOfEdges_3E, (CAST)BF_Zero, 1.5, TRI|QUA|TET|HEX|PRI, 0 }, {"BF_GroupOfEdges_3F_a", (CAST)BF_GroupOfEdges_3F_a, (CAST)BF_CurlGroupOfEdges_3F_a, (CAST)BF_Zero, 1.5, TRI|QUA|TET|HEX|PRI, 0 }, {"BF_GroupOfEdges_3F_b", (CAST)BF_GroupOfEdges_3F_b, (CAST)BF_CurlGroupOfEdges_3F_b, (CAST)BF_Zero, 1.5, TRI|QUA|TET|HEX|PRI, 0 }, {"BF_GroupOfEdges_3F_c", (CAST)BF_GroupOfEdges_3F_c, (CAST)BF_CurlGroupOfEdges_3F_c, (CAST)BF_Zero, 1.5, TRI|QUA|TET|HEX|PRI, 0 }, {"BF_GroupOfEdges_3V", (CAST)BF_GroupOfEdges_3V, (CAST)BF_CurlGroupOfEdges_3V, (CAST)BF_Zero, 1.5, TRI|QUA|TET|HEX|PRI, 0 }, {"BF_GroupOfEdges_4E", (CAST)BF_GroupOfEdges_4E, (CAST)BF_CurlGroupOfEdges_4E, (CAST)BF_Zero, 2., ALL, 0 }, {"BF_GroupOfEdges_4F", (CAST)BF_GroupOfEdges_4F, (CAST)BF_CurlGroupOfEdges_4F, (CAST)BF_Zero, 2., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_GroupOfEdges_4V", (CAST)BF_GroupOfEdges_4V, (CAST)BF_CurlGroupOfEdges_4V, (CAST)BF_Zero, 2., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_CurlGroupOfEdges", (CAST)BF_CurlGroupOfEdges, (CAST)BF_Zero, (CAST)BF_GroupOfEdges, 0., ALL, 1 }, {"BF_CurlGroupOfEdges_1E", (CAST)BF_CurlGroupOfEdges, (CAST)BF_Zero, (CAST)BF_GroupOfEdges, 0., ALL, 0 }, {"BF_CurlGroupOfEdges_2E", (CAST)BF_CurlGroupOfEdges_2E, (CAST)BF_Zero, (CAST)BF_GroupOfEdges_2E, 0., ALL, 0 }, {"BF_CurlGroupOfEdges_2F", (CAST)BF_CurlGroupOfEdges_2F, (CAST)BF_Zero, (CAST)BF_GroupOfEdges_2F, 0., ALL, 0 }, {"BF_CurlGroupOfEdges_2V", (CAST)BF_CurlGroupOfEdges_2V, (CAST)BF_Zero, (CAST)BF_GroupOfEdges_2V, 0., ALL, 0 }, {"BF_CurlGroupOfEdges_3E", (CAST)BF_CurlGroupOfEdges_3E, (CAST)BF_Zero, (CAST)BF_GroupOfEdges_3E, 1., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_CurlGroupOfEdges_3F_a", (CAST)BF_CurlGroupOfEdges_3F_a, (CAST)BF_Zero, (CAST)BF_GroupOfEdges_3F_a, 1., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_CurlGroupOfEdges_3F_b", (CAST)BF_CurlGroupOfEdges_3F_b, (CAST)BF_Zero, (CAST)BF_GroupOfEdges_3F_b, 1., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_CurlGroupOfEdges_3F_c", (CAST)BF_CurlGroupOfEdges_3F_c, (CAST)BF_Zero, (CAST)BF_GroupOfEdges_3F_c, 1., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_CurlGroupOfEdges_3V", (CAST)BF_CurlGroupOfEdges_3V, (CAST)BF_Zero, (CAST)BF_GroupOfEdges_3V, 1., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_CurlGroupOfEdges_4E", (CAST)BF_CurlGroupOfEdges_4E, (CAST)BF_Zero, (CAST)BF_GroupOfEdges_4E, 1., ALL, 0 }, {"BF_CurlGroupOfEdges_4F", (CAST)BF_CurlGroupOfEdges_4F, (CAST)BF_Zero, (CAST)BF_GroupOfEdges_4F, 1., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_CurlGroupOfEdges_4V", (CAST)BF_CurlGroupOfEdges_4V, (CAST)BF_Zero, (CAST)BF_GroupOfEdges_4V, 1., TRI|QUA|TET|HEX|PRI, 0 }, // H(curl, perp) basis Functions and their curls {"BF_PerpendicularEdge", (CAST)BF_PerpendicularEdge, (CAST)BF_CurlPerpendicularEdge, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_PerpendicularEdge_1N", (CAST)BF_PerpendicularEdge, (CAST)BF_CurlPerpendicularEdge, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_PerpendicularEdge_2E", (CAST)BF_PerpendicularEdge_2E, (CAST)BF_CurlPerpendicularEdge_2E, (CAST)BF_Zero, 2., ALL, 0 }, {"BF_PerpendicularEdge_2F", (CAST)BF_PerpendicularEdge_2F, (CAST)BF_CurlPerpendicularEdge_2F, (CAST)BF_Zero, 2., QUA|HEX|PRI, 0 }, {"BF_PerpendicularEdge_2V", (CAST)BF_PerpendicularEdge_2V, (CAST)BF_CurlPerpendicularEdge_2V, (CAST)BF_Zero, 2., QUA|HEX, 0 }, {"BF_PerpendicularEdge_3E", (CAST)BF_PerpendicularEdge_3E, (CAST)BF_CurlPerpendicularEdge_3E, (CAST)BF_Zero, 3., ALL, 0 }, {"BF_PerpendicularEdge_3F", (CAST)BF_PerpendicularEdge_3F, (CAST)BF_CurlPerpendicularEdge_3F, (CAST)BF_Zero, 3., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_PerpendicularEdge_3V", (CAST)BF_PerpendicularEdge_3V, (CAST)BF_CurlPerpendicularEdge_3V, (CAST)BF_Zero, 3., HEX|PRI, 0 }, {"BF_CurlPerpendicularEdge", (CAST)BF_CurlPerpendicularEdge, (CAST)BF_Zero, (CAST)BF_PerpendicularEdge, 0., ALL, 0 }, {"BF_CurlPerpendicularEdge_1N", (CAST)BF_CurlPerpendicularEdge, (CAST)BF_Zero, (CAST)BF_PerpendicularEdge, 0., ALL, 0 }, {"BF_CurlPerpendicularEdge_2E", (CAST)BF_CurlPerpendicularEdge_2E, (CAST)BF_Zero, (CAST)BF_PerpendicularEdge_2E, 1., ALL, 0 }, {"BF_CurlPerpendicularEdge_2F", (CAST)BF_CurlPerpendicularEdge_2F, (CAST)BF_Zero, (CAST)BF_PerpendicularEdge_2F, 1., QUA|HEX|PRI, 0 }, {"BF_CurlPerpendicularEdge_2V", (CAST)BF_CurlPerpendicularEdge_2V, (CAST)BF_Zero, (CAST)BF_PerpendicularEdge_2V, 1., QUA|HEX, 0 }, {"BF_CurlPerpendicularEdge_3E", (CAST)BF_CurlPerpendicularEdge_3E, (CAST)BF_Zero, (CAST)BF_PerpendicularEdge_3E, 2., ALL, 0 }, {"BF_CurlPerpendicularEdge_3F", (CAST)BF_CurlPerpendicularEdge_3F, (CAST)BF_Zero, (CAST)BF_PerpendicularEdge_3F, 2., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_CurlPerpendicularEdge_3V", (CAST)BF_CurlPerpendicularEdge_3V, (CAST)BF_Zero, (CAST)BF_PerpendicularEdge_3V, 2., HEX|PRI, 0 }, {"BF_GroupOfPerpendicularEdges", (CAST)BF_GroupOfPerpendicularEdges, (CAST)BF_CurlGroupOfPerpendicularEdges, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_GroupOfPerpendicularEdges_1N", (CAST)BF_GroupOfPerpendicularEdges, (CAST)BF_CurlGroupOfPerpendicularEdges, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_GroupOfPerpendicularEdges_2E", (CAST)BF_GroupOfPerpendicularEdges_2E, (CAST)BF_CurlGroupOfPerpendicularEdges_2E, (CAST)BF_Zero, 2., ALL, 0 }, {"BF_GroupOfPerpendicularEdges_2F", (CAST)BF_GroupOfPerpendicularEdges_2F, (CAST)BF_CurlGroupOfPerpendicularEdges_2F, (CAST)BF_Zero, 2., QUA|HEX|PRI, 0 }, {"BF_GroupOfPerpendicularEdges_2V", (CAST)BF_GroupOfPerpendicularEdges_2V, (CAST)BF_CurlGroupOfPerpendicularEdges_2V, (CAST)BF_Zero, 2., QUA|HEX, 0 }, {"BF_GroupOfPerpendicularEdges_3E", (CAST)BF_GroupOfPerpendicularEdges_3E, (CAST)BF_CurlGroupOfPerpendicularEdges_3E, (CAST)BF_Zero, 3., ALL, 0 }, {"BF_GroupOfPerpendicularEdges_3F", (CAST)BF_GroupOfPerpendicularEdges_3F, (CAST)BF_CurlGroupOfPerpendicularEdges_3F, (CAST)BF_Zero, 3., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_GroupOfPerpendicularEdges_3V", (CAST)BF_GroupOfPerpendicularEdges_3V, (CAST)BF_CurlGroupOfPerpendicularEdges_3V, (CAST)BF_Zero, 3., HEX|PRI, 0 }, {"BF_CurlGroupOfPerpendicularEdges", (CAST)BF_CurlGroupOfPerpendicularEdges, (CAST)BF_Zero, (CAST)BF_GroupOfPerpendicularEdges, 0., ALL, 0 }, {"BF_CurlGroupOfPerpendicularEdges_1N", (CAST)BF_CurlGroupOfPerpendicularEdges, (CAST)BF_Zero, (CAST)BF_GroupOfPerpendicularEdges, 0., ALL, 0 }, {"BF_CurlGroupOfPerpendicularEdges_2E", (CAST)BF_CurlGroupOfPerpendicularEdges_2E, (CAST)BF_Zero, (CAST)BF_GroupOfPerpendicularEdges_2E, 1., ALL, 0 }, {"BF_CurlGroupOfPerpendicularEdges_2F", (CAST)BF_CurlGroupOfPerpendicularEdges_2F, (CAST)BF_Zero, (CAST)BF_GroupOfPerpendicularEdges_2F, 1., QUA|HEX|PRI, 0 }, {"BF_CurlGroupOfPerpendicularEdges_2V", (CAST)BF_CurlGroupOfPerpendicularEdges_2V, (CAST)BF_Zero, (CAST)BF_GroupOfPerpendicularEdges_2V, 1., QUA|HEX, 0 }, {"BF_CurlGroupOfPerpendicularEdges_3E", (CAST)BF_CurlGroupOfPerpendicularEdges_3E, (CAST)BF_Zero, (CAST)BF_GroupOfPerpendicularEdges_3E, 2., ALL, 0 }, {"BF_CurlGroupOfPerpendicularEdges_3F", (CAST)BF_CurlGroupOfPerpendicularEdges_3F, (CAST)BF_Zero, (CAST)BF_GroupOfPerpendicularEdges_3F, 2., TRI|QUA|TET|HEX|PRI, 0 }, {"BF_CurlGroupOfPerpendicularEdges_3V", (CAST)BF_CurlGroupOfPerpendicularEdges_3V, (CAST)BF_Zero, (CAST)BF_GroupOfPerpendicularEdges_3V, 2., HEX|PRI, 0 }, // H(div) basis Functions and their divergences {"BF_Facet", (CAST)BF_Facet, (CAST)BF_DivFacet, (CAST)BF_Zero, 0.5, ALL, 1 }, {"BF_DivFacet", (CAST)BF_DivFacet, (CAST)BF_Zero, (CAST)BF_Facet, 0., ALL, 1 }, {"BF_GroupOfFacets", (CAST)BF_GroupOfFacets, (CAST)BF_DivGroupOfFacets, (CAST)BF_Zero, 0.5, ALL, 1 }, {"BF_DivGroupOfFacets", (CAST)BF_DivGroupOfFacets, (CAST)BF_Zero, (CAST)BF_GroupOfFacets, 0., ALL, 1 }, // Current along wire {"BF_Wire", (CAST)BF_Wire, (CAST)BF_DivWire, (CAST)BF_Zero, 1., LIN, 0 }, {"BF_DivWire", (CAST)BF_DivWire, (CAST)BF_Zero, (CAST)BF_Wire, 0., LIN, 0 }, // H(div, perp) basis Functions and their divergences {"BF_PerpendicularFacet", (CAST)BF_PerpendicularFacet, (CAST)BF_DivPerpendicularFacet, (CAST)BF_Zero, 0.5, ALL, 1 }, {"BF_PerpendicularFacet_1E", (CAST)BF_PerpendicularFacet, (CAST)BF_DivPerpendicularFacet, (CAST)BF_Zero, 0.5, ALL, 0 }, {"BF_PerpendicularFacet_2E", (CAST)BF_PerpendicularFacet_2E, (CAST)BF_DivPerpendicularFacet_2E, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_PerpendicularFacet_2F", (CAST)BF_PerpendicularFacet_2F, (CAST)BF_DivPerpendicularFacet_2F, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_PerpendicularFacet_2V", (CAST)BF_PerpendicularFacet_2V, (CAST)BF_DivPerpendicularFacet_2V, (CAST)BF_Zero, 1., ALL, 0 }, {"BF_PerpendicularFacet_3E", (CAST)BF_PerpendicularFacet_3E, (CAST)BF_DivPerpendicularFacet_3E, (CAST)BF_Zero, 1.5, ALL, 0 }, {"BF_PerpendicularFacet_3F_a", (CAST)BF_PerpendicularFacet_3F_a, (CAST)BF_DivPerpendicularFacet_3F_a, (CAST)BF_Zero, 1.5, ALL, 0 }, {"BF_PerpendicularFacet_3F_b", (CAST)BF_PerpendicularFacet_3F_b, (CAST)BF_DivPerpendicularFacet_3F_b, (CAST)BF_Zero, 1.5, ALL, 0 }, {"BF_PerpendicularFacet_3F_c", (CAST)BF_PerpendicularFacet_3F_c, (CAST)BF_DivPerpendicularFacet_3F_c, (CAST)BF_Zero, 1.5, ALL, 0 }, {"BF_PerpendicularFacet_3V", (CAST)BF_PerpendicularFacet_3V, (CAST)BF_DivPerpendicularFacet_3V, (CAST)BF_Zero, 1.5, ALL, 0 }, {"BF_PerpendicularFacet_4E", (CAST)BF_PerpendicularFacet_4E, (CAST)BF_DivPerpendicularFacet_4E, (CAST)BF_Zero, 2., ALL, 0 }, {"BF_PerpendicularFacet_4F", (CAST)BF_PerpendicularFacet_4F, (CAST)BF_DivPerpendicularFacet_4F, (CAST)BF_Zero, 2., ALL, 0 }, {"BF_PerpendicularFacet_4V", (CAST)BF_PerpendicularFacet_4V, (CAST)BF_DivPerpendicularFacet_4V, (CAST)BF_Zero, 2., ALL, 0 }, {"BF_DivPerpendicularFacet", (CAST)BF_DivPerpendicularFacet, (CAST)BF_Zero, (CAST)BF_PerpendicularFacet, 0., ALL, 1 }, {"BF_DivPerpendicularFacet_1E", (CAST)BF_DivPerpendicularFacet, (CAST)BF_Zero, (CAST)BF_PerpendicularFacet, 0., ALL, 0 }, {"BF_DivPerpendicularFacet_2E", (CAST)BF_DivPerpendicularFacet_2E, (CAST)BF_Zero, (CAST)BF_PerpendicularFacet_2E, 0., ALL, 0 }, {"BF_DivPerpendicularFacet_2F", (CAST)BF_DivPerpendicularFacet_2F, (CAST)BF_Zero, (CAST)BF_PerpendicularFacet_2F, 0., ALL, 0 }, {"BF_DivPerpendicularFacet_2V", (CAST)BF_DivPerpendicularFacet_2V, (CAST)BF_Zero, (CAST)BF_PerpendicularFacet_2V, 0., ALL, 0 }, {"BF_DivPerpendicularFacet_3E", (CAST)BF_DivPerpendicularFacet_3E, (CAST)BF_Zero, (CAST)BF_PerpendicularFacet_3E, 1., ALL, 0 }, {"BF_DivPerpendicularFacet_3F_a", (CAST)BF_DivPerpendicularFacet_3F_a, (CAST)BF_Zero, (CAST)BF_PerpendicularFacet_3F_a, 1., ALL, 0 }, {"BF_DivPerpendicularFacet_3F_b", (CAST)BF_DivPerpendicularFacet_3F_b, (CAST)BF_Zero, (CAST)BF_PerpendicularFacet_3F_b, 1., ALL, 0 }, {"BF_DivPerpendicularFacet_3F_c", (CAST)BF_DivPerpendicularFacet_3F_c, (CAST)BF_Zero, (CAST)BF_PerpendicularFacet_3F_c, 1., ALL, 0 }, {"BF_DivPerpendicularFacet_3V", (CAST)BF_DivPerpendicularFacet_3V, (CAST)BF_Zero, (CAST)BF_PerpendicularFacet_3V, 1., ALL, 0 }, {"BF_DivPerpendicularFacet_4E", (CAST)BF_DivPerpendicularFacet_4E, (CAST)BF_Zero, (CAST)BF_PerpendicularFacet_4E, 1., ALL, 0 }, {"BF_DivPerpendicularFacet_4F", (CAST)BF_DivPerpendicularFacet_4F, (CAST)BF_Zero, (CAST)BF_PerpendicularFacet_4F, 1., ALL, 0 }, {"BF_DivPerpendicularFacet_4V", (CAST)BF_DivPerpendicularFacet_4V, (CAST)BF_Zero, (CAST)BF_PerpendicularFacet_4V, 1., ALL, 0 }, // L^2 basis Functions {"BF_Volume", (CAST)BF_Volume, (CAST)BF_Volume, (CAST)BF_Zero, 0., ALL, 0 }, {"BF_VolumeX", (CAST)BF_VolumeX, (CAST)BF_VolumeX, (CAST)BF_Zero, 0., ALL, 0 }, {"BF_VolumeY", (CAST)BF_VolumeY, (CAST)BF_VolumeY, (CAST)BF_Zero, 0., ALL, 0 }, {"BF_VolumeZ", (CAST)BF_VolumeZ, (CAST)BF_VolumeZ, (CAST)BF_Zero, 0., ALL, 0 }, // (H^1)^3 Basis Functions {"BF_NodeX" , (CAST)BF_NodeX , (CAST)BF_NodeX_D1 , (CAST)BF_NodeX_D2 , 1. , ALL, 0 }, {"BF_NodeY" , (CAST)BF_NodeY , (CAST)BF_NodeY_D1 , (CAST)BF_NodeY_D2 , 1. , ALL, 0 }, {"BF_NodeZ" , (CAST)BF_NodeZ , (CAST)BF_NodeZ_D1 , (CAST)BF_NodeZ_D2 , 1. , ALL, 0 }, {"BF_NodeX_2E" , (CAST)BF_NodeX_2E , (CAST)BF_NodeX_D1_2E , (CAST)BF_NodeX_D2_2E , 2. , ALL, 0 }, {"BF_NodeY_2E" , (CAST)BF_NodeY_2E , (CAST)BF_NodeY_D1_2E , (CAST)BF_NodeY_D2_2E , 2. , ALL, 0 }, {"BF_NodeZ_2E" , (CAST)BF_NodeZ_2E , (CAST)BF_NodeZ_D1_2E , (CAST)BF_NodeZ_D2_2E , 2. , ALL, 0 }, {"BF_NodeX_2F" , (CAST)BF_NodeX_2F , (CAST)BF_NodeX_D1_2F , (CAST)BF_NodeX_D2_2F , 2. , QUA|HEX/*|PRI*/, 0 }, {"BF_NodeY_2F" , (CAST)BF_NodeY_2F , (CAST)BF_NodeY_D1_2F , (CAST)BF_NodeY_D2_2F , 2. , QUA|HEX/*|PRI*/, 0 }, {"BF_NodeZ_2F" , (CAST)BF_NodeZ_2F , (CAST)BF_NodeZ_D1_2F , (CAST)BF_NodeZ_D2_2F , 2. , QUA|HEX/*|PRI*/, 0 }, {"BF_NodeX_2V" , (CAST)BF_NodeX_2V , (CAST)BF_NodeX_D1_2V , (CAST)BF_NodeX_D2_2V , 2. , HEX, 0 }, {"BF_NodeY_2V" , (CAST)BF_NodeY_2V , (CAST)BF_NodeY_D1_2V , (CAST)BF_NodeY_D2_2V , 2. , HEX, 0 }, {"BF_NodeZ_2V" , (CAST)BF_NodeZ_2V , (CAST)BF_NodeZ_D1_2V , (CAST)BF_NodeZ_D2_2V , 2. , HEX, 0 }, {"BF_NodeX_3E" , (CAST)BF_NodeX_3E , (CAST)BF_NodeX_D1_3E , (CAST)BF_NodeX_D2_3E , 3. , ALL, 0 }, {"BF_NodeY_3E" , (CAST)BF_NodeY_3E , (CAST)BF_NodeY_D1_3E , (CAST)BF_NodeY_D2_3E , 3. , ALL, 0 }, {"BF_NodeZ_3E" , (CAST)BF_NodeZ_3E , (CAST)BF_NodeZ_D1_3E , (CAST)BF_NodeZ_D2_3E , 3. , ALL, 0 }, {"BF_NodeX_3F" , (CAST)BF_NodeX_3F , (CAST)BF_NodeX_D1_3F , (CAST)BF_NodeX_D2_3F , 3. , TRI|QUA|TET|HEX|PRI, 0 }, {"BF_NodeY_3F" , (CAST)BF_NodeY_3F , (CAST)BF_NodeY_D1_3F , (CAST)BF_NodeY_D2_3F , 3. , TRI|QUA|TET|HEX|PRI, 0 }, {"BF_NodeZ_3F" , (CAST)BF_NodeZ_3F , (CAST)BF_NodeZ_D1_3F , (CAST)BF_NodeZ_D2_3F , 3. , TRI|QUA|TET|HEX|PRI, 0 }, {"BF_NodeX_3V" , (CAST)BF_NodeX_3V , (CAST)BF_NodeX_D1_3V , (CAST)BF_NodeX_D2_3V , 3. , HEX|PRI, 0 }, {"BF_NodeY_3V" , (CAST)BF_NodeY_3V , (CAST)BF_NodeY_D1_3V , (CAST)BF_NodeY_D2_3V , 3. , HEX|PRI, 0 }, {"BF_NodeZ_3V" , (CAST)BF_NodeZ_3V , (CAST)BF_NodeZ_D1_3V , (CAST)BF_NodeZ_D2_3V , 3. , HEX|PRI, 0 }, {"BF_NodeX_D1" , (CAST)BF_NodeX_D1 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_NodeY_D1" , (CAST)BF_NodeY_D1 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_NodeZ_D1" , (CAST)BF_NodeZ_D1 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_NodeX_D1_2E" , (CAST)BF_NodeX_D1_2E , (CAST)BF_Zero , (CAST)BF_Zero , 1. , ALL, 0 }, {"BF_NodeY_D1_2E" , (CAST)BF_NodeY_D1_2E , (CAST)BF_Zero , (CAST)BF_Zero , 1. , ALL, 0 }, {"BF_NodeZ_D1_2E" , (CAST)BF_NodeZ_D1_2E , (CAST)BF_Zero , (CAST)BF_Zero , 1. , ALL, 0 }, {"BF_NodeX_D1_2F" , (CAST)BF_NodeX_D1_2F , (CAST)BF_Zero , (CAST)BF_Zero , 1. , QUA|HEX/*|PRI*/, 0 }, {"BF_NodeY_D1_2F" , (CAST)BF_NodeY_D1_2F , (CAST)BF_Zero , (CAST)BF_Zero , 1. , QUA|HEX/*|PRI*/, 0 }, {"BF_NodeZ_D1_2F" , (CAST)BF_NodeZ_D1_2F , (CAST)BF_Zero , (CAST)BF_Zero , 1. , QUA|HEX/*|PRI*/, 0 }, {"BF_NodeX_D1_2V" , (CAST)BF_NodeX_D1_2V , (CAST)BF_Zero , (CAST)BF_Zero , 1. , HEX, 0 }, {"BF_NodeY_D1_2V" , (CAST)BF_NodeY_D1_2V , (CAST)BF_Zero , (CAST)BF_Zero , 1. , HEX, 0 }, {"BF_NodeZ_D1_2V" , (CAST)BF_NodeZ_D1_2V , (CAST)BF_Zero , (CAST)BF_Zero , 1. , HEX, 0 }, {"BF_NodeX_D1_3E" , (CAST)BF_NodeX_D1_3E , (CAST)BF_Zero , (CAST)BF_Zero , 2. , ALL, 0 }, {"BF_NodeY_D1_3E" , (CAST)BF_NodeY_D1_3E , (CAST)BF_Zero , (CAST)BF_Zero , 2. , ALL, 0 }, {"BF_NodeZ_D1_3E" , (CAST)BF_NodeZ_D1_3E , (CAST)BF_Zero , (CAST)BF_Zero , 2. , ALL, 0 }, {"BF_NodeX_D1_3F" , (CAST)BF_NodeX_D1_3F , (CAST)BF_Zero , (CAST)BF_Zero , 2. , TRI|QUA|TET|HEX|PRI, 0 }, {"BF_NodeY_D1_3F" , (CAST)BF_NodeY_D1_3F , (CAST)BF_Zero , (CAST)BF_Zero , 2. , TRI|QUA|TET|HEX|PRI, 0 }, {"BF_NodeZ_D1_3F" , (CAST)BF_NodeZ_D1_3F , (CAST)BF_Zero , (CAST)BF_Zero , 2. , TRI|QUA|TET|HEX|PRI, 0 }, {"BF_NodeX_D1_3V" , (CAST)BF_NodeX_D1_3V , (CAST)BF_Zero , (CAST)BF_Zero , 2. , HEX|PRI, 0 }, {"BF_NodeY_D1_3V" , (CAST)BF_NodeY_D1_3V , (CAST)BF_Zero , (CAST)BF_Zero , 2. , HEX|PRI, 0 }, {"BF_NodeZ_D1_3V" , (CAST)BF_NodeZ_D1_3V , (CAST)BF_Zero , (CAST)BF_Zero , 2. , HEX|PRI, 0 }, {"BF_NodeX_D2" , (CAST)BF_NodeX_D2 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_NodeY_D2" , (CAST)BF_NodeY_D2 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_NodeZ_D2" , (CAST)BF_NodeZ_D2 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_NodeX_D2_2E" , (CAST)BF_NodeX_D2_2E , (CAST)BF_Zero , (CAST)BF_Zero , 1. , ALL, 0 }, {"BF_NodeY_D2_2E" , (CAST)BF_NodeY_D2_2E , (CAST)BF_Zero , (CAST)BF_Zero , 1. , ALL, 0 }, {"BF_NodeZ_D2_2E" , (CAST)BF_NodeZ_D2_2E , (CAST)BF_Zero , (CAST)BF_Zero , 1. , ALL, 0 }, {"BF_NodeX_D2_2F" , (CAST)BF_NodeX_D2_2F , (CAST)BF_Zero , (CAST)BF_Zero , 1. , QUA|HEX/*|PRI*/, 0 }, {"BF_NodeY_D2_2F" , (CAST)BF_NodeY_D2_2F , (CAST)BF_Zero , (CAST)BF_Zero , 1. , QUA|HEX/*|PRI*/, 0 }, {"BF_NodeZ_D2_2F" , (CAST)BF_NodeZ_D2_2F , (CAST)BF_Zero , (CAST)BF_Zero , 1. , QUA|HEX/*|PRI*/, 0 }, {"BF_NodeX_D2_2V" , (CAST)BF_NodeX_D2_2V , (CAST)BF_Zero , (CAST)BF_Zero , 1. , HEX, 0 }, {"BF_NodeY_D2_2V" , (CAST)BF_NodeY_D2_2V , (CAST)BF_Zero , (CAST)BF_Zero , 1. , HEX, 0 }, {"BF_NodeZ_D2_2V" , (CAST)BF_NodeZ_D2_2V , (CAST)BF_Zero , (CAST)BF_Zero , 1. , HEX, 0 }, {"BF_NodeX_D2_3E" , (CAST)BF_NodeX_D2_3E , (CAST)BF_Zero , (CAST)BF_Zero , 2. , ALL, 0 }, {"BF_NodeY_D2_3E" , (CAST)BF_NodeY_D2_3E , (CAST)BF_Zero , (CAST)BF_Zero , 2. , ALL, 0 }, {"BF_NodeZ_D2_3E" , (CAST)BF_NodeZ_D2_3E , (CAST)BF_Zero , (CAST)BF_Zero , 2. , ALL, 0 }, {"BF_NodeX_D2_3F" , (CAST)BF_NodeX_D2_3F , (CAST)BF_Zero , (CAST)BF_Zero , 2. , TRI|QUA|TET|HEX|PRI, 0 }, {"BF_NodeY_D2_3F" , (CAST)BF_NodeY_D2_3F , (CAST)BF_Zero , (CAST)BF_Zero , 2. , TRI|QUA|TET|HEX|PRI, 0 }, {"BF_NodeZ_D2_3F" , (CAST)BF_NodeZ_D2_3F , (CAST)BF_Zero , (CAST)BF_Zero , 2. , TRI|QUA|TET|HEX|PRI, 0 }, {"BF_NodeX_D2_3V" , (CAST)BF_NodeX_D2_3V , (CAST)BF_Zero , (CAST)BF_Zero , 2. , HEX|PRI, 0 }, {"BF_NodeY_D2_3V" , (CAST)BF_NodeY_D2_3V , (CAST)BF_Zero , (CAST)BF_Zero , 2. , HEX|PRI, 0 }, {"BF_NodeZ_D2_3V" , (CAST)BF_NodeZ_D2_3V , (CAST)BF_Zero , (CAST)BF_Zero , 2. , HEX|PRI, 0 }, {"BF_NodeX_D12" , (CAST)BF_NodeX_D12 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_NodeY_D12" , (CAST)BF_NodeY_D12 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_NodeZ_D12" , (CAST)BF_NodeZ_D12 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_NodeX_D12_2E" , (CAST)BF_NodeX_D12_2E , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_NodeY_D12_2E" , (CAST)BF_NodeY_D12_2E , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_NodeZ_D12_2E" , (CAST)BF_NodeZ_D12_2E , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_GroupOfNodesX" , (CAST)BF_GroupOfNodesX , (CAST)BF_GroupOfNodesX_D1 , (CAST)BF_GroupOfNodesX_D2 , 1. , ALL, 0 }, {"BF_GroupOfNodesY" , (CAST)BF_GroupOfNodesY , (CAST)BF_GroupOfNodesY_D1 , (CAST)BF_GroupOfNodesY_D2 , 1. , ALL, 0 }, {"BF_GroupOfNodesZ" , (CAST)BF_GroupOfNodesZ , (CAST)BF_GroupOfNodesZ_D1 , (CAST)BF_GroupOfNodesZ_D2 , 1. , ALL, 0 }, {"BF_GroupOfNodesX_D1" , (CAST)BF_GroupOfNodesX_D1 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_GroupOfNodesY_D1" , (CAST)BF_GroupOfNodesY_D1 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_GroupOfNodesZ_D1" , (CAST)BF_GroupOfNodesZ_D1 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_GroupOfNodesX_D2" , (CAST)BF_GroupOfNodesX_D2 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_GroupOfNodesY_D2" , (CAST)BF_GroupOfNodesY_D2 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_GroupOfNodesZ_D2" , (CAST)BF_GroupOfNodesZ_D2 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_GroupOfNodesX_D12" , (CAST)BF_GroupOfNodesX_D12 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_GroupOfNodesY_D12" , (CAST)BF_GroupOfNodesY_D12 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_GroupOfNodesZ_D12" , (CAST)BF_GroupOfNodesZ_D12 , (CAST)BF_Zero , (CAST)BF_Zero , 0. , ALL, 0 }, // Special basis Functions {"BF_Zero", (CAST)BF_Zero, (CAST)BF_Zero, (CAST)BF_Zero, 0., ALL, 0 }, {"BF_One", (CAST)BF_One, (CAST)BF_One, (CAST)BF_One, 0., ALL, 0 }, {"BF_Region" , (CAST)BF_Region , (CAST)BF_dRegion , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_RegionX" , (CAST)BF_RegionX , (CAST)BF_dRegionX , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_RegionY" , (CAST)BF_RegionY , (CAST)BF_dRegionY , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_RegionZ" , (CAST)BF_RegionZ , (CAST)BF_dRegionZ , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_Global" , (CAST)BF_Global , (CAST)BF_dGlobal , (CAST)BF_Zero , 0. , ALL, 0 }, {"BF_dGlobal" , (CAST)BF_dGlobal , (CAST)BF_Zero , (CAST)BF_Global, 0. , ALL, 0 }, #endif {NULL , NULL , NULL , NULL , 0. , ALL, 0 } } ; #undef POI #undef LIN #undef TRI #undef QUA #undef TET #undef HEX #undef PRI #undef PYR #undef ALL struct StringXFunction2Nbr F_Function[] = { /* #Par #Arg */ /* #Par = -1 => free number of Parameters ; = -2 free even number */ /* #Arg ... same */ #if defined(HAVE_LEGACY) // F_Math {"Exp" , (CAST)F_Exp , 0, 1 }, {"Log" , (CAST)F_Log , 0, 1 }, {"Log10" , (CAST)F_Log10 , 0, 1 }, {"Sqrt" , (CAST)F_Sqrt , 0, 1 }, {"Sin" , (CAST)F_Sin , 0, 1 }, {"Asin" , (CAST)F_Asin , 0, 1 }, {"Cos" , (CAST)F_Cos , 0, 1 }, {"Acos" , (CAST)F_Acos , 0, 1 }, {"Tan" , (CAST)F_Tan , 0, 1 }, {"Atan" , (CAST)F_Atan , 0, 1 }, {"Sinh" , (CAST)F_Sinh , 0, 1 }, {"Cosh" , (CAST)F_Cosh , 0, 1 }, {"Tanh" , (CAST)F_Tanh , 0, 1 }, {"Fabs" , (CAST)F_Fabs , 0, 1 }, {"Floor" , (CAST)F_Floor , 0, 1 }, {"Ceil" , (CAST)F_Ceil , 0, 1 }, {"Atan2" , (CAST)F_Atan2 , 0, 2 }, {"Fmod" , (CAST)F_Fmod , 0, 2 }, {"Sign" , (CAST)F_Sign , 0, 1 }, {"Jn" , (CAST)F_Jn , 0, 2 }, {"Yn" , (CAST)F_Yn , 0, 2 }, {"dJn" , (CAST)F_dJn , 0, 2 }, {"dYn" , (CAST)F_dYn , 0, 2 }, // F_ExtMath {"Hypot" , (CAST)F_Hypot , 0, 2 }, {"TanhC2" , (CAST)F_TanhC2 , 0, 1 }, {"Transpose" , (CAST)F_Transpose , 0, 1 }, {"Inv" , (CAST)F_Inv , 0, 1 }, {"Det" , (CAST)F_Det , 0, 1 }, {"TTrace" , (CAST)F_Trace , 0, 1 }, {"Rotate" , (CAST)F_RotateXYZ , 0, 4 }, {"Norm" , (CAST)F_Norm , 0, 1 }, {"SquNorm" , (CAST)F_SquNorm , 0, 1 }, {"Unit" , (CAST)F_Unit , 0, 1 }, {"ScalarUnit" , (CAST)F_ScalarUnit , 0, 1 }, {"Normalized" , (CAST)F_Unit , 0, 1 }, {"F_Cos_wt_p" , (CAST)F_Cos_wt_p , 2, 0 }, {"F_Sin_wt_p" , (CAST)F_Sin_wt_p , 2, 0 }, {"F_Period" , (CAST)F_Period , 1, 1 }, {"Interval" , (CAST)F_Interval , 3, 3 }, {"Complex" , (CAST)F_Complex , 0, -2 }, {"Complex_MH" , (CAST)F_Complex_MH , -1, -2 }, {"Re" , (CAST)F_Re , 0, 1 }, {"Im" , (CAST)F_Im , 0, 1 }, {"Conj" , (CAST)F_Conj , 0, 1 }, {"Cart2Pol" , (CAST)F_Cart2Pol , 0, 1 }, {"Vector" , (CAST)F_Vector , 0, 3 }, {"Tensor" , (CAST)F_Tensor , 0, 9 }, {"TensorV" , (CAST)F_TensorV , 0, 3 }, {"TensorSym" , (CAST)F_TensorSym , 0, 6 }, {"TensorDiag" , (CAST)F_TensorDiag , 0, 3 }, {"SquDyadicProduct" , (CAST)F_SquDyadicProduct , 0, 1 }, {"CompX" , (CAST)F_CompX , 0, 1 }, {"CompY" , (CAST)F_CompY , 0, 1 }, {"CompZ" , (CAST)F_CompZ , 0, 1 }, {"CompXX" , (CAST)F_CompXX , 0, 1 }, {"CompXY" , (CAST)F_CompXY , 0, 1 }, {"CompXZ" , (CAST)F_CompXZ , 0, 1 }, {"CompYX" , (CAST)F_CompYX , 0, 1 }, {"CompYY" , (CAST)F_CompYY , 0, 1 }, {"CompYZ" , (CAST)F_CompYZ , 0, 1 }, {"CompZX" , (CAST)F_CompZX , 0, 1 }, {"CompZY" , (CAST)F_CompZY , 0, 1 }, {"CompZZ" , (CAST)F_CompZZ , 0, 1 }, {"Cart2Sph" , (CAST)F_Cart2Sph , 0, 1 }, {"Cart2Cyl" , (CAST)F_Cart2Cyl , 0, 1 }, {"UnitVectorX" , (CAST)F_UnitVectorX , 0, 0 }, {"UnitVectorY" , (CAST)F_UnitVectorY , 0, 0 }, {"UnitVectorZ" , (CAST)F_UnitVectorZ , 0, 0 }, // F_Coord {"CoordX" , (CAST)F_CoordX , 0, 0 }, {"CoordY" , (CAST)F_CoordY , 0, 0 }, {"CoordZ" , (CAST)F_CoordZ , 0, 0 }, {"CoordXYZ" , (CAST)F_CoordXYZ , 0, 0 }, {"X" , (CAST)F_CoordX , 0, 0 }, {"Y" , (CAST)F_CoordY , 0, 0 }, {"Z" , (CAST)F_CoordZ , 0, 0 }, {"XYZ" , (CAST)F_CoordXYZ , 0, 0 }, {"F_aX_bY_cZ" , (CAST)F_aX_bY_cZ , 3, 0 }, {"F_aX21_bY21_cZ21" , (CAST)F_aX21_bY21_cZ21 , 3, 0 }, {"XS" , (CAST)F_CoordXS , 0, 0 }, {"YS" , (CAST)F_CoordYS , 0, 0 }, {"ZS" , (CAST)F_CoordZS , 0, 0 }, {"XYZS" , (CAST)F_CoordXYZS , 0, 0 }, // F_Geometry {"Normal" , (CAST)F_Normal , 0, 0 }, {"NormalSource" , (CAST)F_NormalSource , 0, 0 }, {"Tangent" , (CAST)F_Tangent , 0, 0 }, {"TangentSource" , (CAST)F_TangentSource , 0, 0 }, {"ElementVol" , (CAST)F_ElementVol , 0, 0 }, {"SurfaceArea" , (CAST)F_SurfaceArea , -1, 0 }, {"GetVolume" , (CAST)F_GetVolume , -1, 0 }, {"ProjectPointOnEllipse", (CAST)F_ProjectPointOnEllipse, 2, 1 }, // F_Misc {"Printf" , (CAST)F_Printf , 0, 1 }, {"Rand" , (CAST)F_Rand , 0, 1 }, {"CompElementNum" , (CAST)F_CompElementNum , 0, 0 }, {"VirtualWork" , (CAST)F_VirtualWork , 0, 1 }, // F_Interpolation {"InterpolationLinear" , (CAST)F_InterpolationLinear , -2, 1 }, {"dInterpolationLinear" , (CAST)F_dInterpolationLinear , -2, 1 }, {"dInterpolationLinear2" , (CAST)F_dInterpolationLinear2 , -2, 1 }, {"InterpolationAkima" , (CAST)F_InterpolationAkima , -2, 1 }, {"dInterpolationAkima" , (CAST)F_dInterpolationAkima , -2, 1 }, {"InterpolationBilinear" , (CAST)F_InterpolationBilinear , -1, 2 }, {"dInterpolationBilinear", (CAST)F_dInterpolationBilinear, -1, 2 }, {"ValueFromIndex" , (CAST)F_ValueFromIndex , -1, 0 }, {"VectorFromIndex" , (CAST)F_VectorFromIndex , -1, 0 }, // F_Hysteresis {"dhdb_Jiles" , (CAST)F_dhdb_Jiles , -1, 3 }, {"dbdh_Jiles" , (CAST)F_dbdh_Jiles , -1, 3 }, {"h_Jiles" , (CAST)F_h_Jiles , -1, 3 }, {"b_Jiles" , (CAST)F_b_Jiles , -1, 3 }, {"dhdb_Ducharne" , (CAST)F_dhdb_Ducharne , -1, 3 }, {"h_Ducharne" , (CAST)F_h_Ducharne , -1, 3 }, {"nu_Ducharne" , (CAST)F_nu_Ducharne , -1, 3 }, {"mu_Vinch" , (CAST)F_mu_Vinch , -1, 3 }, {"nu_Vinch" , (CAST)F_nu_Vinch , -1, 3 }, {"h_Vinch" , (CAST)F_h_Vinch , -1, 4 }, {"dhdb_Vinch" , (CAST)F_dhdb_Vinch , -1, 3 }, {"dbdh_Vinch" , (CAST)F_dbdh_Vinch , -1, 3 }, {"Update_Jk" , (CAST)F_Update_Jk , -1, 6 }, {"Update_Jk_sd" , (CAST)F_Update_Jk_sd , -1, 6 }, // F_MultiHar {"MHToTime" , (CAST)F_MHToTime , 0, 2 }, // F_Analytic {"JFIE_ZPolAnalyticOnCyl", (CAST)F_JFIE_ZPolCyl , 4, 1 }, {"RCS_ZPolAnalyticCyl", (CAST)F_RCS_ZPolCyl , 3, 1 }, {"JFIE_TransZPolAnalyticOnCyl", (CAST)F_JFIE_TransZPolCyl, 3, 1 }, {"JFIE_OnSphCutTheta", (CAST)F_JFIE_SphTheta, 4, 1 }, {"RCS_SphTheta", (CAST)F_RCS_SphTheta, 4, 1 }, {"JFIE_OnSphCutPhi", (CAST)F_JFIE_SphPhi, 4, 1 }, {"RCS_SphPhi", (CAST)F_RCS_SphPhi, 4, 1 }, {"CurrentPerfectlyConductingSphere",(CAST)F_CurrentPerfectlyConductingSphere, 3, 1 }, {"ElectricFieldPerfectlyConductingSphereMwt", (CAST)F_ElectricFieldPerfectlyConductingSphereMwt, 2, 1 }, {"ElectricFieldDielectricSphereMwt", (CAST)F_ElectricFieldDielectricSphereMwt, 2, 1 }, {"ExactOsrcSolutionPerfectlyConductingSphereMwt", (CAST)F_ExactOsrcSolutionPerfectlyConductingSphereMwt, 3, 1 }, {"CurrentPerfectlyConductingSphereMwt",(CAST)F_CurrentPerfectlyConductingSphereMwt, 3, 1 }, {"AcousticFieldSoftSphere", (CAST)F_AcousticFieldSoftSphere, 2, 1 }, {"DrAcousticFieldSoftSphere", (CAST)F_DrAcousticFieldSoftSphere, 2, 1 }, {"RCSSoftSphere", (CAST)F_RCSSoftSphere, 2, 1 }, {"AcousticFieldHardSphere", (CAST)F_AcousticFieldHardSphere, 2, 1 }, {"RCSHardSphere", (CAST)F_RCSHardSphere, 2, 1 }, {"AcousticFieldSoftCylinder", (CAST)F_AcousticFieldSoftCylinder, 2, 1 }, {"AcousticFieldSoftCylinderABC", (CAST)F_AcousticFieldSoftCylinderABC, 5, 1 }, {"DrAcousticFieldSoftCylinder", (CAST)F_DrAcousticFieldSoftCylinder, 2, 1 }, {"RCSSoftCylinder", (CAST)F_RCSSoftCylinder, 2, 1 }, {"AcousticFieldHardCylinder", (CAST)F_AcousticFieldHardCylinder, 2, 1 }, {"AcousticFieldHardCylinderABC", (CAST)F_AcousticFieldHardCylinderABC, 5, 1 }, {"DthetaAcousticFieldHardCylinder", (CAST)F_DthetaAcousticFieldHardCylinder, 2, 1 }, {"RCSHardCylinder", (CAST)F_RCSHardCylinder, 2, 1 }, {"OSRC_C0", (CAST)F_OSRC_C0, 2, 0}, {"OSRC_Aj", (CAST)F_OSRC_Aj, 3, 0}, {"OSRC_Bj", (CAST)F_OSRC_Bj, 3, 0}, // F_Raytracing: ray tracing functions {"CylinderPhase", (CAST)F_CylinderPhase, 0, 1 }, {"DiamondPhase", (CAST)F_DiamondPhase, 0, 1 }, // F_BiotSavart {"BiotSavart", (CAST)F_BiotSavart , 1, 0 }, {"Pocklington", (CAST)F_Pocklington , 2, 0 }, // F_Gmsh {"Field", (CAST)F_Field , -1, -1 }, {"ScalarField", (CAST)F_ScalarField , -1, -1 }, {"VectorField", (CAST)F_VectorField , -1, -1 }, {"TensorField", (CAST)F_TensorField , -1, -1 }, {"ComplexScalarField", (CAST)F_ComplexScalarField, -1, -1 }, {"ComplexVectorField", (CAST)F_ComplexVectorField, -1, -1 }, {"ComplexTensorField", (CAST)F_ComplexTensorField, -1, -1 }, // F_DiffGeom {"Hodge", (CAST)F_Hodge , 1, 2 }, {"Sharp", (CAST)F_Sharp , 1, 2 }, {"Flat", (CAST)F_Flat , 1, 2 }, {"InnerProduct", (CAST)F_InnerProduct , 1, 3 }, {"WedgeProduct", (CAST)F_WedgeProduct , 2, 2 }, {"InteriorProduct", (CAST)F_InteriorProduct , 1, 2 }, {"TensorProduct", (CAST)F_TensorProduct , 0, 2 }, {"PullBack", (CAST)F_PullBack , 1, 2 }, {"PullBackMetric", (CAST)F_PullBackMetric , 0, 2 }, {"PushForward", (CAST)F_PushForward , 1, 2 }, {"InvPullBack", (CAST)F_InvPullBack , 1, 2 }, {"InvPushForward", (CAST)F_InvPushForward , 1, 2 }, // GF_XXX : Green Functions {"Laplace" , (CAST)GF_Laplace , 1, 0 }, {"GradLaplace" , (CAST)GF_GradLaplace , 1, 0 }, {"NPxGradLaplace" , (CAST)GF_NPxGradLaplace , 1, 0 }, {"NSxGradLaplace" , (CAST)GF_NSxGradLaplace , 1, 0 }, {"ApproximateLaplace", (CAST)GF_ApproximateLaplace, 2, 0 }, {"Helmholtz" , (CAST)GF_Helmholtz , 2, 0 }, {"HelmholtzThinWire" , (CAST)GF_HelmholtzThinWire, 3, 0 }, {"GradHelmholtz" , (CAST)GF_GradHelmholtz , 2, 0 }, {"NPxGradHelmholtz" , (CAST)GF_NPxGradHelmholtz , 2, 0 }, {"NSxGradHelmholtz" , (CAST)GF_NSxGradHelmholtz , 2, 0 }, #endif {NULL , NULL , 0, 0 } } ; struct FunctionXFunction GF_Function[] = { #if defined(HAVE_LEGACY) {(CAST)GF_Laplace , (CAST)GF_LaplacexForm } , {(CAST)GF_GradLaplace , (CAST)GF_GradLaplacexForm } , {(CAST)GF_NPxGradLaplace , (CAST)GF_NPxGradLaplacexForm } , {(CAST)GF_NSxGradLaplace , (CAST)GF_NSxGradLaplacexForm } , {(CAST)GF_ApproximateLaplace , (CAST)GF_ApproximateLaplacexForm } , {(CAST)GF_Helmholtz , (CAST)GF_HelmholtzxForm } , #endif {NULL , NULL } } ; #undef CAST #endif getdp-2.4.2-source/Interface/ProData.cpp000644 001750 001750 00000167363 12166744441 021567 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include #include "GetDPConfig.h" #include "ProData.h" #include "ProDefine.h" #include "ProParser.h" #include "Message.h" #include "MallocUtils.h" #include "OS.h" #if defined(HAVE_LEGACY) #include "Generate_Network.h" #endif // Global problem structure: this is the only problem structure that // is instanciated, and it is filled by the parser struct Problem Problem_S; // Global run-time current data: this is the only current data // structure that is instantiated struct CurrentData Current; // Sorting functions int fcmp_Integer(const void *a, const void *b) { return(*(int*)a - *(int*)b ); } int fcmp_Constant (const void *a, const void *b) { return ( strcmp(((struct Constant *)a)->Name, ((struct Constant *)b)->Name)); } int fcmp_Expression_Name(const void *a, const void *b) { return ( strcmp((char *)a, ((struct Expression *)b)->Name ) ); } int fcmp_Group_Name(const void *a, const void *b) { return ( strcmp((char *)a, ((struct Group *)b)->Name ) ); } int fcmp_Constraint_Name(const void *a, const void *b) { return ( strcmp((char *)a, ((struct Constraint *)b)->Name ) ); } int fcmp_JacobianMethod_Name(const void *a, const void *b) { return ( strcmp((char *)a, ((struct JacobianMethod *)b)->Name ) ); } int fcmp_IntegrationMethod_Name(const void *a, const void *b) { return ( strcmp((char *)a, ((struct IntegrationMethod *)b)->Name ) ); } int fcmp_BasisFunction_Name(const void *a, const void *b) { return ( strcmp((char *)a, ((struct BasisFunction *)b)->Name ) ); } int fcmp_FunctionSpace_Name(const void *a, const void *b) { return ( strcmp((char *)a, ((struct FunctionSpace *)b)->Name ) ); } int fcmp_BasisFunction_NameOfCoef(const void *a, const void *b) { return ( strcmp((char *)a, ((struct BasisFunction *)b)->NameOfCoef ) ); } int fcmp_SubSpace_Name(const void *a, const void *b) { return ( strcmp((char *)a, ((struct SubSpace *)b)->Name ) ); } int fcmp_GlobalQuantity_Name(const void *a, const void *b) { return ( strcmp((char *)a, ((struct GlobalQuantity *)b)->Name ) ); } int fcmp_Formulation_Name(const void *a, const void *b) { return ( strcmp((char *)a, ((struct Formulation *)b)->Name ) ); } int fcmp_DefineQuantity_Name(const void *a, const void *b) { return ( strcmp((char *)a, ((struct DefineQuantity *)b)->Name ) ); } int fcmp_DefineSystem_Name(const void *a, const void *b) { return ( strcmp((char *)a, ((struct DefineSystem *)b)->Name ) ); } int fcmp_Resolution_Name(const void *a, const void *b) { return ( strcmp((char *)a, ((struct Resolution *)b)->Name ) ); } int fcmp_PostProcessing_Name(const void *a, const void *b) { return ( strcmp((char *)a, ((struct PostProcessing *)b)->Name ) ); } int fcmp_PostQuantity_Name(const void *a, const void *b) { return ( strcmp((char *)a, ((struct PostQuantity *)b)->Name ) ); } int fcmp_PostOperation_Name(const void *a, const void *b) { return ( strcmp((char *)a, ((struct PostOperation *)b)->Name ) ); } // I/O routines void Init_ProblemStructure() { Problem_S.Group = NULL ; Problem_S.Expression = NULL ; Problem_S.FunctionSpace = NULL ; Problem_S.Constraint = NULL ; Problem_S.Formulation = NULL ; Problem_S.JacobianMethod = NULL ; Problem_S.IntegrationMethod = NULL ; Problem_S.Resolution = NULL ; Problem_S.PostProcessing = NULL ; Problem_S.PostOperation = NULL ; } // TODO ! void Free_Group(struct Group* a){} void Free_Expression(struct Expression* a){} void Free_FunctinSpace(struct FunctionSpace* a){} void Free_Constraint(struct Constraint* a){} void Free_Formulation(struct Formuation* a){} void Free_JacobianMethod(struct JacobianMethod* a){} void Free_IntegrationMethod(struct IntegrationMethod* a){} void Free_Resolution(struct Resolution* a){} void Free_PostProcessing(struct PostProcessing* a){} void Free_PostOperation(struct PostOperation* a){} void Free_ProblemStructure() { if(Problem_S.Group){ for(int i = 0; i < List_Nbr(Problem_S.Group); i++) Free_Group((Group*)List_Pointer(Problem_S.Group, i)); List_Delete(Problem_S.Group); } if(Problem_S.Expression){ for(int i = 0; i < List_Nbr(Problem_S.Expression); i++) Free_Expression((Expression*)List_Pointer(Problem_S.Expression, i)); List_Delete(Problem_S.Expression); } if(Problem_S.FunctionSpace){ for(int i = 0; i < List_Nbr(Problem_S.FunctionSpace); i++) Free_FunctinSpace((FunctionSpace*)List_Pointer(Problem_S.FunctionSpace, i)); List_Delete(Problem_S.FunctionSpace); } if(Problem_S.Constraint){ for(int i = 0; i < List_Nbr(Problem_S.Constraint); i++) Free_Constraint((Constraint*)List_Pointer(Problem_S.Constraint, i)); List_Delete(Problem_S.Constraint); } if(Problem_S.Formulation){ for(int i = 0; i < List_Nbr(Problem_S.Formulation); i++) Free_Formulation((Formuation*)List_Pointer(Problem_S.Formulation, i)); List_Delete(Problem_S.Formulation); } if(Problem_S.JacobianMethod){ for(int i = 0; i < List_Nbr(Problem_S.JacobianMethod); i++) Free_JacobianMethod((JacobianMethod*)List_Pointer(Problem_S.JacobianMethod, i)); List_Delete(Problem_S.JacobianMethod); } if(Problem_S.IntegrationMethod){ for(int i = 0; i < List_Nbr(Problem_S.IntegrationMethod); i++) Free_IntegrationMethod((IntegrationMethod*)List_Pointer(Problem_S.IntegrationMethod, i)); List_Delete(Problem_S.IntegrationMethod); } if(Problem_S.Resolution){ for(int i = 0; i < List_Nbr(Problem_S.Resolution); i++) Free_Resolution((Resolution*)List_Pointer(Problem_S.Resolution, i)); List_Delete(Problem_S.Resolution); } if(Problem_S.PostProcessing){ for(int i = 0; i < List_Nbr(Problem_S.PostProcessing); i++) Free_PostProcessing((PostProcessing*)List_Pointer(Problem_S.PostProcessing, i)); List_Delete(Problem_S.PostProcessing); } if(Problem_S.PostOperation){ for(int i = 0; i < List_Nbr(Problem_S.PostOperation); i++) Free_PostOperation((PostOperation*)List_Pointer(Problem_S.PostOperation, i)); List_Delete(Problem_S.PostOperation); } Init_ProblemStructure(); } std::string Get_AbsolutePath(const char *name) { char AbsPath[2048]; strcpy(AbsPath, getdp_yyname); int i = strlen(getdp_yyname) - 1; while(i >= 0 && getdp_yyname[i] != '/' && getdp_yyname[i] != '\\') i--; AbsPath[i+1] = '\0'; strcat(AbsPath, name); return std::string(AbsPath); } void Read_ProblemStructure(const char *name) { int Last_yylinenum = getdp_yylinenum; std::string Last_yyname = std::string(getdp_yyname); int Last_ErrorLevel = getdp_yyerrorlevel; int Last_yyincludenum = getdp_yyincludenum; char AbsPath[2048]; int i; if((strlen(name) > 0 && (name[0] == '/' || name[0] == '\\')) || (strlen(name) > 3 && name[1] == ':' && (name[2] == '\\' || name[2] == '/'))){ // name is an absolute path strcpy(AbsPath, name); } else{ strcpy(AbsPath, getdp_yyname); i = strlen(getdp_yyname) - 1; while(i >= 0 && getdp_yyname[i] != '/' && getdp_yyname[i] != '\\') i--; AbsPath[i+1] = '\0'; strcat(AbsPath, name); } Message::Info("Loading problem definition '%s'", AbsPath); // opening the file in text mode messes up the loops (they use // fsetpos/fgetpos) on Windows without Cygwin; not sure why, but // opening the file in binary mode fixes the problem if(!(getdp_yyin = FOpen(AbsPath, "rb"))){ Message::Error("Unable to open file '%s'", AbsPath); return; } getdp_yyerrorlevel = 0; getdp_yylinenum = 1; getdp_yyincludenum=0; strcpy(getdp_yyname, AbsPath); getdp_yyrestart(getdp_yyin); getdp_yyparse(); fclose(getdp_yyin); if(getdp_yyerrorlevel) return; while(getdp_yyincludenum > 0){ Read_ProblemStructure(getdp_yyincludename); getdp_yyin = FOpen(getdp_yyname, "rb"); // same comment as above getdp_yyrestart(getdp_yyin); for(i = 0; i < getdp_yylinenum; i++) fgets(AbsPath, 2048, getdp_yyin); getdp_yylinenum++; getdp_yyparse(); fclose(getdp_yyin); if(getdp_yyerrorlevel) return; } getdp_yylinenum = Last_yylinenum; strcpy(getdp_yyname, Last_yyname.c_str()); getdp_yyerrorlevel = Last_ErrorLevel; getdp_yyincludenum = Last_yyincludenum; } void Finalize_ProblemStructure() { // Here we should parse any ONELAB-defined functions (+ their context) } char *Get_ExpressionName(int Index) { return(((struct Expression *)List_Pointer(Problem_S.Expression, Index))->Name); } void Print_WholeQuantity(List_T *WholeQuantity, List_T *DQ_L) { int j, k; struct WholeQuantity *WQ; WQ = (struct WholeQuantity*)List_Pointer(WholeQuantity, 0); for (k = 0; k < List_Nbr(WholeQuantity); k++) { switch ((WQ+k)->Type) { case WQ_OPERATORANDQUANTITY : Message::Check(" {%s %s}", Get_StringForDefine (Operator_Type, (WQ+k)->Case.OperatorAndQuantity.TypeOperator), ((struct DefineQuantity *) List_Pointer(DQ_L, (WQ+k)->Case.OperatorAndQuantity.Index)) ->Name); break; case WQ_OPERATORANDQUANTITYEVAL : Message::Check(" {%s %s} ExplicitEvaluation", Get_StringForDefine (Operator_Type, (WQ+k)->Case.OperatorAndQuantity.TypeOperator), ((struct DefineQuantity *) List_Pointer(DQ_L, (WQ+k)->Case.OperatorAndQuantity.Index)) ->Name); break; case WQ_BINARYOPERATOR : switch ((WQ+k)->Case.Operator.TypeOperator) { case OP_PLUS : Message::Check(" +"); break; case OP_MINUS : Message::Check(" -"); break; case OP_TIME : Message::Check(" *"); break; case OP_DIVIDE : Message::Check(" /"); break; case OP_MODULO : Message::Check(" %%"); break; case OP_POWER : Message::Check(" ^"); break; case OP_CROSSPRODUCT : Message::Check(" x"); break; case OP_LESS : Message::Check(" <"); break; case OP_GREATER : Message::Check(" >"); break; case OP_LESSOREQUAL : Message::Check(" <="); break; case OP_GREATEROREQUAL : Message::Check(" >="); break; case OP_EQUAL : Message::Check(" =="); break; case OP_NOTEQUAL : Message::Check(" !="); break; default : Message::Check(" UnknownBinaryOperator[]"); break; } break; case WQ_UNARYOPERATOR : switch ((WQ+k)->Case.Operator.TypeOperator) { case OP_NEG : Message::Check(" -(unary)"); break; case OP_NOT : Message::Check(" !"); break; default : Message::Check(" UnknownUnaryOperator[]"); break; } break; case WQ_EXPRESSION : Message::Check(" %s[]", ((struct Expression *) List_Pointer(Problem_S.Expression, (WQ+k)->Case.Expression.Index))->Name); break; case WQ_BUILTINFUNCTION : case WQ_EXTERNBUILTINFUNCTION : #if defined(HAVE_LEGACY) Message::Check(" %s", Get_StringForFunction2Nbr(F_Function, (WQ+k)->Case.Function.Fct)); #endif if ((WQ+k)->Type == WQ_EXTERNBUILTINFUNCTION) Message::Check("[.]"); if ((WQ+k)->Type == WQ_BUILTINFUNCTION) Message::Check("[]"); if ((WQ+k)->Case.Function.NbrParameters) { Message::Check("{"); for (j = 0; j < (WQ+k)->Case.Function.NbrParameters; j++) { if (j) Message::Check(","); Message::Check(" %.10g", (WQ+k)->Case.Function.Para[j]); } Message::Check(" }"); } break; case WQ_CONSTANT : Message::Check(" %.8g", (WQ+k)->Case.Constant); break; case WQ_TIMEDERIVATIVE : Message::Check(" Dt["); Print_WholeQuantity((WQ+k)->Case.TimeDerivative.WholeQuantity, DQ_L); Message::Check(" ]"); break; case WQ_TRACE : Message::Check(" Trace["); Print_WholeQuantity((WQ+k)->Case.Trace.WholeQuantity, DQ_L); Message::Check(" , %s ]", ((struct Group*) List_Pointer(Problem_S.Group, (WQ+k)->Case.Trace.InIndex))->Name); break; case WQ_CAST : if(!(WQ+k)->Case.Cast.NbrHar) Message::Check(" <%s>[", ((struct FunctionSpace *) List_Pointer(Problem_S.FunctionSpace, (WQ+k)->Case.Cast.FunctionSpaceIndexForType))->Name); else Message::Check(" ["); Print_WholeQuantity((WQ+k)->Case.Cast.WholeQuantity, DQ_L); Message::Check(" ]"); break; case WQ_CURRENTVALUE : Message::Check(" $%s", Get_StringForPointer(Current_Value, (void *)((WQ+k)->Case.CurrentValue.Value))); break; case WQ_ARGUMENT : Message::Check(" $%d", (WQ+k)->Case.Argument.Index); break; case WQ_TEST : Message::Check(" ?"); Print_WholeQuantity((WQ+k)->Case.Test.WholeQuantity_True , DQ_L); Message::Check(" :"); Print_WholeQuantity((WQ+k)->Case.Test.WholeQuantity_False, DQ_L); break; case WQ_SAVEVALUE : Message::Check(" ->#%d", (WQ+k)->Case.SaveValue.Index + 1); break; case WQ_VALUESAVED : Message::Check(" #%d", (WQ+k)->Case.ValueSaved.Index + 1); break; case WQ_SHOWVALUE : Message::Check(" ->show with prefix #%d", (WQ+k)->Case.ShowValue.Index + 1); break; default : Message::Check(" ???"); break; } } } void Print_Group() { int i, Nbr, j; struct Group *GR; Nbr = List_Nbr(Problem_S.Group); Message::Check("Group { /* nbr = %d */\n", Nbr); Message::Check("\n"); for (i = 0; i < Nbr; i++) { GR = (struct Group*)List_Pointer(Problem_S.Group, i); Message::Check(" %s = %s [", GR->Name, Get_StringForDefine(FunctionForGroup_Type, GR->FunctionType)); if (GR->InitialList != NULL) { Message::Check(" {"); for (j = 0; j < List_Nbr(GR->InitialList); j++) Message::Check(" %d", *((int *)List_Pointer(GR->InitialList, j)) ); Message::Check(" }"); } else Message::Check(" All"); if (GR->InitialSuppList != NULL) { if (GR->SuppListType != SUPPLIST_INSUPPORT) { Message::Check(", %s {", Get_StringForDefine(FunctionForGroup_SuppList, GR->SuppListType)); for (j = 0; j < List_Nbr(GR->InitialSuppList); j++) Message::Check(" %d", *((int *)List_Pointer(GR->InitialSuppList, j)) ); Message::Check(" }"); } else { Message::Check(", %s", Get_StringForDefine(FunctionForGroup_SuppList, GR->SuppListType)); Message::Check(" %s", ((struct Group *) List_Pointer(Problem_S.Group, *((int *)List_Pointer(GR->InitialSuppList, 0)))) ->Name); } } Message::Check(" ]"); if (GR->Type == MOVINGBAND2D) { Message::Check(" = MovingBand2D [ {"); for (j = 0; j < List_Nbr(GR->MovingBand2D->InitialList1); j++) Message::Check(" %d", *((int *)List_Pointer(GR->MovingBand2D->InitialList1, j)) ); Message::Check(" } , {"); for (j = 0; j < List_Nbr(GR->MovingBand2D->InitialList2); j++) Message::Check(" %d", *((int *)List_Pointer(GR->MovingBand2D->InitialList2, j)) ); Message::Check(" } ]"); } Message::Check("; /* Num %d */\n", i); } Message::Check("\n"); Message::Check("}\n"); } void Print_Expression() { int i, Nbr, j; struct Expression *EX; struct ExpressionPerRegion *EXPR; Nbr = List_Nbr(Problem_S.Expression); Message::Check("Function { /* nbr = %d */\n", Nbr); Message::Check("\n"); for (i = 0; i < Nbr; i++) { EX = (struct Expression*)List_Pointer(Problem_S.Expression, i); switch (EX->Type) { case CONSTANT : Message::Check(" %s[] = %.10g;\n", EX->Name, EX->Case.Constant); break; case WHOLEQUANTITY : Message::Check(" %s[] = ", EX->Name); Print_WholeQuantity(EX->Case.WholeQuantity, NULL); Message::Check(";\n"); break; case PIECEWISEFUNCTION : for (j = 0; j < List_Nbr(EX->Case.PieceWiseFunction.ExpressionPerRegion); j++) { EXPR = (struct ExpressionPerRegion*) List_Pointer(EX->Case.PieceWiseFunction.ExpressionPerRegion, j); Message::Check(" %s[%d] = Exp[%s];\n", EX->Name, EXPR->RegionIndex, Get_ExpressionName(EXPR->ExpressionIndex)); } if (!List_Nbr(EX->Case.PieceWiseFunction.ExpressionPerRegion)) Message::Check(" DefineFunction[ %s ];\n", EX->Name); break; case UNDEFINED_EXP : Message::Check(" DefineFunction[ %s ];\n", EX->Name); break; default : Message::Check("???;\n"); break; } } Message::Check("\n"); Message::Check("}\n"); } void Print_Network(struct MultiConstraintPerRegion *MCPR_P) { int i, j; struct ConstraintActive *CA; CA = MCPR_P->Active; Message::Check("NbrNode = %d, NbrBranch = %d\n", CA->Case.Network.NbrNode, CA->Case.Network.NbrBranch); Message::Check("\n"); Message::Check("MatNode (NbrNode x NbrBranch):\n"); for (i = 0; i < CA->Case.Network.NbrNode; i++) { for (j = 0; j < CA->Case.Network.NbrBranch; j++) { Message::Check("%2d ", CA->Case.Network.MatNode[i][j]); } Message::Check("\n"); } Message::Check("\n"); Message::Check("MatLoop (NbrLoop x NbrBranch):\n"); for (i = 0; i < CA->Case.Network.NbrLoop; i++) { for (j = 0; j < CA->Case.Network.NbrBranch; j++) { Message::Check("%2d ", CA->Case.Network.MatLoop[i][j]); } Message::Check("\n"); } } void Print_Constraint() { int i, Nbr, j, Nbrj, k, Nbrk; struct Constraint *CO; struct ConstraintPerRegion *CPR; struct MultiConstraintPerRegion MCPR_S; Nbr = List_Nbr(Problem_S.Constraint); Message::Check("Constraint { /* nbr = %d */\n", Nbr); Message::Check("\n"); for (i = 0; i < Nbr; i++) { Message::Check(" /* Num : %d */\n", i); CO = (struct Constraint*)List_Pointer(Problem_S.Constraint, i); Message::Check(" { Name %s; Type %s;\n", CO->Name, Get_StringForDefine(Constraint_Type, CO->Type)); if (CO->Type == NETWORK){ Nbrk = List_Nbr(CO->MultiConstraintPerRegion); for (k = 0; k < Nbrk; k++) { List_Read(CO->MultiConstraintPerRegion, k, &MCPR_S); Message::Check(" Case %s {\n", MCPR_S.Name); Nbrj = List_Nbr(MCPR_S.ConstraintPerRegion); for (j = 0; j < Nbrj; j++) { CPR = (struct ConstraintPerRegion*) List_Pointer(MCPR_S.ConstraintPerRegion, j); Message::Check(" { Region %s;", ((struct Group *) List_Pointer(Problem_S.Group, CPR->RegionIndex))->Name); Message::Check(" Branch { %d, %d };", CPR->Case.Network.Node1, CPR->Case.Network.Node2); Message::Check(" }\n"); } #if defined(HAVE_LEGACY) if (!MCPR_S.Active) MCPR_S.Active = Generate_Network(MCPR_S.Name, MCPR_S.ConstraintPerRegion); #endif Print_Network(&MCPR_S); } } else { Message::Check(" Case {\n"); Nbrj = List_Nbr(CO->ConstraintPerRegion); for (j = 0; j < Nbrj; j++) { CPR = (struct ConstraintPerRegion*)List_Pointer(CO->ConstraintPerRegion, j); Message::Check(" { Region %s;", ((struct Group *) List_Pointer(Problem_S.Group, CPR->RegionIndex))->Name); if (CPR->SubRegionIndex >= 0) Message::Check(" SubRegion %s;", ((struct Group *) List_Pointer(Problem_S.Group, CPR->SubRegionIndex))->Name); if (CPR->Type != CO->Type) Message::Check(" Type %s;", Get_StringForDefine(Constraint_Type, CPR->Type)); switch (CPR->Type) { case ASSIGN : case INIT : Message::Check(" Value Exp[%s];", Get_ExpressionName(CPR->Case.Fixed.ExpressionIndex)); break; case ASSIGNFROMRESOLUTION : case INITFROMRESOLUTION : Message::Check(" NameOfResolution %s;", CPR->Case.Solve.ResolutionName); break; } if (CPR->TimeFunctionIndex >= 0) Message::Check(" TimeFunction Exp[%s];", Get_ExpressionName(CPR->TimeFunctionIndex)); Message::Check(" }\n"); } } Message::Check(" }\n"); Message::Check(" }\n"); } Message::Check("\n"); Message::Check("}\n"); } void Print_Jacobian() { int i, Nbr, j, Nbrj, k; struct JacobianMethod *JM; struct JacobianCase *JC; Nbr = List_Nbr(Problem_S.JacobianMethod); Message::Check("Jacobian { /* nbr = %d */\n", Nbr); Message::Check("\n"); for (i = 0; i < Nbr; i++) { Message::Check(" /* Num : %d */\n", i); JM = (struct JacobianMethod*)List_Pointer(Problem_S.JacobianMethod, i); Message::Check(" { Name %s;\n", JM->Name); Message::Check(" Case {\n"); Nbrj = List_Nbr(JM->JacobianCase); for (j = 0; j < Nbrj; j++) { JC = (struct JacobianCase*)List_Pointer(JM->JacobianCase, j); Message::Check(" { Region "); if (JC->RegionIndex >= 0) Message::Check("%s;", ((struct Group *) List_Pointer(Problem_S.Group, JC->RegionIndex))->Name); else Message::Check("All;"); Message::Check(" Jacobian %s", Get_StringForDefine1Nbr(Jacobian_Type, JC->TypeJacobian)); if (JC->NbrParameters) { for (k = 0; k < JC->NbrParameters; k++) { if (k) Message::Check(","); else Message::Check(" {"); Message::Check(" %.10g", JC->Para[k]); } Message::Check(" }"); } Message::Check("; }\n"); } Message::Check(" }\n"); Message::Check(" }\n"); } Message::Check("\n"); Message::Check("}\n"); } void Print_Integration() { int i, j, k, Nbrm, Nbrc, Nbrq; struct IntegrationMethod *IM; struct IntegrationCase *IC; struct Quadrature *Q; Nbrm = List_Nbr(Problem_S.IntegrationMethod); Message::Check("Integration { /* nbr = %d */\n", Nbrm); Message::Check("\n"); for (i = 0; i < Nbrm; i++) { Message::Check(" /* Num : %d */\n", i); IM = (struct IntegrationMethod*)List_Pointer(Problem_S.IntegrationMethod, i); Message::Check(" { Name %s; \n", IM->Name); if(IM->CriterionIndex>=0) Message::Check(" Criterion Exp[%s]; \n", Get_ExpressionName(IM->CriterionIndex)); Nbrc = List_Nbr(IM->IntegrationCase); Message::Check(" Case {"); Message::Check(" /* nbr = %d */\n", Nbrc); for (j = 0; j < Nbrc; j++) { IC = (struct IntegrationCase*)List_Pointer(IM->IntegrationCase, j); Message::Check(" { Type %s;", Get_StringForDefine(Integration_Type, IC->Type)); switch (IC->Type) { case GAUSS : Message::Check("\n"); Message::Check(" Case {\n"); Nbrq = List_Nbr(IC->Case); for (k = 0; k < Nbrq; k++) { Q = (struct Quadrature*)List_Pointer(IC->Case, k); Message::Check(" { GeoElement %s; NumberOfPoints %d; }\n", Get_StringForDefine(Element_Type, Q->ElementType), Q->NumberOfPoints); } Message::Check(" }\n"); Message::Check(" }\n"); break; default : Message::Check(" }\n"); break; } } Message::Check(" }\n"); Message::Check(" }\n"); } Message::Check("\n"); Message::Check("}\n"); } void Print_FunctionSpace() { struct FunctionSpace *FS; struct BasisFunction *BF; struct SubSpace *SS; struct GlobalQuantity *GQ; struct ConstraintInFS *CO; List_T *BF_L, *SS_L, *GQ_L, *CO_L; int i0, i, Nbr0, Nbr, j, Nbrj; Nbr0 = List_Nbr(Problem_S.FunctionSpace); Message::Check("FunctionSpace { /* nbr = %d */\n", Nbr0); Message::Check("\n"); for (i0=0; i0BasisFunction; SS_L = FS->SubSpace; GQ_L = FS->GlobalQuantity; CO_L = FS->Constraint; Message::Check(" { Name %s; Type %s;", FS->Name, Get_StringForDefine(Field_Type, FS->Type)); Message::Check("\n"); Nbr = List_Nbr(BF_L); if (Nbr > 0) { Message::Check(" BasisFunction {\n"); BF = (struct BasisFunction*)List_Pointer(BF_L, 0); for (i=0; iNum); #if defined(HAVE_LEGACY) Message::Check(" Name %s; NameOfCoef %s; Function %s;\n", BF->Name, BF->NameOfCoef, Get_StringFor3Function3Nbr(BF_Function, BF->Function)); #endif if (BF->SubFunction) { Message::Check(" SubFunction {"); Nbrj = List_Nbr(BF->SubFunction); for (j=0; jSubFunction, j))))->Name); Message::Check(" };\n"); } if (BF->SubdFunction) { Message::Check(" SubdFunction {"); Nbrj = List_Nbr(BF->SubdFunction); for (j=0; jSubdFunction, j))))->Name); Message::Check(" };\n"); } Message::Check(" Support %s;", (BF->SupportIndex >=0)? ((struct Group *)List_Pointer(Problem_S.Group, BF->SupportIndex)) ->Name : "?"); Message::Check(" Entity %s;\n", (BF->EntityIndex >=0)? ((struct Group *)List_Pointer(Problem_S.Group, BF->EntityIndex)) ->Name : "?"); BF += 1; } Message::Check(" }\n"); } BF = (Nbr>0)? (struct BasisFunction*)List_Pointer(BF_L, 0) : NULL; Nbr = List_Nbr(SS_L); if (Nbr > 0) { Message::Check(" SubSpace {\n"); SS = (struct SubSpace*)List_Pointer(SS_L, 0); for (i=0; iName); Nbrj = List_Nbr(SS->BasisFunction); for (j=0; jBasisFunction, j)))) ->Name, *((int *)List_Pointer(SS->BasisFunction, j))); Message::Check(" };\n"); SS += 1; } Message::Check(" }\n"); } Nbr = List_Nbr(GQ_L); if (Nbr > 0) { Message::Check(" GlobalQuantity {\n"); GQ = (struct GlobalQuantity*)List_Pointer(GQ_L, 0); for (i=0; iNum); Message::Check(" Name %s; Type %s;", GQ->Name, Get_StringForDefine(GlobalQuantity_Type, GQ->Type)); Message::Check(" NameOfCoef %s;\n", ((struct BasisFunction *) List_Pointer(BF_L, GQ->ReferenceIndex))->NameOfCoef); GQ += 1; } Message::Check(" }\n"); } Nbr = List_Nbr(CO_L); if (Nbr > 0) { Message::Check(" Constraint {\n"); CO = (struct ConstraintInFS*)List_Pointer(CO_L, 0); for (i=0; iQuantityType == LOCALQUANTITY) Message::Check("%s;", ((struct BasisFunction *) List_Pointer(BF_L, CO->ReferenceIndex))->NameOfCoef); else if (CO->QuantityType == GLOBALQUANTITY) Message::Check("%s;", ((struct GlobalQuantity *) List_Pointer(GQ_L, CO->ReferenceIndex))->Name); else Message::Check("?;"); Message::Check(" // Entity %s;\n", ((struct Group *)List_Pointer(Problem_S.Group, CO->EntityIndex)) ->Name ); switch(CO->ConstraintPerRegion->Type) { case ASSIGN : case INIT : Message::Check(" // Value Exp[%s];", Get_ExpressionName (CO->ConstraintPerRegion->Case.Fixed.ExpressionIndex)); break; case ASSIGNFROMRESOLUTION : case INITFROMRESOLUTION : Message::Check(" // Resolution %s;", CO->ConstraintPerRegion->Case.Solve.ResolutionName); break; } if (CO->ConstraintPerRegion->TimeFunctionIndex >= 0) Message::Check(" TimeFunction Exp[%s];", Get_ExpressionName(CO->ConstraintPerRegion->TimeFunctionIndex)); Message::Check("\n"); CO += 1; } Message::Check(" }\n"); } Message::Check(" }\n"); } Message::Check("\n"); Message::Check("}\n"); } void Print_Formulation() { struct Formulation *FO; struct DefineQuantity *DQ; struct EquationTerm *FE; struct GlobalEquationTerm *GET; List_T *DQ_L, *FE_L; int i, Nbr, j, Nbrj, k, Nbrk; Nbr = List_Nbr(Problem_S.Formulation); Message::Check("Formulation { /* nbr = %d */\n", Nbr); Message::Check("\n"); for (i = 0; i < Nbr; i++) { Message::Check(" /* Num : %d */\n", i); FO = (struct Formulation*)List_Pointer(Problem_S.Formulation, i); Message::Check(" { Name %s; Type %s;\n", FO->Name, Get_StringForDefine(Formulation_Type, FO->Type)); DQ_L = FO->DefineQuantity; FE_L = FO->Equation; Message::Check(" Quantity {\n"); Nbrj = List_Nbr(DQ_L); for (j=0; jName, Get_StringForDefine(DefineQuantity_Type, DQ->Type), (DQ->FunctionSpaceIndex < 0) ? "?" : ((struct FunctionSpace *) List_Pointer(Problem_S.FunctionSpace, DQ->FunctionSpaceIndex))->Name); if (DQ->IndexInFunctionSpace) { if (DQ->Type == GLOBALQUANTITY) Message::Check("[%s]", ((struct GlobalQuantity *) List_Pointer (((struct FunctionSpace *) List_Pointer(Problem_S.FunctionSpace, DQ->FunctionSpaceIndex)) ->GlobalQuantity, *((int *)List_Pointer(DQ->IndexInFunctionSpace, 0))))->Name); else if (DQ->Type == LOCALQUANTITY) { Message::Check("["); Nbrk = List_Nbr(DQ->IndexInFunctionSpace); for (k=0; kIndexInFunctionSpace, k))); Message::Check("]"); } } Message::Check(";"); if (DQ->Type == INTEGRALQUANTITY) { Message::Check("\n"); Message::Check(" Integration %s;\n", ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, DQ->IntegralQuantity.IntegrationMethodIndex))->Name); Message::Check(" Jacobian %s;", ((struct JacobianMethod *) List_Pointer(Problem_S.JacobianMethod, DQ->IntegralQuantity.JacobianMethodIndex))->Name); } Message::Check(" }\n"); } Message::Check(" }\n"); Message::Check(" Equation {\n"); Nbrj = List_Nbr(FE_L); for (j=0; jType == GALERKIN || FE->Type == DERHAM) { if(FE->Type == GALERKIN) Message::Check(" Galerkin { Density [ ... ];\n"); if(FE->Type == DERHAM) Message::Check(" deRham { Density [ ... ];\n"); Message::Check(" In %s;\n", ((struct Group *) List_Pointer(Problem_S.Group, FE->Case.LocalTerm.InIndex))->Name ); Message::Check(" Jacobian %s; \n", ((struct JacobianMethod *) List_Pointer(Problem_S.JacobianMethod, FE->Case.LocalTerm.JacobianMethodIndex))->Name ); Message::Check(" Integration %s; }\n", ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, FE->Case.LocalTerm.IntegrationMethodIndex))->Name ); Message::Check(" /* Inventaire des DQ (%d) [%d] :", FE->Case.LocalTerm.Term.NbrQuantityIndex, FE->Case.LocalTerm.Term.QuantityIndexPost); for (k = 0; k < FE->Case.LocalTerm.Term.NbrQuantityIndex; k++) Message::Check(" {%s}", ((struct DefineQuantity *) List_Pointer (DQ_L, FE->Case.LocalTerm.Term.QuantityIndexTable[k]))->Name); Message::Check(" */\n"); Message::Check(" /* WholeQuantity (%d) :", List_Nbr(FE->Case.LocalTerm.Term.WholeQuantity)); Print_WholeQuantity(FE->Case.LocalTerm.Term.WholeQuantity, DQ_L); Message::Check(" */\n"); } else if (FE->Type == GLOBALTERM ) { Message::Check(" GlobalTerm { [ ... ];\n"); Message::Check(" In %s;\n", ((struct Group *) List_Pointer(Problem_S.Group, FE->Case.GlobalTerm.InIndex))->Name ); Message::Check(" /* Inventaire des DQ (%d) [%d,%d] :", FE->Case.GlobalTerm.Term.NbrQuantityIndex, FE->Case.GlobalTerm.Term.DefineQuantityIndexDof, FE->Case.GlobalTerm.Term.DefineQuantityIndexEqu); for (k = 0; k < FE->Case.GlobalTerm.Term.NbrQuantityIndex; k++) Message::Check(" {%s}", ((struct DefineQuantity *) List_Pointer (DQ_L, FE->Case.GlobalTerm.Term.QuantityIndexTable[k]))->Name); Message::Check(" */\n"); Message::Check(" /* WholeQuantity (%d) :", List_Nbr(FE->Case.GlobalTerm.Term.WholeQuantity)); Print_WholeQuantity(FE->Case.GlobalTerm.Term.WholeQuantity, DQ_L); Message::Check(" */\n"); } else if (FE->Type == GLOBALEQUATION) { Message::Check(" GlobalEquation { Type %s; UsingConstraint %s;\n", Get_StringForDefine(Constraint_Type, FE->Case.GlobalEquation.Type), ((struct Constraint *) List_Pointer(Problem_S.Constraint, FE->Case.GlobalEquation.ConstraintIndex))->Name); Nbrk = List_Nbr(FE->Case.GlobalEquation.GlobalEquationTerm); for (k = 0; k < Nbrk; k++) { GET = (struct GlobalEquationTerm*) List_Pointer(FE->Case.GlobalEquation.GlobalEquationTerm, k); Message::Check(" { Node {%s}; Loop {%s}; Equation {%s};", ((struct DefineQuantity *) List_Pointer(DQ_L, GET->DefineQuantityIndexNode))->Name, ((struct DefineQuantity *) List_Pointer(DQ_L, GET->DefineQuantityIndexLoop))->Name, ((struct DefineQuantity *) List_Pointer(DQ_L, GET->DefineQuantityIndexEqu))->Name); Message::Check(" In %s; }\n", ((struct Group *) List_Pointer(Problem_S.Group, GET->InIndex))->Name); } } } Message::Check(" }\n"); Message::Check(" }\n"); } Message::Check("\n"); Message::Check("}\n"); } void Print_Operation(struct Resolution *RE, List_T *Operation_L) { struct Operation *OPE; int i, j, Nbrj; static int NbrBlk = -1; NbrBlk++; Nbrj = List_Nbr(Operation_L); for (j=0; jType) { case OPERATION_GENERATE : case OPERATION_GENERATEONLY : case OPERATION_SOLVE : case OPERATION_GENERATEJAC : case OPERATION_SOLVEJAC : case OPERATION_SOLVENL : case OPERATION_GENERATESEPARATE : case OPERATION_INITSOLUTION : case OPERATION_SAVESOLUTION : case OPERATION_SAVESOLUTIONS : case OPERATION_READSOLUTION : case OPERATION_TRANSFERSOLUTION : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" %s [%s];\n", Get_StringForDefine(Operation_Type, OPE->Type), ((struct DefineSystem *) List_Pointer(RE->DefineSystem, OPE->DefineSystemIndex))->Name); break; case OPERATION_UPDATE : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" Update [ %s, Exp[%s] ];\n", ((struct DefineSystem *) List_Pointer(RE->DefineSystem, OPE->DefineSystemIndex))->Name, Get_ExpressionName(OPE->Case.Update.ExpressionIndex)); break; case OPERATION_SELECTCORRECTION : for (i=0 ; i<2*NbrBlk ; i++) Message::Check(" "); Message::Check(" SelectCorrection [ %s, %d ] ;\n", ((struct DefineSystem *) List_Pointer(RE->DefineSystem, OPE->DefineSystemIndex))->Name, OPE->Case.SelectCorrection.Iteration) ; break ; case OPERATION_ADDCORRECTION : for (i=0 ; i<2*NbrBlk ; i++) Message::Check(" "); Message::Check(" AddCorrection [ %s, %g ] ;\n", ((struct DefineSystem *) List_Pointer(RE->DefineSystem, OPE->DefineSystemIndex))->Name, OPE->Case.AddCorrection.Alpha) ; break ; case OPERATION_UPDATECONSTRAINT : for (i=0 ; i<2*NbrBlk ; i++) Message::Check(" "); Message::Check(" UpdateConstraint [ %s ] ;\n", ((struct DefineSystem *) List_Pointer(RE->DefineSystem, OPE->DefineSystemIndex))->Name) ; break ; case OPERATION_FOURIERTRANSFORM : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" FourierTransform [ %s, %s, {...} ];\n", ((struct DefineSystem *) List_Pointer(RE->DefineSystem, OPE->Case.FourierTransform.DefineSystemIndex[0]))->Name, ((struct DefineSystem *) List_Pointer(RE->DefineSystem, OPE->Case.FourierTransform.DefineSystemIndex[1]))->Name); break; case OPERATION_TIMELOOPTHETA : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" TimeLoopTheta [ %.10g, %.10g, Exp[%s], Exp[%s] ] {\n", OPE->Case.TimeLoopTheta.Time0, OPE->Case.TimeLoopTheta.TimeMax, Get_ExpressionName(OPE->Case.TimeLoopTheta.DTimeIndex), Get_ExpressionName(OPE->Case.TimeLoopTheta.ThetaIndex)); Print_Operation(RE, OPE->Case.TimeLoopTheta.Operation); for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" }\n"); break; case OPERATION_TIMELOOPNEWMARK : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" TimeLoopNewmark [ %.10g, %.10g, Exp[%s], %.10g, %.10g ] {\n", OPE->Case.TimeLoopNewmark.Time0, OPE->Case.TimeLoopNewmark.TimeMax, Get_ExpressionName(OPE->Case.TimeLoopNewmark.DTimeIndex), OPE->Case.TimeLoopNewmark.Beta, OPE->Case.TimeLoopNewmark.Gamma); Print_Operation(RE, OPE->Case.TimeLoopNewmark.Operation); for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" }\n"); break; case OPERATION_ITERATIVELOOP : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" IterativeLoop [ %d, %.10g, Exp[%s] ] {\n", OPE->Case.IterativeLoop.NbrMaxIteration, OPE->Case.IterativeLoop.Criterion, Get_ExpressionName(OPE->Case.IterativeLoop.RelaxationFactorIndex)); Print_Operation(RE, OPE->Case.IterativeLoop.Operation); for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" }\n"); break; case OPERATION_LANCZOS : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" Lanczos [ %s, %d, { ... } , %.10g ];\n", ((struct DefineSystem *) List_Pointer(RE->DefineSystem, OPE->DefineSystemIndex))->Name, OPE->Case.Lanczos.Size, OPE->Case.Lanczos.Shift); break; case OPERATION_EIGENSOLVE : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" EigenSolve [ %s, %d, %.10g , %.10g ];\n", ((struct DefineSystem *) List_Pointer(RE->DefineSystem, OPE->DefineSystemIndex))->Name, OPE->Case.EigenSolve.NumEigenvalues, OPE->Case.EigenSolve.Shift_r, OPE->Case.EigenSolve.Shift_i); break; case OPERATION_POSTOPERATION : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" PostOperation [ ... ];\n"); break; case OPERATION_EVALUATE : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" Evaluate [ Exp[%s] ];\n", Get_ExpressionName(OPE->Case.Evaluate.ExpressionIndex)); break; case OPERATION_SETTIME : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" SetTime [ Exp[%s] ];\n", Get_ExpressionName(OPE->Case.SetTime.ExpressionIndex)); break; case OPERATION_SETFREQUENCY : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" SetFrequency [ %s, Exp[%s] ];\n", ((struct DefineSystem *) List_Pointer(RE->DefineSystem, OPE->DefineSystemIndex))->Name, Get_ExpressionName(OPE->Case.SetFrequency.ExpressionIndex)); break; case OPERATION_BREAK : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" Break;\n"); break; case OPERATION_SYSTEMCOMMAND : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" SystemCommand \" %s \";\n", OPE->Case.SystemCommand.String); break; case OPERATION_TEST : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" If [ Exp[%s] ] {\n", Get_ExpressionName(OPE->Case.Test.ExpressionIndex)); Print_Operation(RE, OPE->Case.Test.Operation_True); for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" }\n"); for (i=0; i<2*NbrBlk; i++) Message::Check(" "); if(OPE->Case.Test.Operation_False){ Message::Check(" Else {\n"); Print_Operation(RE, OPE->Case.Test.Operation_False); Message::Check(" }\n"); } break; case OPERATION_CHANGEOFCOORDINATES : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" ChangeOfCoordinates [ %s, Exp[%s] ];\n", ((struct Group *) List_Pointer(Problem_S.Group, OPE->Case.ChangeOfCoordinates.GroupIndex))->Name, Get_ExpressionName(OPE->Case.ChangeOfCoordinates.ExpressionIndex)); break; case OPERATION_INIT_MOVINGBAND2D : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" Init_MovingBand2D [ %s ];\n", ((struct Group *) List_Pointer(Problem_S.Group, OPE->Case.Init_MovingBand2D.GroupIndex))->Name); break; case OPERATION_MESH_MOVINGBAND2D : for (i=0; i<2*NbrBlk; i++) Message::Check(" "); Message::Check(" Mesh_MovingBand2D [ %s ];\n", ((struct Group *) List_Pointer(Problem_S.Group, OPE->Case.Mesh_MovingBand2D.GroupIndex))->Name); break; case OPERATION_DEFORMEMESH : Message::Check(" DeformeMesh [%s, %s, '%s']; \n", ((struct DefineSystem *) List_Pointer(RE->DefineSystem, OPE->DefineSystemIndex))->Name, OPE->Case.DeformeMesh.Quantity, OPE->Case.DeformeMesh.Name_MshFile); break; // FIXME: Roman case OPERATION_TENSORPRODUCTSOLVE : Message::Check(" TensorProductSolve [\n"); for(int i = 0; i < List_Nbr(OPE->Case.TensorProductSolve.SystemIndex); i++){ int j; List_Read(OPE->Case.TensorProductSolve.SystemIndex, i, &j); Message::Check("%d ", j); } Message::Check(" XXX] \n"); //Operation_P->ExpectationIndex = ; //Operation_P->LocalMatrixIndex = ; //Operation_P->ExpansionCoef = ; break; default : Message::Check(" ???;\n"); break; } } NbrBlk--; } void Print_Resolution() { struct Resolution *RE; struct DefineSystem *DS; List_T *DS_L; int i, Nbr, j, Nbrj, k; Nbr = List_Nbr(Problem_S.Resolution); Message::Check("Resolution { /* nbr = %d */\n", Nbr); Message::Check("\n"); for (i = 0; i < Nbr; i++) { Message::Check(" /* Num : %d */\n", i); RE = (struct Resolution*)List_Pointer(Problem_S.Resolution, i); Message::Check(" { Name %s\n", RE->Name); DS_L = RE->DefineSystem; Message::Check(" System {\n"); Nbrj = List_Nbr(DS_L); for (j=0; jName, Get_StringForDefine(DefineSystem_Type, DS->Type)); Message::Check("NameOfFormulation {"); for (k = 0; k < List_Nbr(DS->FormulationIndex); k++) Message::Check(" %s", ((struct Formulation *) List_Pointer(Problem_S.Formulation, *((int *)List_Pointer(DS->FormulationIndex, k))))->Name); Message::Check(" }; "); if(DS->MeshName) Message::Check("NameOfMesh %s; ", DS->MeshName); if(DS->OriginSystemIndex) { Message::Check("OriginSystem {") ; for (k = 0 ; k < List_Nbr(DS->OriginSystemIndex) ; k++) { if (k) Message::Check(",") ; Message::Check(" %d", *((int *)List_Pointer(DS->OriginSystemIndex, k))) ; } Message::Check(" } ;") ; } if (DS->Type == VAL_COMPLEX) { Message::Check("Frequency {"); for (k = 0; k < List_Nbr(DS->FrequencyValue); k++) { if (k) Message::Check(","); Message::Check(" %.10g", *((double *)List_Pointer(DS->FrequencyValue, k))); } Message::Check(" };"); } Message::Check(" }\n"); } Message::Check(" }\n"); Message::Check(" Operation {\n"); Print_Operation(RE, RE->Operation); Message::Check(" }\n"); Message::Check(" }\n"); } Message::Check("\n"); Message::Check("}\n"); } void Print_PostProcessing() { struct PostProcessing *PP; struct PostQuantity *PQ; struct PostQuantityTerm *PQT; int i, Nbr, j, Nbrj, k, Nbrk; Nbr = List_Nbr(Problem_S.PostProcessing); Message::Check("PostProcessing { /* nbr = %d */\n", Nbr); Message::Check("\n"); for (i = 0; i < Nbr; i++) { Message::Check(" /* Num : %d */\n", i); PP = (struct PostProcessing*)List_Pointer(Problem_S.PostProcessing, i); Message::Check(" { Name %s; NameOfFormulation %s; \n", PP->Name, ((struct Formulation *) List_Pointer(Problem_S.Formulation, PP->FormulationIndex))->Name); if(PP->NameOfSystem) Message::Check("NameOfSystem %s;", PP->NameOfSystem); Nbrj = List_Nbr(PP->PostQuantity); if (Nbrj > 0) { Message::Check(" Quantity {\n"); for (j = 0; j < Nbrj; j++) { PQ = (struct PostQuantity*)List_Pointer(PP->PostQuantity, j); Message::Check(" { Name %s;\n", PQ->Name); Message::Check(" Value {\n"); Nbrk = List_Nbr(PQ->PostQuantityTerm); for (k = 0; k < Nbrk; k++) { PQT = (struct PostQuantityTerm*)List_Pointer(PQ->PostQuantityTerm, k); Message::Check(" { %s { ['", Get_StringForDefine(PostQuantityTerm_EvaluationType, PQT->EvaluationType)); Print_WholeQuantity (PQT->WholeQuantity, ((struct Formulation *) List_Pointer(Problem_S.Formulation, PP->FormulationIndex)) ->DefineQuantity); Message::Check(" ']; /* DefineQuantityType %s */\n", Get_StringForDefine(DefineQuantity_Type, PQT->Type)); if(PQT->InIndex > 0) Message::Check(" In %s;\n", ((struct Group *)List_Pointer(Problem_S.Group, PQT->InIndex))->Name); if(PQT->IntegrationMethodIndex > 0) Message::Check(" Integration %s;\n", ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, PQT->IntegrationMethodIndex))->Name); if(PQT->JacobianMethodIndex > 0) Message::Check(" Jacobian %s;\n", ((struct JacobianMethod *) List_Pointer(Problem_S.JacobianMethod, PQT->JacobianMethodIndex))->Name); } Message::Check(" } } }\n"); Message::Check(" }\n"); } Message::Check(" }\n"); } Message::Check(" }\n"); } Message::Check("\n}"); Message::Check("\n"); } void Print_PostOperation() { struct PostProcessing *PP; struct PostOperation *PO; struct PostSubOperation *PSO; int i, Nbr, k, Nbrk; Nbr = List_Nbr(Problem_S.PostOperation); Message::Check("PostOperation { /* nbr = %d */\n", Nbr); Message::Check("\n"); for (i = 0; i < Nbr; i++) { PO = (struct PostOperation*)List_Pointer(Problem_S.PostOperation, i); PP = (struct PostProcessing*)List_Pointer(Problem_S.PostProcessing, PO->PostProcessingIndex); Message::Check(" { Name %s; NameOfPostProcessing %s;\n", PO->Name, PP->Name); Message::Check(" Operation {\n"); Nbrk = List_Nbr(PO->PostSubOperation); for (k = 0; k < Nbrk; k++) { PSO = (struct PostSubOperation*)List_Pointer(PO->PostSubOperation, k); switch (PSO->Type) { case POP_PRINT : Message::Check(" Print[%s", ((struct PostQuantity *) List_Pointer(PP->PostQuantity, PSO->PostQuantityIndex[0]))->Name); if(PSO->PostQuantitySupport[0] >= 0) Message::Check(" [%s]", ((struct Group *) List_Pointer(Problem_S.Group, PSO->PostQuantitySupport[0]))->Name); if(PSO->PostQuantityIndex[1] >= 0) { Message::Check(" %s %s", Get_StringForDefine(PostSubOperation_CombinationType, PSO->CombinationType), ((struct PostQuantity *) List_Pointer(PP->PostQuantity, PSO->PostQuantityIndex[1]))->Name); if(PSO->PostQuantitySupport[1] >= 0) Message::Check(" [%s]", ((struct Group *) List_Pointer(Problem_S.Group, PSO->PostQuantitySupport[1]))->Name); } switch (PSO->SubType) { case PRINT_ONREGION : if (PSO->Case.OnRegion.RegionIndex >=0) Message::Check(", OnRegion %s", ((struct Group *) List_Pointer(Problem_S.Group, PSO->Case.OnRegion.RegionIndex))->Name ); else Message::Check(", OnGlobal"); break; case PRINT_ONELEMENTSOF : Message::Check(", OnElementsOf %s", ((struct Group *) List_Pointer(Problem_S.Group, PSO->Case.OnRegion.RegionIndex))->Name ); break; case PRINT_ONGRID : Message::Check(", OnGrid %s", ((struct Group *) List_Pointer(Problem_S.Group, PSO->Case.OnRegion.RegionIndex))->Name ); break; case PRINT_ONGRID_0D : Message::Check(", OnPoint {%.10g,%.10g,%.10g}", PSO->Case.OnGrid.x[0], PSO->Case.OnGrid.y[0], PSO->Case.OnGrid.z[0]); break; case PRINT_ONGRID_1D : Message::Check(", OnLine {{%.10g,%.10g,%.10g}{%.10g,%.10g,%.10g}} {%d}", PSO->Case.OnGrid.x[0], PSO->Case.OnGrid.y[0], PSO->Case.OnGrid.z[0], PSO->Case.OnGrid.x[1], PSO->Case.OnGrid.y[1], PSO->Case.OnGrid.z[1], PSO->Case.OnGrid.n[0]); break; case PRINT_ONGRID_2D : Message::Check(", OnPlane {{%.10g,%.10g,%.10g}{%.10g,%.10g,%.10g}" "{%.10g,%.10g,%.10g}} {%d,%d}", PSO->Case.OnGrid.x[0], PSO->Case.OnGrid.y[0], PSO->Case.OnGrid.z[0], PSO->Case.OnGrid.x[1], PSO->Case.OnGrid.y[1], PSO->Case.OnGrid.z[1], PSO->Case.OnGrid.x[2], PSO->Case.OnGrid.y[2], PSO->Case.OnGrid.z[2], PSO->Case.OnGrid.n[0], PSO->Case.OnGrid.n[1]); break; default : /* parametric grid, ... */ break; } break; default : /* POP_EXPRESSION, POP_GROUP, etc. */ break; } if(PSO->Depth != 1) Message::Check(", Depth %d", PSO->Depth); if(PSO->Skin) Message::Check(", Skin"); if(PSO->NoNewLine) Message::Check(", NoNewLine"); if(PSO->Smoothing) Message::Check(", Smoothing %d", PSO->Smoothing); if(PSO->Dimension != _ALL) Message::Check(", Dimension %d", PSO->Dimension); if(PSO->HarmonicToTime > 1) Message::Check(", HarmonicToTime %d", PSO->HarmonicToTime); if(PSO->Sort) Message::Check(", Sort %s", Get_StringForDefine(PostSubOperation_SortType, PSO->Adapt)); if(PSO->Adapt) Message::Check(", Adapt %s", Get_StringForDefine(PostSubOperation_AdaptationType, PSO->Adapt)); if(PSO->Target >= 0) Message::Check(", Target %g", PSO->Target); if(PSO->Iso){ if(PSO->Iso < 0){ Message::Check(", Iso {"); for(i=0; iIso_L); i++){ if(i!=List_Nbr(PSO->Iso_L)-1) Message::Check("%g,", *(double*)List_Pointer(PSO->Iso_L,i)); else Message::Check("%g}", *(double*)List_Pointer(PSO->Iso_L,i)); } } else{ Message::Check(", Iso %d", PSO->Iso); } } /* todo: time steps, frequencies, values, changeofcoord, ... */ Message::Check(", Format %s", Get_StringForDefine(PostSubOperation_Format, PSO->Format)); if(PSO->FileOut){ Message::Check(", File %s\"%s\"", (PSO->CatFile==2)?">> ":(PSO->CatFile==1)?"> ":"", PSO->FileOut); } Message::Check("];\n"); } Message::Check(" }\n "); Message::Check(" }\n"); } Message::Check("\n"); Message::Check("}\n"); } int Print_Object(int ichoice) { switch (ichoice) { case 0 : Print_Constants (); break; case 1 : Print_Group (); break; case 2 : Print_Expression (); break; case 3 : Print_Constraint (); break; case 4 : Print_Jacobian (); break; case 5 : Print_Integration (); break; case 6 : Print_FunctionSpace (); break; case 7 : Print_Formulation (); break; case 8 : Print_Resolution (); break; case 9 : Print_PostProcessing(); break; case 10 : Print_PostOperation (); break; default : return 1; } return 0; } void Print_ProblemStructure() { char buff[128]; int ichoice; while (1) { Message::Info("Checking"); Message::Direct("(1) Constants (2) Groups (3) Functions"); Message::Direct("(4) Constraints (5) Jacobians (6) Integrations"); Message::Direct("(7) FunctionSpaces (8) Formulations (9) Resolution"); Message::Direct("(10) PostProcessings (11) PostOperations (other) Quit"); Message::Check("Choice: "); fgets(buff, 128, stdin); ichoice = atoi(buff); if(Print_Object(ichoice ? ichoice - 1 : -1)){ Message::Check("E n d C h e c k i n g\n"); return; } } } void Print_ListResolution(int choose, int Flag_LRES, char **name) { struct Resolution *RE; int i, Nbr, ichoice = 0; char buff[128]; bool print = (!choose || (!Message::UseSocket() && !Message::UseOnelab())); if((Nbr = List_Nbr(Problem_S.Resolution))){ if(Flag_LRES < 0){ ichoice = - Flag_LRES; } else{ if(print) Message::Info("Available Resolutions"); std::vector choices; for (i = 0; i < Nbr; i++) { RE = (struct Resolution*)List_Pointer(Problem_S.Resolution, i); if(print) Message::Direct("(%d) %s", i+1, RE->Name); if(Message::UseSocket()) Message::SendOptionOnSocket(1, RE->Name); choices.push_back(RE->Name); } if(Message::UseOnelab() && choices.size()){ Constant c; c.Name = (char*)"ResolutionChoices"; c.Type = VAR_CHAR; c.Value.Char = strSave(choices[0].c_str()); std::map > floatOptions; std::map > charOptions; charOptions["Choices"] = choices; charOptions["Label"].push_back("Resolution"); charOptions["Path"].push_back(Message::GetOnelabClientName() + "/1"); Message::ExchangeOnelabParameter(&c, floatOptions, charOptions); if(choose){ *name = c.Value.Char; return; } } if(choose){ Message::Check("Choice: "); fgets(buff, 128, stdin); ichoice = atoi(buff); } } if(ichoice > 0 && ichoice < Nbr+1){ RE = (struct Resolution*)List_Pointer(Problem_S.Resolution, ichoice-1); *name = RE->Name; return; } else if(choose) Message::Error("Unknown Resolution"); } else Message::Warning("No Resolution available"); } static std::string removeWhiteSpace(const std::string &s) { std::string::size_type beg = s.find_first_not_of(' '); std::string::size_type end = s.find_last_not_of(' '); if(beg == std::string::npos || end == std::string::npos) return ""; return s.substr(beg, end + 1 - beg); } void Print_ListPostOperation(int choose, int Flag_LPOS, char *name[NBR_MAX_POS]) { struct PostOperation *PO; int i, Nbr, ichoice = 0; char buff[128]; bool print = (!choose || (!Message::UseSocket() && !Message::UseOnelab())); if((Nbr = List_Nbr(Problem_S.PostOperation))){ if(Flag_LPOS < 0){ ichoice = - Flag_LPOS; } else{ if(print) Message::Info("Available PostOperations"); std::vector choices; for (i = 0; i < Nbr; i++) { PO = (struct PostOperation*)List_Pointer(Problem_S.PostOperation, i); if(print) Message::Direct("(%d) %s", i+1, PO->Name); if(Message::UseSocket()) Message::SendOptionOnSocket(2, PO->Name); choices.push_back(PO->Name); } if(Message::UseOnelab() && choices.size()){ Constant c; c.Name = (char*)"PostOperationChoices"; c.Type = VAR_CHAR; c.Value.Char = strSave(choices[0].c_str()); std::map > floatOptions; std::map > charOptions; charOptions["Choices"] = choices; charOptions["Label"].push_back("Post-processing"); charOptions["Path"].push_back(Message::GetOnelabClientName() + "/2"); charOptions["MultipleSelection"].push_back("1"); Message::ExchangeOnelabParameter(&c, floatOptions, charOptions); if(choose){ std::string str(c.Value.Char); int i = 0; std::string::size_type first = 0; while(1){ std::string::size_type last = str.find_first_of(",", first); std::string next = str.substr(first, last - first); name[i++] = strSave(removeWhiteSpace(next).c_str()); if(last == std::string::npos) break; first = last + 1; if(i == NBR_MAX_POS - 1) break; } name[i] = NULL; return; } } if(choose){ Message::Check("Choice: "); fgets(buff, 128, stdin); ichoice = atoi(buff); } } if(ichoice > 0 && ichoice < Nbr+1){ PO = (struct PostOperation*)List_Pointer(Problem_S.PostOperation, ichoice-1); name[0] = PO->Name; name[1] = NULL; return; } else if(choose) Message::Error("Unknown PostOperation"); } else Message::Warning("No PostOperation available"); } getdp-2.4.2-source/Interface/ProDefine.h000644 001750 001750 00000010015 12116424200 021511 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _PRO_DEFINE_H_ #define _PRO_DEFINE_H_ #include "ProData.h" struct StringXDefine { const char *string; int define; }; struct StringXDefine1Nbr { const char *string; int define, Nbr1; }; struct StringXPointer { const char *string; void *Pointer; }; struct StringX3Function3Nbr { const char *string; void (*Function1)(); void (*Function2)(); void (*Function3)(); double Nbr1; int Nbr2; int Nbr3; }; struct DefineXFunction { int define; void (*Function)(); }; struct StringXFunction2Nbr { const char *string; void (*Function)(); int Nbr1, Nbr2; }; struct FunctionXFunction { void (*Function1)(); void (*Function2)(); }; extern struct StringXDefine Mesh_Format[]; extern struct StringXDefine Field_Type[]; extern struct StringXDefine FunctionForGroup_Type[]; extern struct StringXDefine FunctionForGroup_SuppList[]; extern struct StringXDefine1Nbr Jacobian_Type[]; extern struct StringXDefine Integration_Type[]; extern struct StringXDefine Integration_SubType[]; extern struct StringXDefine Element_Type[]; extern struct StringXDefine GlobalQuantity_Type[]; extern struct StringXDefine Constraint_Type[]; extern struct StringXDefine Formulation_Type[]; extern struct StringXDefine DefineQuantity_Type[]; extern struct StringXDefine Operator_Type[]; extern struct StringXDefine QuantityFromFS_Type[]; extern struct StringXDefine DefineSystem_Type[]; extern struct StringXDefine Operation_Type[]; extern struct StringXDefine ChangeOfState_Type[]; extern struct StringXDefine PostQuantityTerm_EvaluationType[]; extern struct StringXDefine PostSubOperation_CombinationType[]; extern struct StringXDefine PostSubOperation_Format[]; extern struct StringXDefine PostSubOperation_FormatTag[]; extern struct StringXDefine PostSubOperation_AdaptationType[]; extern struct StringXDefine PostSubOperation_SortType[]; extern struct StringXPointer Current_Value[]; extern struct DefineXFunction FunctionForGauss[]; extern struct DefineXFunction FunctionForGaussLegendre[]; extern struct DefineXFunction FunctionForSingularGauss[]; extern struct StringX3Function3Nbr BF_Function[]; extern struct StringXFunction2Nbr F_Function[]; extern struct FunctionXFunction GF_Function[]; const char *Get_StringForDefine(struct StringXDefine SXD[], int define); int Get_DefineForString(struct StringXDefine SXD[], const char *string, int *FlagError); const char *Get_StringForDefine1Nbr(struct StringXDefine1Nbr SXD[], int define); int Get_Define1NbrForString(struct StringXDefine1Nbr SXD[], const char *string, int *FlagError, int *Nbr1); const char *Get_StringForPointer(struct StringXPointer SXF[], void *Pointer); void Get_PointerForString(struct StringXPointer SXF[], const char *string, int *FlagError, void **Pointer); const char *Get_StringFor3Function3Nbr(struct StringX3Function3Nbr SXF[], void (*Function1)()); void Get_3Function3NbrForString(struct StringX3Function3Nbr SXF[], const char *string, int *FlagError, void (**Function1)(), void (**Function2)(), void (**Function3)(), double *Nbr1, int *Nbr2, int *Nbr3); void Get_FunctionForDefine(struct DefineXFunction DXF[], int define, int *FlagError, void (**Function)()); void Get_Function2NbrForString(struct StringXFunction2Nbr SXF[], const char *string, int *FlagError, void (**Function)(), int *Nbr1, int *Nbr2); void Get_FunctionForFunction(struct FunctionXFunction FXF[], void (*Function1)(), int *FlagError, void (**Function2)() ); const char *Get_StringForFunction2Nbr(struct StringXFunction2Nbr SXF[], void (*Function)()); char *Get_Valid_SXD(struct StringXDefine V[]); char *Get_Valid_SXD1N(struct StringXDefine1Nbr V[]); char *Get_Valid_SXP(struct StringXPointer V[]); char *Get_Valid_SX3F3N(struct StringX3Function3Nbr V[]); char *Get_Valid_SXF2N(struct StringXFunction2Nbr V[]); #endif getdp-2.4.2-source/Interface/ProParser.l000644 001750 001750 00000044324 12221300353 021570 0ustar00geuzainegeuzaine000000 000000 %{ // GetDP - Copyright (C) 1997-2008 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include #include #include "ProData.h" #include "ProParser.h" #include "ProParser.tab.hpp" #include "MallocUtils.h" #include "Message.h" // Redefinition of YY_INPUT to allow input character count (this is // slower than fread(), but the .pro files are never that big) #ifdef YY_INPUT #undef YY_INPUT #endif #define YY_INPUT(buf,result,max_size) { \ int c = getc(getdp_yyin); \ getdp_yycolnum++; \ result = (c == EOF) ? YY_NULL : (buf[0] = c, 1); \ } %} alpha [a-zA-Z\_\.] digit [0-9] exp [Ee][-+]?{digit}+ string {alpha}({alpha}|{digit})* %% [\ \t\r\f] /* nothing to do */; [\n] { getdp_yycolnum = 0; getdp_yylinenum++; } <> { getdp_yyincludenum = 0; return(0); } ";" return tEND; "/*" cStyleComments(); "//" cxxStyleComments(); "\"" { parseString('\"'); return tBIGSTR; } "=" return tDEF; "*^" return tCROSSPRODUCT; "/\\" return tCROSSPRODUCT; "||" return tOR; "&&" return tAND; "==" return tEQUAL; "!=" return tNOTEQUAL; "~=" return tAPPROXEQUAL; "<=" return tLESSOREQUAL; ">=" return tGREATEROREQUAL; ">>" return tGREATERGREATER; "<<" return tLESSLESS; "..." return tDOTS; ":" return tDOTS; "##" return tSHOW; StrCat return tStrCat; Sprintf return tSprintf; Printf return tPrintf; Read return tRead; PrintConstants return tPrintConstants; StrCmp return tStrCmp ; NbrRegions return tNbrRegions ; Pi return tPi; 0D return t0D; 1D return t1D; 2D return t2D; 3D return t3D; MPI_Rank return tMPI_Rank; MPI_Size return tMPI_Size; Include return tInclude; #include return tInclude; Constant return tConstant; Const return tConstant; Group return tGroup; DefineGroup return tDefineGroup; All return tAll; InSupport return tInSupport; MovingBand2D return tMovingBand2D; SaveMesh return tSaveMesh; DeformMesh return tDeformeMesh; DeformeMesh return tDeformeMesh; DefineFunction return tDefineFunction; DefineVariable return tDefineConstant; DefineConstant return tDefineConstant; UndefineConstant return tUndefineConstant; List return tList; ListAlt return tListAlt; ListFromFile return tListFromFile; Exp return tExp; Log return tLog; Log10 return tLog10; Sqrt return tSqrt; Sin return tSin; ASin return tAsin; Asin return tAsin; Cos return tCos; ACos return tAcos; Acos return tAcos; Tan return tTan; Atan return tAtan; Atan2 return tAtan2; Sinh return tSinh; Cosh return tCosh; Tanh return tTanh; Fabs return tFabs; Floor return tFloor; Ceil return tCeil; Round return tRound; Sign return tSign; Fmod return tFmod; Modulo return tModulo; Hypot return tHypot; Rand return tRand; Cross return tCrossProduct; CrossProduct return tCrossProduct; SolidAngle return tSolidAngle; Order return tOrder; Trace return tTrace; DofValue return tDofValue; LinSpace return tLinSpace; LogSpace return tLogSpace; MHTransform return tMHTransform; MHJacNL return tMHJacNL; Constraint return tConstraint; Region return tRegion; SubRegion return tSubRegion; RegionRef return tRegionRef; SubRegionRef return tSubRegionRef; Coefficient return tCoefficient; Filter return tFilter; Value return tValue; TimeFunction return tTimeFunction; Branch return tBranch; NameOfResolution return tNameOfResolution; Jacobian return tJacobian; MetricTensor return tMetricTensor; Case return tCase; Integration return tIntegration; Matrix return tMatrix; Criterion return tCriterion; GeoElement return tGeoElement; NumberOfPoints return tNumberOfPoints; MaxNumberOfPoints return tMaxNumberOfPoints; NumberOfDivisions return tNumberOfDivisions; MaxNumberOfDivisions return tMaxNumberOfDivisions; StoppingCriterion return tStoppingCriterion; FunctionSpace return tFunctionSpace; Name return tName; Type return tType; SubType return tSubType; BasisFunction return tBasisFunction; NameOfCoef return tNameOfCoef; Function return tFunction; dFunction return tdFunction; SubFunction return tSubFunction; SubdFunction return tSubdFunction; Support return tSupport; Entity return tEntity; SubSpace return tSubSpace; NameOfBasisFunction return tNameOfBasisFunction; GlobalQuantity return tGlobalQuantity; EntityType return tEntityType; EntitySubType return tEntitySubType; NameOfConstraint return tNameOfConstraint; Formulation return tFormulation; Quantity return tQuantity; NameOfSpace return tNameOfSpace; IndexOfSystem return tIndexOfSystem; Symmetry return tSymmetry; Galerkin return tGalerkin; deRham return tdeRham; Dt return tDt; DtDof return tDtDof; DtDt return tDtDt; DtDtDof return tDtDtDof; JacNL return tJacNL; DtDofJacNL return tDtDofJacNL; NeverDt return tNeverDt; DtNL return tDtNL; AtAnteriorTimeStep return tAtAnteriorTimeStep; In return tIn; Full_Matrix return tFull_Matrix; GlobalTerm return tGlobalTerm; GlobalEquation return tGlobalEquation; Resolution return tResolution; System return tDefineSystem; NameOfFormulation return tNameOfFormulation; NameOfMesh return tNameOfMesh; Frequency return tFrequency; DummyFrequency return tDummyFrequency; Solver return tSolver; OriginSystem return tOriginSystem; DestinationSystem return tDestinationSystem; Operation return tOperation; OperationEnd return tOperationEnd; SetTime return tSetTime; SetFrequency return tSetFrequency; Update return tUpdate; UpdateConstraint return tUpdateConstraint; GenerateOnly return tGenerateOnly; GenerateOnlyJac return tGenerateOnlyJac; FourierTransform return tFourierTransform; FourierTransformJ return tFourierTransformJ; Lanczos return tLanczos; EigenSolve return tEigenSolve; EigenSolveJac return tEigenSolveJac; Evaluate return tEvaluate; SelectCorrection return tSelectCorrection ; AddCorrection return tAddCorrection ; MultiplySolution return tMultiplySolution ; AddOppositeFullSolution return tAddOppositeFullSolution ; SolveAgainWithOther return tSolveAgainWithOther; Test return tIf; TimeLoopTheta return tTimeLoopTheta; TimeLoopNewmark return tTimeLoopNewmark; TimeLoopRungeKutta return tTimeLoopRungeKutta; TimeLoopAdaptive return tTimeLoopAdaptive; Time0 return tTime0; TimeMax return tTimeMax; DTime return tDTime; Theta return tTheta; Beta return tBeta; Gamma return tGamma; IterativeLoop return tIterativeLoop; IterativeLoopN return tIterativeLoopN; IterativeLinearSolver return tIterativeLinearSolver; NbrMaxIteration return tNbrMaxIteration; RelaxationFactor return tRelaxationFactor; IterativeTimeReduction return tIterativeTimeReduction; DivisionCoefficient return tDivisionCoefficient; ChangeOfState return tChangeOfState; ChangeOfCoordinates return tChangeOfCoordinates; ChangeOfCoordinates2 return tChangeOfCoordinates2; ChangeOfValues return tChangeOfValues; SystemCommand return tSystemCommand; GmshRead return tGmshRead; GmshClearAll return tGmshClearAll; DeleteFile return tDeleteFile; CreateDir return tCreateDir; CreateDirectory return tCreateDir; Break return tBreak; SolveJac_AdaptRelax return tSolveJac_AdaptRelax; TensorProductSolve return tTensorProductSolve; SaveSolutionWithEntityNum return tSaveSolutionWithEntityNum; SaveSolutionExtendedMH return tSaveSolutionExtendedMH; SaveSolutionMHtoTime return tSaveSolutionMHtoTime; InitMovingBand2D return tInitMovingBand2D; MeshMovingBand2D return tMeshMovingBand2D; Generate_MH_Moving return tGenerate_MH_Moving; Generate_MH_Moving_Separate return tGenerate_MH_Moving_Separate; Add_MH_Moving return tAdd_MH_Moving; GenerateGroup return tGenerateGroup; GenerateJacGroup return tGenerateJacGroup; GenerateRHSGroup return tGenerateRHSGroup; SetCommSelf return tSetCommSelf; SetCommWorld return tSetCommWorld; Barrier return tBarrier; PostProcessing return tPostProcessing; NameOfSystem return tNameOfSystem; PostOperation return tPostOperation; NameOfPostProcessing return tNameOfPostProcessing; UsingPost return tUsingPost; Append return tAppend; ResampleTime return tResampleTime; Plot return tPlot; Print return tPrint; PrintGroup return tPrintGroup; Echo return tEcho; Adapt return tAdapt; Write return tWrite; OnGlobal return tOnGlobal; OnRegion return tOnRegion; OnElementsOf return tOnElementsOf; OnGrid return tOnGrid; OnCut return tOnSection; OnSection return tOnSection; OnPoint return tOnPoint; OnLine return tOnLine; OnPlane return tOnPlane; OnBox return tOnBox; WithArgument return tWithArgument; Smoothing return tSmoothing; Skin return tSkin; Format return tFormat; Footer return tFooter; Header return tHeader; Depth return tDepth; Dimension return tDimension; Comma return tComma; ValueIndex return tValueIndex; ValueName return tValueName; HarmonicToTime return tHarmonicToTime; TimeStep return tTimeStep; Target return tTarget; File return tFile; Sort return tSort; Iso return tIso; NoNewLine return tNoNewLine; NoTitle return tNoTitle; TimeLegend return tTimeLegend; FrequencyLegend return tFrequencyLegend; EigenvalueLegend return tEigenvalueLegend; EvaluationPoints return tEvaluationPoints; StoreInRegister return tStoreInRegister; Store return tStoreInRegister; StoreInField return tStoreInField; LastTimeStepOnly return tLastTimeStepOnly; AppendTimeStepToFileName return tAppendTimeStepToFileName; OverrideTimeStepValue return tOverrideTimeStepValue; SendToServer return tSendToServer; Color return tColor; NewCoordinates return tNewCoordinates; If return tIf; Else return tElse; EndIf return tEndIf; For return tFor; EndFor return tEndFor; DecomposeInSimplex return tDecomposeInSimplex; Str return tStr; Date return tDate; Flag return tFlag; PostQuantity return tQuantity; Integral return tGalerkin; {digit}+ { getdp_yylval.i = atoi(yytext); return tINT; } {digit}+"."{digit}*({exp})? | {digit}*"."{digit}+({exp})? | {digit}+{exp} { getdp_yylval.d = atof(yytext); return tFLOAT; } {string} { getdp_yylval.c = strSave(yytext); return tSTRING; } . return yytext[0]; %% #undef getdp_yywrap int getdp_yywrap() { return 1; } #ifdef __cplusplus #define input yyinput #endif #ifndef yytext_ptr #define yytext_ptr yytext #endif char *strSave(const char *string) { return ((char *)strcpy((char *)Malloc(strlen(string)+1), string)); } void cStyleComments() { int c; while(1) { while((c = input()) != '*'){ if(c == '\n') getdp_yylinenum++; if(feof(getdp_yyin)) { Message::Error("End of file in commented region"); exit(1); } } if((c = input()) == '/') return; unput(c); } } void cxxStyleComments() { int c; while(1){ c = input(); if(c == '\n' || feof(getdp_yyin)) break; } getdp_yylinenum++; } void parseString(char endchar) { char tmp[2048]; int c = input(); int i = 0; while(c != endchar){ if(feof(getdp_yyin)) { Message::Error("End of file in string"); getdp_yycolnum = 0; break; } else if(c == '\n') { getdp_yycolnum = 0; } else if(i >= (int)sizeof(tmp)-1) { Message::Error("String too long"); break; } else { tmp[i++] = c; } c = input(); } tmp[i] = '\0'; getdp_yylval.c = strSave(tmp); } void skipUntil(const char *skip, const char *until) { int l, l_skip, l_until; char chars[256]; int c_next, c_next_skip, c_next_until; int nb_skip = 0; if(skip) l_skip = strlen(skip); else l_skip = 0; l_until = strlen(until); while(1){ while (1){ chars[0] = input(); if(chars[0] == '\n') getdp_yylinenum++; if(feof(getdp_yyin)){ Message::Error("Unexpected end of file"); return; } if(chars[0] == '/'){ c_next = input(); if (c_next == '*') cStyleComments(); else if(c_next == '/') cxxStyleComments(); else unput(c_next); } if(chars[0] == until[0]) break; if(skip && chars[0] == skip[0]) break; } l = (l_skip > l_until) ? l_skip : l_until; if(l >= (int)sizeof(chars)){ Message::Error("Search pattern too long in skip_until"); return; } for(int i = 1; i < l; i++){ chars[i] = input(); if(chars[i] == '\n') getdp_yylinenum++; if(feof(getdp_yyin)){ l = i; break; } } c_next = input(); unput(c_next); c_next_skip = (l_skip='a' && c_next_until<='z') && !(c_next_until>='A' && c_next_until<='Z') && c_next_until!='_' ) ){ if(!nb_skip){ return; } else{ nb_skip--; } } else if(skip && !strncmp(chars,skip,l_skip) && (!(c_next_skip>='a' && c_next_skip<='z') && !(c_next_skip>='A' && c_next_skip<='Z') && c_next_skip!='_' ) ){ nb_skip++; } else{ for(int i = 1; i < l - 1; i++){ unput(chars[l-i]); if(chars[l-i] == '\n') getdp_yylinenum--; } } } } void hack_fsetpos_printf() { char chars[5]; int c = input(), c2 = input(), c3 = input(); unput(c3); unput(c2); unput(c); chars[0] = c; chars[1] = c2; chars[2] = c3; chars[3] = 0; printf("++++++ c: %d %d %d /%s/\n", (int)c, (int)c2, (int)c3, chars); } void hack_fsetpos() { input(); } getdp-2.4.2-source/Interface/ProParser.y000644 001750 001750 00000747354 12221300353 021622 0ustar00geuzainegeuzaine000000 000000 %{ // GetDP - Copyright (C) 1997-2008 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Ruth Sabariego // Johan Gyselinck // #include #include #include #include #include #include #include #include #include "GetDPConfig.h" #include "ProData.h" #include "ProDefine.h" #include "ProDefines.h" #include "ProParser.h" #include "MallocUtils.h" #include "TreeUtils.h" #include "Message.h" #include "OS.h" // Global problem structure filled by the parser extern struct Problem Problem_S; // Global parser variables char getdp_yyname[256] = ""; char getdp_yyincludename[256] = ""; long int getdp_yylinenum = 0; int getdp_yycolnum = 0; int getdp_yyincludenum = 0; int getdp_yyerrorlevel = 0; std::map CommandLineNumbers; std::map CommandLineStrings; // Static parser variables (accessible only in this file) static Tree_T *ConstantTable_L = 0; static List_T *ListOfInt_L = 0; static List_T *ListOfPointer_L = 0, *ListOfPointer2_L = 0, *ListOfChar_L = 0; static List_T *ListOfFormulation = 0, *ListOfBasisFunction = 0, *ListOfEntityIndex = 0; static List_T *Operation_L = 0; static List_T *Current_BasisFunction_L = 0, *Current_SubSpace_L = 0; static List_T *Current_GlobalQuantity_L = 0, *Current_WholeQuantity_L = 0; static List_T *Current_System_L = 0; static int Num_BasisFunction = 1; static int FlagError = 0; static int Type_TermOperator = 0, Type_Function = 0, Type_SuppList = 0; static int Quantity_TypeOperator = 0, Quantity_Index = 0; static int Current_DofIndexInWholeQuantity = 0, Last_DofIndexInWholeQuantity = 0; static int Current_NoDofIndexInWholeQuantity = 0; static int Current_System = 0, Constraint_Index = 0; static int TypeOperatorDofInTrace = 0, DefineQuantityIndexDofInTrace = 0; static int ImbricatedLoop = 0; #define MAX_RECUR_LOOPS 100 static fpos_t FposImbricatedLoopsTab[MAX_RECUR_LOOPS]; static int LinenoImbricatedLoopsTab[MAX_RECUR_LOOPS]; static double LoopControlVariablesTab[MAX_RECUR_LOOPS][3]; static char *LoopControlVariablesNameTab[MAX_RECUR_LOOPS]; static struct Constant Constant_S, Constant1_S, Constant2_S; static struct Expression Expression_S, *Expression_P; static struct ExpressionPerRegion ExpressionPerRegion_S; static struct Group Group_S; static struct Constraint Constraint_S, *Constraint_P; static struct ConstraintPerRegion ConstraintPerRegion_S, *ConstraintPerRegion_P; static struct MultiConstraintPerRegion MultiConstraintPerRegion_S; static struct JacobianMethod JacobianMethod_S; static struct JacobianCase JacobianCase_S; static struct IntegrationMethod IntegrationMethod_S; static struct IntegrationCase IntegrationCase_S; static struct Quadrature QuadratureCase_S; static struct FunctionSpace FunctionSpace_S; static struct BasisFunction BasisFunction_S; static struct GlobalBasisFunction GlobalBasisFunction_S; static struct SubSpace SubSpace_S; static struct GlobalQuantity GlobalQuantity_S; static struct ConstraintInFS ConstraintInFS_S; static struct Formulation Formulation_S; static struct DefineQuantity DefineQuantity_S; static struct EquationTerm EquationTerm_S; static struct WholeQuantity WholeQuantity_S, *WholeQuantity_P; static struct GlobalEquationTerm GlobalEquationTerm_S; static struct Resolution Resolution_S; static struct DefineSystem DefineSystem_S; static struct Operation Operation_S, *Operation_P; static struct ChangeOfState ChangeOfState_S; static struct TimeLoopAdaptiveSystem TimeLoopAdaptiveSystem_S; static struct LoopErrorPostOperation TimeLoopAdaptivePO_S, IterativeLoopPO_S; static struct IterativeLoopSystem IterativeLoopSystem_S; static struct PostProcessing PostProcessing_S, InteractivePostProcessing_S; static struct PostQuantity PostQuantity_S; static struct PostQuantityTerm PostQuantityTerm_S; static struct PostOperation PostOperation_S; static struct PostSubOperation PostSubOperation_S; static std::map > FloatOptions_S; static std::map > CharOptions_S; // External lexer functions void hack_fsetpos(); void hack_fsetpos_printf(); int getdp_yylex(); // Forward function declarations void Alloc_ParserVariables(); void Check_NameOfStructNotExist(const char *Struct, List_T *List_L, void *data, int (*fcmp)(const void *a, const void *b)); int Add_Group(struct Group *Group_P, char *Name, bool Flag_Add, int Flag_Plus, int Num_Index); int Num_Group(struct Group *Group_P, char *Name, int Num_Group); void Fill_GroupInitialListFromString(List_T *list, const char *str); int Add_Expression(struct Expression *Expression_P, char *Name, int Flag_Plus); bool Is_ExpressionPieceWiseDefined(int index); void Pro_DefineQuantityIndex(List_T *WholeQuantity_L,int DefineQuantityIndexEqu, int *NbrQuantityIndex, int **QuantityIndexTable, int **QuantityTraceGroupIndexTable); void Pro_DefineQuantityIndex_1(List_T *WholeQuantity_L, int TraceGroupIndex); int Print_ListOfDouble(char *format, List_T *list, char *buffer); void yyerror(const char *s); void vyyerror(const char *fmt, ...); struct doubleXstring{ double d; char *s; }; %} /* ------------------------------------------------------------------ */ %union { char *c; int i; double d; List_T *l; struct TwoInt t; } %token tINT %token tFLOAT %token tSTRING tBIGSTR %type GroupRHS ReducedGroupRHS %type FunctionForGroup SuppListTypeForGroup %type Expression %type ArgumentsForFunction RecursiveListOfQuantity %type PostQuantitySupport %type IRegion RecursiveListOfRegion Enumeration %type StrCmp NbrRegions CommaFExprOrNothing %type FExpr OneFExpr %type MultiFExpr ListOfFExpr RecursiveListOfFExpr RecursiveListOfListOfFExpr %type RecursiveListOfCharExpr ParametersForFunction %type ListOfRegion ListOfRegionOrAll SuppListOfRegion %type ConstraintCases IntegrationCases QuadratureCases JacobianCases %type BasisFunctions SubSpaces GlobalQuantities ConstraintInFSs %type ListOfBasisFunction RecursiveListOfBasisFunction %type ListOfBasisFunctionCoef RecursiveListOfBasisFunctionCoef %type Equations WholeQuantityExpression %type DefineSystems Operation ChangeOfStates %type ListOfFormulation RecursiveListOfFormulation %type ListOfSystem RecursiveListOfSystem %type PostQuantities SubPostQuantities PostSubOperations %type NameForMathFunction NameForFunction CharExpr CharExprNoVar %type StrCat StringIndex String__Index %type RecursiveListOfString__Index %type Quantity_Def %type TimeLoopAdaptiveSystems TimeLoopAdaptivePOs IterativeLoopSystems IterativeLoopPOs /* ------------------------------------------------------------------ */ %token tEND tDOTS %token tStrCat tSprintf tPrintf tRead tPrintConstants tStrCmp tNbrRegions %token tFor tEndFor tIf tElse tEndIf %token tFlag %token tInclude %token tConstant tList tListAlt tLinSpace tLogSpace tListFromFile %token tChangeCurrentPosition %token tDefineConstant tUndefineConstant tPi tMPI_Rank tMPI_Size t0D t1D t2D t3D %token tExp tLog tLog10 tSqrt tSin tAsin tCos tAcos tTan %token tAtan tAtan2 tSinh tCosh tTanh tFabs tFloor tCeil tRound tSign %token tFmod tModulo tHypot tRand %token tSolidAngle tTrace tOrder tCrossProduct tDofValue %token tMHTransform tMHJacNL %token tGroup tDefineGroup tAll tInSupport tMovingBand2D %token tDefineFunction %token tConstraint %token tRegion tSubRegion tRegionRef tSubRegionRef %token tFilter tCoefficient tValue tTimeFunction %token tBranch tNameOfResolution %token tJacobian %token tCase %token tMetricTensor %token tIntegration %token tMatrix %token tType tSubType tCriterion tGeoElement %token tNumberOfPoints tMaxNumberOfPoints %token tNumberOfDivisions tMaxNumberOfDivisions %token tStoppingCriterion %token tFunctionSpace %token tName %token tBasisFunction %token tNameOfCoef tFunction tdFunction tSubFunction tSubdFunction tSupport tEntity %token tSubSpace tNameOfBasisFunction %token tGlobalQuantity %token tEntityType tEntitySubType tNameOfConstraint %token tFormulation %token tQuantity %token tNameOfSpace tIndexOfSystem %token tSymmetry %token tGalerkin tdeRham tGlobalTerm tGlobalEquation %token tDt tDtDof tDtDt tDtDtDof tJacNL tDtDofJacNL tNeverDt tDtNL tAtAnteriorTimeStep %token tIn %token tFull_Matrix %token tResolution %token tDefineSystem %token tNameOfFormulation tNameOfMesh tFrequency tSolver %token tOriginSystem tDestinationSystem %token tOperation tOperationEnd %token tSetTime tDTime tSetFrequency tFourierTransform tFourierTransformJ %token tLanczos tEigenSolve tEigenSolveJac tPerturbation %token tUpdate tUpdateConstraint tBreak %token tEvaluate tSelectCorrection tAddCorrection tMultiplySolution %token tAddOppositeFullSolution tSolveAgainWithOther %token tTimeLoopTheta tTimeLoopNewmark tTimeLoopRungeKutta tTimeLoopAdaptive %token tTime0 tTimeMax tTheta %token tBeta tGamma %token tIterativeLoop tIterativeLoopN tIterativeLinearSolver %token tNbrMaxIteration tRelaxationFactor %token tIterativeTimeReduction %token tSetCommSelf tSetCommWorld tBarrier %token tDivisionCoefficient tChangeOfState %token tChangeOfCoordinates tChangeOfCoordinates2 tSystemCommand %token tGmshRead tGmshClearAll tDeleteFile tCreateDir %token tGenerateOnly %token tGenerateOnlyJac %token tSolveJac_AdaptRelax tTensorProductSolve %token tSaveSolutionExtendedMH tSaveSolutionMHtoTime tSaveSolutionWithEntityNum %token tInitMovingBand2D tMeshMovingBand2D %token tGenerate_MH_Moving tGenerate_MH_Moving_Separate tAdd_MH_Moving %token tGenerateGroup tGenerateJacGroup tGenerateRHSGroup %token tSaveMesh %token tDeformeMesh %token tDummyFrequency %token tPostProcessing %token tNameOfSystem %token tPostOperation %token tNameOfPostProcessing tUsingPost tAppend tResampleTime %token tPlot tPrint tPrintGroup tEcho tWrite tAdapt %token tOnGlobal tOnRegion tOnElementsOf %token tOnGrid tOnSection tOnPoint tOnLine tOnPlane tOnBox %token tWithArgument %token tFile tDepth tDimension tComma tTimeStep tHarmonicToTime %token tValueIndex tValueName %token tFormat tHeader tFooter tSkin tSmoothing %token tTarget tSort tIso tNoNewLine tNoTitle tDecomposeInSimplex tChangeOfValues %token tTimeLegend tFrequencyLegend tEigenvalueLegend %token tEvaluationPoints tStoreInRegister tStoreInField %token tLastTimeStepOnly tAppendTimeStepToFileName %token tOverrideTimeStepValue tNoMesh tSendToServer tColor tStr tDate %token tNewCoordinates /* ------------------------------------------------------------------ */ /* Operators (with ascending priority): cf. C language */ /* */ /* Notes: - associativity (%left, %right) */ /* - UNARYPREC is a dummy terminal to resolve ambiguous cases */ /* for + and - (which exist in both unary and binary form) */ /* ------------------------------------------------------------------ */ %right tDEF %right '?' tDOTS %left tOR %left tAND %left tEQUAL tNOTEQUAL tAPPROXEQUAL %left '<' tLESSOREQUAL '>' tGREATEROREQUAL tLESSLESS tGREATERGREATER %left '+' '-' %left '*' '/' '%' tCROSSPRODUCT %left '|' '&' %right '!' UNARYPREC %right '^' %left '(' ')' '[' ']' '.' %left '#' '$' tSHOW /* ------------------------------------------------------------------ */ %start Stats %% Stats : { Alloc_ParserVariables(); } ProblemDefinitions ; /* ------------------------------------------------------------------------ */ /* P r o b l e m */ /* ------------------------------------------------------------------------ */ ProblemDefinitions : /* none */ | ProblemDefinitions { Formulation_S.DefineQuantity = NULL; } ProblemDefinition ; ProblemDefinition : tGroup '{' Groups '}' | tFunction '{' Functions '}' | tConstraint '{' Constraints '}' | tJacobian '{' JacobianMethods '}' | tIntegration '{' IntegrationMethods '}' | tFunctionSpace '{' FunctionSpaces '}' | tFormulation '{' Formulations '}' | tResolution '{' Resolutions '}' | tPostProcessing '{' PostProcessings '}' | tPostOperation '{' PostOperations '}' | SeparatePostOperation | Loop // contains For, EndFor, If, EndIf, Affectation | tInclude CharExpr { strcpy(getdp_yyincludename, $2); getdp_yyincludenum++; return(0); } ; /* ------------------------------------------------------------------------ */ /* G r o u p */ /* ------------------------------------------------------------------------ */ Groups : /* none */ | Groups Group ; Group : String__Index tDEF ReducedGroupRHS tEND { Add_Group(&Group_S, $1, false, 0, 0); } | String__Index '+' tDEF ReducedGroupRHS tEND { Add_Group(&Group_S, $1, true, 0, 0); } | String__Index tDEF tMovingBand2D '[' IRegion { int j = 0; if(List_Nbr($5) == 1) List_Read($5, 0, &j); else vyyerror("Single region number expected for moving band definition"); Group_S.InitialList = List_Create(1, 1, sizeof(int)); List_Add(Group_S.InitialList, &j); Group_S.Type = MOVINGBAND2D; Group_S.FunctionType = REGION; Group_S.InitialSuppList = NULL; Group_S.SuppListType = SUPPLIST_NONE; Group_S.MovingBand2D = (struct MovingBand2D *)Malloc(sizeof(struct MovingBand2D)); Group_S.MovingBand2D->PhysNum = j; } ',' ListOfRegion { Group_S.MovingBand2D->InitialList1 = $8; Group_S.MovingBand2D->ExtendedList1 = NULL; } ',' ListOfRegion ',' FExpr ']' tEND { Group_S.MovingBand2D->InitialList2 = $11; Group_S.MovingBand2D->Period2 = (int)$13; Add_Group(&Group_S, $1, false, 0, 0); } | tDefineGroup '[' DefineGroups ']' tEND | Loop ; ReducedGroupRHS : FunctionForGroup '[' ListOfRegionOrAll { Group_S.FunctionType = $1; switch (Group_S.FunctionType) { case ELEMENTSOF : Group_S.Type = ELEMENTLIST; break; default : Group_S.Type = REGIONLIST; break; } Group_S.InitialList = $3; } SuppListOfRegion ']' { Group_S.SuppListType = Type_SuppList; Group_S.InitialSuppList = $5; $$ = -1; } /* shortcut: #list == Region[ list ] */ | '#' ListOfRegion { Group_S.FunctionType = REGION; Group_S.Type = REGIONLIST; Group_S.InitialList = $2; Group_S.SuppListType = SUPPLIST_NONE; Group_S.InitialSuppList = NULL; $$ = -1; } ; GroupRHS : ReducedGroupRHS { $$ = $1; } | String__Index { int i; if(!strcmp($1, "All")) { $$ = -3; } else if((i = List_ISearchSeq(Problem_S.Group, $1, fcmp_Group_Name)) >= 0) { List_Read(Problem_S.Group, i, &Group_S); $$ = i; } else { $$ = -2; vyyerror("Unknown Group: %s", $1); } Free($1); } ; FunctionForGroup : tRegion { $$ = REGION; } | tSTRING { $$ = Get_DefineForString(FunctionForGroup_Type, $1, &FlagError); if(FlagError){ vyyerror("Unknown type of Function for Group: %s", $1); Get_Valid_SXD(FunctionForGroup_Type); } Free($1); } ; ListOfRegionOrAll : ListOfRegion { $$ = $1; } | tAll { $$ = NULL; } ; SuppListOfRegion : /* none */ { Type_SuppList = SUPPLIST_NONE; $$ = NULL; } | Comma SuppListTypeForGroup ListOfRegion { Type_SuppList = $2; $$ = $3; } | Comma tInSupport String__Index { int i; Type_SuppList = SUPPLIST_INSUPPORT; if((i = List_ISearchSeq(Problem_S.Group, $3, fcmp_Group_Name)) >= 0) { if(((struct Group *)List_Pointer(Problem_S.Group, i))->Type == ELEMENTLIST) { $$ = List_Create(1, 5, sizeof(int)); List_Add($$, &i); } else vyyerror("Not a Support of Element Type: %s", $3); } else vyyerror("Unknown Region for Support: %s", $3); Free($3); } ; SuppListTypeForGroup : tSTRING { $$ = Get_DefineForString(FunctionForGroup_SuppList, $1, &FlagError); if(FlagError){ vyyerror("Unknown type of Supplementary Region: %s", $1); Get_Valid_SXD(FunctionForGroup_SuppList); } Free($1); } ; ListOfRegion : IRegion { $$ = List_Create(((List_Nbr($1) > 0)? List_Nbr($1) : 1), 5, sizeof(int)); for(int i = 0; i < List_Nbr($1); i++) List_Add($$, (int *)List_Pointer($1, i)); } | '{' RecursiveListOfRegion '}' { $$ = $2; } ; RecursiveListOfRegion : // none { $$ = List_Create(5, 5, sizeof(int)); } | RecursiveListOfRegion Comma IRegion { $$ = $1; for(int i = 0; i < List_Nbr($3); i++) List_Add($$, (int *)List_Pointer($3, i)); } | RecursiveListOfRegion Comma '-' IRegion { $$ = $1; for(int i = 0; i < List_Nbr($4); i++) List_Suppress($$, (int *)List_Pointer($4, i), fcmp_Integer); } ; IRegion : tINT { List_Reset(ListOfInt_L); List_Add($$ = ListOfInt_L, &($1)); } | tINT tDOTS tINT { List_Reset($$ = ListOfInt_L); for(int j = $1; ($1 < $3) ? (j <= $3) : (j >= $3); ($1 < $3) ? (j += 1) : (j -= 1)) List_Add(ListOfInt_L, &j); } | tINT tDOTS tINT tDOTS tINT { List_Reset($$ = ListOfInt_L); if(!$5 || ($1 < $3 && $5 < 0) || ($1 > $3 && $5 > 0)){ vyyerror("Wrong increment in '%d : %d : %d'", $1, $3, $5); List_Add(ListOfInt_L, &($1)); } else for(int j = $1; ($5 > 0) ? (j <= $3) : (j >= $3); j += $5) List_Add($$, &j); } | String__Index { int i; if((i = List_ISearchSeq(Problem_S.Group, $1, fcmp_Group_Name)) < 0) { // Si ce n'est pas un nom de groupe, est-ce un nom de constante ? : Constant_S.Name = $1; if(!Tree_Query(ConstantTable_L, &Constant_S)) { vyyerror("Unknown Constant: %s", $1); i = 0; List_Reset(ListOfInt_L); List_Add($$ = ListOfInt_L, &i); } else if(Constant_S.Type == VAR_FLOAT) { i = (int)Constant_S.Value.Float; List_Reset(ListOfInt_L); List_Add($$ = ListOfInt_L, &i); } else if(Constant_S.Type == VAR_LISTOFFLOAT) { List_Reset($$ = ListOfInt_L); for(int i = 0; i < List_Nbr(Constant_S.Value.ListOfFloat); i++) { double d; List_Read(Constant_S.Value.ListOfFloat, i, &d); int j = (int)d; List_Add(ListOfInt_L, &j); } } else { vyyerror("Unknown type of Constant: %s", $1); i = 0; List_Reset(ListOfInt_L); List_Add($$ = ListOfInt_L, &i); } } else // Si c'est un nom de groupe : $$ = ((struct Group *)List_Pointer(Problem_S.Group, i))->InitialList; Free($1); } // (.) used to access all the FExpr syntax | '(' FExpr ')' { int i = (int)$2; List_Reset(ListOfInt_L); List_Add($$ = ListOfInt_L, &i); } // (.) used to access all the FExpr syntax | '(' MultiFExpr ')' { List_Reset(ListOfInt_L); for(int i = 0; i < List_Nbr($2); i++) { double d; List_Read($2, i, &d); int j = (int)d; List_Add(ListOfInt_L, &j); } $$ = ListOfInt_L; } // deprecated: for backward compatibility only (for Ruth :-) | '@' MultiFExpr '@' { List_Reset(ListOfInt_L); for(int i = 0; i < List_Nbr($2); i++) { double d; List_Read($2, i, &d); int j = (int)d; List_Add(ListOfInt_L, &j); } $$ = ListOfInt_L; } ; ListOfStringsForCharOptions : /* none */ | tSTRING { CharOptions_S["Strings"].push_back($1); Free($1); } | tINT { char tmp[128]; sprintf(tmp, "%d", $1); CharOptions_S["Strings"].push_back(tmp); } | ListOfStringsForCharOptions ',' tSTRING { CharOptions_S["Strings"].push_back($3); Free($3); } | ListOfStringsForCharOptions ',' tINT { char tmp[128]; sprintf(tmp, "%d", $3); CharOptions_S["Strings"].push_back(tmp); } ; DefineGroups : /* none */ | DefineGroups Comma String__Index { int i; if ( (i = List_ISearchSeq(Problem_S.Group, $3, fcmp_Group_Name)) < 0 ) { Group_S.Type = REGIONLIST ; Group_S.FunctionType = REGION ; Group_S.InitialList = List_Create( 5, 5, sizeof(int)) ; Group_S.SuppListType = SUPPLIST_NONE ; Group_S.InitialSuppList = NULL ; i = Add_Group(&Group_S, $3, false, 0, 0) ; } else Free($3) ; } | DefineGroups Comma String__Index tDEF '{' { FloatOptions_S.clear(); CharOptions_S.clear(); } '{' ListOfStringsForCharOptions '}' CharParameterOptions '}' { int i; if ( (i = List_ISearchSeq(Problem_S.Group, $3, fcmp_Group_Name)) < 0 ) { Group_S.Name = $3; // will be overwritten in Add_Group Group_S.Type = REGIONLIST ; Group_S.FunctionType = REGION ; Group_S.InitialList = List_Create( 5, 5, sizeof(int)) ; if(CharOptions_S.count("Strings")){ std::vector vec(CharOptions_S["Strings"]); for(unsigned int i = 0; i < vec.size(); i++) Fill_GroupInitialListFromString(Group_S.InitialList, vec[i].c_str()); } Message::ExchangeOnelabParameter(&Group_S, FloatOptions_S, CharOptions_S); Group_S.SuppListType = SUPPLIST_NONE ; Group_S.InitialSuppList = NULL ; i = Add_Group(&Group_S, $3, false, 0, 0) ; } else Free($3) ; } | DefineGroups Comma String__Index '{' FExpr '}' { for (int k = 0 ; k < (int)$5 ; k++) { char tmpstr[256]; sprintf(tmpstr, "%s_%d", $3, k+1) ; int i; if ( (i = List_ISearchSeq(Problem_S.Group, tmpstr, fcmp_Group_Name)) < 0 ) { Group_S.Type = REGIONLIST ; Group_S.FunctionType = REGION ; Group_S.SuppListType = SUPPLIST_NONE ; Group_S.InitialSuppList = NULL ; Group_S.InitialList = List_Create( 5, 5, sizeof(int)) ; Add_Group(&Group_S, $3, false, 2, k+1) ; } } Free($3) ; } ; Comma : /* none */ | ',' ; /* ------------------------------------------------------------------------ */ /* F u n c t i o n */ /* ------------------------------------------------------------------------ */ Functions : /* none */ | Functions Function ; Function : tDefineFunction '[' DefineFunctions ']' tEND | String__Index '[' ']' tDEF Expression tEND { int i; if((i = List_ISearchSeq (Problem_S.Expression, $1, fcmp_Expression_Name)) >= 0) { if(((struct Expression *)List_Pointer(Problem_S.Expression, i))->Type == UNDEFINED_EXP) { Free(((struct Expression *)List_Pointer(Problem_S.Expression, i))->Name); List_Read (Problem_S.Expression, $5, &Expression_S); List_Write(Problem_S.Expression, i, &Expression_S); ((struct Expression *)List_Pointer(Problem_S.Expression, i))->Name = $1; List_Pop(Problem_S.Expression); } else { vyyerror("Redefinition of Function: %s", $1); } } else { /* new identifier */ Free(((struct Expression *)List_Pointer(Problem_S.Expression, $5))->Name); ((struct Expression *)List_Pointer(Problem_S.Expression, $5))->Name = $1; } } | String__Index '[' GroupRHS ']' tDEF Expression tEND { int i; if((i = List_ISearchSeq (Problem_S.Expression, $1, fcmp_Expression_Name)) < 0) { /* Si le nom n'existe pas : */ i = List_Nbr(Problem_S.Expression); Expression_S.Type = PIECEWISEFUNCTION; Expression_S.Case.PieceWiseFunction.ExpressionPerRegion = List_Create(5, 5, sizeof(struct ExpressionPerRegion)); Expression_S.Case.PieceWiseFunction.NumLastRegion = -1; Add_Expression(&Expression_S, $1, 0); Expression_P = (struct Expression*)List_Pointer(Problem_S.Expression, i); } else { Expression_P = (struct Expression*)List_Pointer(Problem_S.Expression, i); if(Expression_P->Type == UNDEFINED_EXP) { Expression_P->Type = PIECEWISEFUNCTION; Expression_P->Case.PieceWiseFunction.ExpressionPerRegion = List_Create(5, 5, sizeof(struct ExpressionPerRegion)); Expression_P->Case.PieceWiseFunction.NumLastRegion = -1; } else if(Expression_P->Type != PIECEWISEFUNCTION) vyyerror("Not piece-wise Expression: %s", $1); Free($1); } if($3 >= 0 || $3 == -1) { ExpressionPerRegion_S.ExpressionIndex = $6; for(int i = 0; i < List_Nbr(Group_S.InitialList); i++) { List_Read(Group_S.InitialList, i, &ExpressionPerRegion_S.RegionIndex); if(List_Search(Expression_P->Case.PieceWiseFunction.ExpressionPerRegion, &ExpressionPerRegion_S.RegionIndex, fcmp_Integer)) vyyerror("Redefinition of piece-wise Function: %s [%d]", Expression_P->Name, ExpressionPerRegion_S.RegionIndex); else List_Add(Expression_P->Case.PieceWiseFunction.ExpressionPerRegion, &ExpressionPerRegion_S); } if($3 == -1) { List_Delete(Group_S.InitialList); } } else vyyerror("Bad Group right hand side"); } | Loop ; DefineFunctions : /* none */ | DefineFunctions Comma tSTRING { int i; if ( (i = List_ISearchSeq (Problem_S.Expression, $3, fcmp_Expression_Name)) < 0 ) { Expression_S.Type = UNDEFINED_EXP ; Add_Expression(&Expression_S, $3, 0) ; } else Free($3) ; } | DefineFunctions Comma tSTRING '{' FExpr '}' { for (int k = 0 ; k < (int)$5 ; k++) { char tmpstr[256]; sprintf(tmpstr, "%s_%d", $3, k+1) ; int i; if ( (i = List_ISearchSeq(Problem_S.Expression, tmpstr, fcmp_Expression_Name)) < 0 ) { Expression_S.Type = UNDEFINED_EXP ; Add_Expression(&Expression_S, tmpstr, 2) ; } } Free($3) ; } ; /* ------------------------------------------------------------------------ E x p r e s s i o n s ------------------------------------------------------------------------ */ Expression : /* expressions constantes: evaluees lors de l'analyse syntaxique */ tConstant '[' FExpr ']' { Expression_S.Type = CONSTANT; Expression_S.Case.Constant = $3; $$ = Add_Expression(&Expression_S, (char*)"Exp_Cst", 1); } /* reutilisation de fonctions deja definies en amont */ | tFunction '[' tSTRING ']' { int i; if((i = List_ISearchSeq(Problem_S.Expression, $3, fcmp_Expression_Name)) < 0) vyyerror("Unknown name of Expression: %s", $3); Free($3); $$ = i; } /* whole quantity */ | { Current_DofIndexInWholeQuantity = -2; List_Reset(ListOfPointer_L); List_Reset(ListOfPointer2_L); } WholeQuantityExpression { Expression_S.Type = WHOLEQUANTITY; Expression_S.Case.WholeQuantity = $2; $$ = Add_Expression(&Expression_S, (char*)"Exp_Fct", 1); } /* undefined expression (same as DefineFunction, but inline) */ | '*' '*' '*' { Expression_S.Type = UNDEFINED_EXP; $$ = Add_Expression(&Expression_S, (char*)"Exp_Undefined", 1); } ; ListOfExpression : /* none */ { List_Reset(ListOfInt_L); } /* shift/reduce | Expression { List_Reset(ListOfInt_L); List_Add(ListOfInt_L, &($1)); } */ | '{' RecursiveListOfExpression '}' ; RecursiveListOfExpression : Expression { List_Reset(ListOfInt_L); List_Add(ListOfInt_L, &($1)); } | RecursiveListOfExpression ',' Expression { List_Add(ListOfInt_L, &($3)); } ; WholeQuantityExpression : { Current_WholeQuantity_L = List_Create(5, 5, sizeof(struct WholeQuantity)); List_Add(ListOfPointer_L, &Current_WholeQuantity_L); } WholeQuantity { $$ = *((List_T **)List_Pointer(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1)); List_Pop(ListOfPointer_L); } ; WholeQuantity : WholeQuantity_Single | WholeQuantity '?' { WholeQuantity_S.Type = WQ_TEST; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); WholeQuantity_P = (struct WholeQuantity*) List_Pointer(Current_WholeQuantity_L, List_Nbr(Current_WholeQuantity_L)-1); List_Add(ListOfPointer2_L, &WholeQuantity_P); List_Add(ListOfPointer2_L, &WholeQuantity_P); Current_WholeQuantity_L = List_Create(5, 5, sizeof(struct WholeQuantity)); List_Add(ListOfPointer_L, &Current_WholeQuantity_L); } WholeQuantity tDOTS { WholeQuantity_P = *((struct WholeQuantity**) List_Pointer(ListOfPointer2_L, List_Nbr(ListOfPointer2_L)-1)); List_Pop(ListOfPointer2_L); WholeQuantity_P->Case.Test.WholeQuantity_True = *((List_T **)List_Pointer(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1)); List_Pop(ListOfPointer_L); Current_WholeQuantity_L = List_Create(5, 5, sizeof(struct WholeQuantity)); List_Add(ListOfPointer_L, &Current_WholeQuantity_L); } WholeQuantity { WholeQuantity_P = *((struct WholeQuantity**) List_Pointer(ListOfPointer2_L, List_Nbr(ListOfPointer2_L)-1)); List_Pop(ListOfPointer2_L); WholeQuantity_P->Case.Test.WholeQuantity_False = *((List_T **)List_Pointer(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1)); List_Pop(ListOfPointer_L); List_Read(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1, &Current_WholeQuantity_L); } | WholeQuantity '*' WholeQuantity { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_TIME; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_ProductValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity tCROSSPRODUCT WholeQuantity { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_CROSSPRODUCT; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_CrossProductValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | tCrossProduct '[' WholeQuantity ',' WholeQuantity ']' { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_CROSSPRODUCT; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_CrossProductValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity '/' WholeQuantity { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_DIVIDE; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_DivideValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity '+' WholeQuantity { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_PLUS; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_AddValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity '-' WholeQuantity { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_MINUS; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_SubstractValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity '%' WholeQuantity { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_MODULO; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_ModuloValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity '^' WholeQuantity { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_POWER; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_PowerValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity '<' WholeQuantity { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_LESS; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_LessValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity '>' WholeQuantity { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_GREATER; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_GreaterValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity tLESSOREQUAL WholeQuantity { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_LESSOREQUAL; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_LessOrEqualValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity tGREATEROREQUAL WholeQuantity { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_GREATEROREQUAL; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_GreaterOrEqualValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity tEQUAL WholeQuantity { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_EQUAL; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_EqualValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity tNOTEQUAL WholeQuantity { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_NOTEQUAL; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_NotEqualValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity tAPPROXEQUAL WholeQuantity { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_APPROXEQUAL; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_ApproxEqualValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity tAND WholeQuantity { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_AND; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_AndValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity tOR WholeQuantity { WholeQuantity_S.Type = WQ_BINARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_OR; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_OrValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | '-' WholeQuantity %prec UNARYPREC { WholeQuantity_S.Type = WQ_UNARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_NEG; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_NegValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | '+' WholeQuantity %prec UNARYPREC | '!' WholeQuantity { WholeQuantity_S.Type = WQ_UNARYOPERATOR; WholeQuantity_S.Case.Operator.TypeOperator = OP_NOT; #if defined(HAVE_LEGACY) WholeQuantity_S.Case.Operator.Function = (void (*)())Cal_NotValue; #endif List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | '<' tChangeCurrentPosition '[' WholeQuantity ']' '>' { WholeQuantity_S.Type = WQ_CHANGECURRENTPOSITION ; List_Add(Current_WholeQuantity_L, &WholeQuantity_S) ; WholeQuantity_P = (struct WholeQuantity*) List_Pointer(Current_WholeQuantity_L, List_Nbr(Current_WholeQuantity_L)-1); List_Add(ListOfPointer2_L, &WholeQuantity_P); Current_WholeQuantity_L = List_Create( 5, 5, sizeof(struct WholeQuantity)) ; List_Add(ListOfPointer_L, &Current_WholeQuantity_L) ; } '[' WholeQuantity ']' { WholeQuantity_P = *((struct WholeQuantity**) List_Pointer(ListOfPointer2_L, List_Nbr(ListOfPointer2_L)-1)) ; List_Pop(ListOfPointer2_L) ; WholeQuantity_P->Case.ChangeCurrentPosition.WholeQuantity = *((List_T **)List_Pointer(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1)) ; List_Pop(ListOfPointer_L) ; List_Read(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1, &Current_WholeQuantity_L) ; } ; WholeQuantity_Single : '(' WholeQuantity ')' | OneFExpr { WholeQuantity_S.Type = WQ_CONSTANT; WholeQuantity_S.Case.Constant = $1; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | NameForFunction ArgumentsForFunction ParametersForFunction { /* Expression */ int l; if((l = List_ISearchSeq(Problem_S.Expression, $1, fcmp_Expression_Name)) >= 0) { WholeQuantity_S.Type = WQ_EXPRESSION; WholeQuantity_S.Case.Expression.Index = l; WholeQuantity_S.Case.Expression.NbrArguments = $2; if($2 < 0) vyyerror("Uncompatible argument for Function: %s", $1); } /* Built in functions */ else { Get_Function2NbrForString(F_Function, $1, &FlagError, &WholeQuantity_S.Case.Function.Fct, &WholeQuantity_S.Case.Function.NbrParameters, &WholeQuantity_S.Case.Function.NbrArguments); WholeQuantity_S.Case.Function.Active = NULL; if(!FlagError) { /* arguments */ if($2 >= 0) { if($2 == WholeQuantity_S.Case.Function.NbrArguments) { WholeQuantity_S.Type = WQ_BUILTINFUNCTION; } else if(WholeQuantity_S.Case.Function.NbrArguments == -1 || (WholeQuantity_S.Case.Function.NbrArguments == -2)) { /* && ($2)%2 == 0)) { */ WholeQuantity_S.Type = WQ_BUILTINFUNCTION; WholeQuantity_S.Case.Function.NbrArguments = $2; } else { vyyerror("Wrong number of arguments for Function '%s' (%d instead of %d)", $1, $2, WholeQuantity_S.Case.Function.NbrArguments); } } else { WholeQuantity_S.Type = WQ_EXTERNBUILTINFUNCTION; } /* parameters */ if(WholeQuantity_S.Case.Function.NbrParameters >= 0 && WholeQuantity_S.Case.Function.NbrParameters != List_Nbr($3)) { vyyerror("Wrong number of parameters for Function '%s' (%d instead of %d)", $1, List_Nbr($3), WholeQuantity_S.Case.Function.NbrParameters); } else if(WholeQuantity_S.Case.Function.NbrParameters == -2 && List_Nbr($3)%2 != 0) { vyyerror("Wrong number of parameters for Function '%s' (%d is not even)", $1, List_Nbr($3)); } else { WholeQuantity_S.Case.Function.NbrParameters = List_Nbr($3); if(WholeQuantity_S.Case.Function.NbrParameters > 0) { WholeQuantity_S.Case.Function.Para = (double *)Malloc (WholeQuantity_S.Case.Function.NbrParameters * sizeof(double)); for(int i = 0; i < WholeQuantity_S.Case.Function.NbrParameters; i++) List_Read($3, i, &WholeQuantity_S.Case.Function.Para[i]); } } } else { vyyerror("Unknown Function: %s", $1); } } List_Add(Current_WholeQuantity_L, &WholeQuantity_S); List_Delete($3); } | tSTRING Quantity_Def { WholeQuantity_S.Type = WQ_OPERATORANDQUANTITY; WholeQuantity_S.Case.OperatorAndQuantity.NbrArguments = 0; WholeQuantity_S.Case.OperatorAndQuantity.TypeQuantity = Get_DefineForString(QuantityFromFS_Type, $1, &FlagError); if(FlagError){ vyyerror("Unknown type of discrete Quantity: %s", $1); Get_Valid_SXD(QuantityFromFS_Type); } Free($1); WholeQuantity_S.Case.OperatorAndQuantity.TypeOperator = $2.Int1; WholeQuantity_S.Case.OperatorAndQuantity.Index = $2.Int2; switch(WholeQuantity_S.Case.OperatorAndQuantity.TypeQuantity) { case QUANTITY_DOF : if(Current_DofIndexInWholeQuantity == -1) Current_DofIndexInWholeQuantity = List_Nbr(Current_WholeQuantity_L); else if(Current_DofIndexInWholeQuantity == -2) vyyerror("Dof{} definition out of context"); else vyyerror("More than one Dof definition in Expression"); break; case QUANTITY_NODOF : if(Current_DofIndexInWholeQuantity == -2) vyyerror("NoDof definition out of context"); else if(Current_NoDofIndexInWholeQuantity == -1) Current_NoDofIndexInWholeQuantity = List_Nbr(Current_WholeQuantity_L); else vyyerror("More than one NoDof definition in Expression"); break; } List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | Quantity_Def { WholeQuantity_S.Type = WQ_OPERATORANDQUANTITY; WholeQuantity_S.Case.OperatorAndQuantity.NbrArguments = 0; WholeQuantity_S.Case.OperatorAndQuantity.TypeQuantity = QUANTITY_SIMPLE; WholeQuantity_S.Case.OperatorAndQuantity.TypeOperator = $1.Int1; WholeQuantity_S.Case.OperatorAndQuantity.Index = $1.Int2; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | Quantity_Def ArgumentsForFunction { if($2 != 1 && $2 != 2 && $2 != 3 && $2 != 4) vyyerror("Wrong number of arguments for discrete quantity evaluation (%d)", $2); WholeQuantity_S.Type = WQ_OPERATORANDQUANTITYEVAL; WholeQuantity_S.Case.OperatorAndQuantity.NbrArguments = $2; WholeQuantity_S.Case.OperatorAndQuantity.TypeQuantity = QUANTITY_SIMPLE; WholeQuantity_S.Case.OperatorAndQuantity.TypeOperator = $1.Int1; WholeQuantity_S.Case.OperatorAndQuantity.Index = $1.Int2; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | tDt { Last_DofIndexInWholeQuantity = Current_DofIndexInWholeQuantity; } '[' WholeQuantityExpression ']' { WholeQuantity_S.Type = WQ_TIMEDERIVATIVE; WholeQuantity_S.Case.TimeDerivative.WholeQuantity = $4; List_Read(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1, &Current_WholeQuantity_L); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); if(Current_DofIndexInWholeQuantity != Last_DofIndexInWholeQuantity) vyyerror("Dof{} definition out of context"); } | tAtAnteriorTimeStep { Last_DofIndexInWholeQuantity = Current_DofIndexInWholeQuantity; } '[' WholeQuantityExpression ',' tINT ']' { WholeQuantity_S.Type = WQ_ATANTERIORTIMESTEP; WholeQuantity_S.Case.AtAnteriorTimeStep.WholeQuantity = $4; WholeQuantity_S.Case.AtAnteriorTimeStep.TimeStep = $6; List_Read(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1, &Current_WholeQuantity_L); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); if(Current_DofIndexInWholeQuantity != Last_DofIndexInWholeQuantity) vyyerror("Dof{} definition out of context"); } | tMHTransform '[' tSTRING '[' { Last_DofIndexInWholeQuantity = Current_DofIndexInWholeQuantity; } WholeQuantityExpression ']' ']' '{' FExpr '}' { int i; if((i = List_ISearchSeq(Problem_S.Expression, $3,fcmp_Expression_Name)) < 0) vyyerror("Undefined function '%s' used in MHTransform", $3); if(Current_DofIndexInWholeQuantity != Last_DofIndexInWholeQuantity) vyyerror("Dof{} definition cannot be used in MHTransform"); WholeQuantity_S.Type = WQ_MHTRANSFORM; WholeQuantity_S.Case.MHTransform.Index = i; WholeQuantity_S.Case.MHTransform.WholeQuantity = $6; WholeQuantity_S.Case.MHTransform.NbrPoints = (int)$10; List_Read(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1, &Current_WholeQuantity_L); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | tMHJacNL '[' tSTRING ']' '{' FExpr ',' FExpr '}' { int i; if((i = List_ISearchSeq(Problem_S.Expression, $3,fcmp_Expression_Name)) < 0) vyyerror("Undefined function '%s' used in MHJacNL", $3); WholeQuantity_S.Type = WQ_MHJACNL; WholeQuantity_S.Case.MHJacNL.Index = i; WholeQuantity_S.Case.MHJacNL.NbrPoints = (int)$6; WholeQuantity_S.Case.MHJacNL.FreqOffSet = (int)$8; List_Read(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1, &Current_WholeQuantity_L); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | tSolidAngle '[' Quantity_Def ']' { WholeQuantity_S.Type = WQ_SOLIDANGLE; WholeQuantity_S.Case.OperatorAndQuantity.Index = $3.Int2; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | tOrder '[' Quantity_Def ']' { WholeQuantity_S.Type = WQ_ORDER; WholeQuantity_S.Case.OperatorAndQuantity.Index = $3.Int2; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | tTrace { Last_DofIndexInWholeQuantity = Current_DofIndexInWholeQuantity; } '[' WholeQuantityExpression ',' GroupRHS ']' { WholeQuantity_S.Type = WQ_TRACE; WholeQuantity_S.Case.Trace.WholeQuantity = $4; WholeQuantity_S.Case.Trace.InIndex = Num_Group(&Group_S, (char*)"WQ_Trace_In", $6); if(Group_S.Type != ELEMENTLIST || Group_S.SuppListType != SUPPLIST_CONNECTEDTO) vyyerror("Group for Trace should be of Type 'ElementsOf[x, ConnectedTo y]'"); WholeQuantity_S.Case.Trace.DofIndexInWholeQuantity = -1; if(Current_DofIndexInWholeQuantity != Last_DofIndexInWholeQuantity){ for(int i = 0; i < List_Nbr($4); i++){ WholeQuantity_P = (struct WholeQuantity*)List_Pointer($4, i); if(WholeQuantity_P->Type == WQ_OPERATORANDQUANTITY) if(WholeQuantity_P->Case.OperatorAndQuantity.TypeQuantity == QUANTITY_DOF){ WholeQuantity_S.Case.Trace.DofIndexInWholeQuantity = i; Current_DofIndexInWholeQuantity = -4; TypeOperatorDofInTrace = WholeQuantity_P->Case.OperatorAndQuantity.TypeOperator; DefineQuantityIndexDofInTrace = WholeQuantity_P->Case.OperatorAndQuantity.Index; } } if(Current_DofIndexInWholeQuantity != -4) vyyerror("Dof{} definition out of context in Trace operator"); } List_Read(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1, &Current_WholeQuantity_L); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | '<' tSTRING '>' '[' WholeQuantityExpression ']' { WholeQuantity_S.Type = WQ_CAST; WholeQuantity_S.Case.Cast.WholeQuantity = $5; int i; if((i = List_ISearchSeq(Formulation_S.DefineQuantity, $2, fcmp_DefineQuantity_Name)) < 0) { if(!strcmp($2, "Real")) WholeQuantity_S.Case.Cast.NbrHar = 1; else if(!strcmp($2, "Complex")) WholeQuantity_S.Case.Cast.NbrHar = 2; else vyyerror("Unknown Cast: %s", $2); } else { WholeQuantity_S.Case.Cast.NbrHar = 0; WholeQuantity_S.Case.Cast.FunctionSpaceIndexForType = ((struct DefineQuantity *)List_Pointer(Formulation_S.DefineQuantity, i)) ->FunctionSpaceIndex; } Free($2); List_Read(ListOfPointer_L, List_Nbr(ListOfPointer_L)-1, &Current_WholeQuantity_L); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | '$' tSTRING { WholeQuantity_S.Type = WQ_CURRENTVALUE; Get_PointerForString(Current_Value, $2, &FlagError, (void **)&WholeQuantity_S.Case.CurrentValue.Value); if(FlagError){ vyyerror("Unknown current value: $%s", $2); Get_Valid_SXP(Current_Value); } Free($2); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } /* a changer */ | '$' tTimeStep { WholeQuantity_S.Type = WQ_CURRENTVALUE; Get_PointerForString(Current_Value, "TimeStep", &FlagError, (void **)&WholeQuantity_S.Case.CurrentValue.Value); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | '$' tDTime { WholeQuantity_S.Type = WQ_CURRENTVALUE; Get_PointerForString(Current_Value, "DTime", &FlagError, (void **)&WholeQuantity_S.Case.CurrentValue.Value); List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | '$' tINT { WholeQuantity_S.Type = WQ_ARGUMENT; WholeQuantity_S.Case.Argument.Index = $2; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity_Single '#' tINT { WholeQuantity_S.Type = WQ_SAVEVALUE; WholeQuantity_S.Case.SaveValue.Index = $3 - 1; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | '#' tINT { WholeQuantity_S.Type = WQ_VALUESAVED; WholeQuantity_S.Case.ValueSaved.Index = $2 - 1; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | WholeQuantity_Single tSHOW FExpr { WholeQuantity_S.Type = WQ_SHOWVALUE; WholeQuantity_S.Case.ShowValue.Index = (int)$3; List_Add(Current_WholeQuantity_L, &WholeQuantity_S); } | StrCmp { WholeQuantity_S.Type = WQ_CONSTANT ; WholeQuantity_S.Case.Constant = $1 ; List_Add(Current_WholeQuantity_L, &WholeQuantity_S) ; } | NbrRegions { WholeQuantity_S.Type = WQ_CONSTANT ; WholeQuantity_S.Case.Constant = $1 ; List_Add(Current_WholeQuantity_L, &WholeQuantity_S) ; } ; ArgumentsForFunction : '[' '.' ']' { $$ = -1; } | '[' ']' { $$ = 0; } | '[' RecursiveListOfQuantity ']' { $$ = $2; } ; RecursiveListOfQuantity : WholeQuantity { $$ = 1; } | RecursiveListOfQuantity ',' WholeQuantity { $$ = $1 + 1; } ; ParametersForFunction : /* none */ { $$ = NULL; } | '{' RecursiveListOfFExpr '}' { $$ = $2; } | '{' tRegion '[' GroupRHS ']' '}' { /* Attention: provisoire. Note: Impossible a mettre dans MultiFExpr car conflit avec Affectation dans Group */ $$ = List_Create(2, 1, sizeof(double)); double d = (double)Num_Group(&Group_S, (char*)"PA_Region", $4); List_Add($$, &d); } ; /* ------------------------------------------------------------------------ */ /* J a c o b i a n M e t h o d */ /* ------------------------------------------------------------------------ */ JacobianMethods : /* none */ { if(!Problem_S.JacobianMethod) Problem_S.JacobianMethod = List_Create(5, 5, sizeof (struct JacobianMethod)); } | JacobianMethods '{' JacobianMethod '}' { List_Add(Problem_S.JacobianMethod, &JacobianMethod_S); } ; JacobianMethod : /* none */ { JacobianMethod_S.Name = NULL; JacobianMethod_S.JacobianCase = NULL; } | JacobianMethod JacobianMethodTerm ; JacobianMethodTerm : tName String__Index tEND { Check_NameOfStructNotExist("JacobianMethod", Problem_S.JacobianMethod, $2, fcmp_JacobianMethod_Name); JacobianMethod_S.Name = $2; } | tCase '{' JacobianCases '}' { JacobianMethod_S.JacobianCase = $3; } ; JacobianCases : /* none */ { $$ = List_Create(5, 5, sizeof (struct JacobianCase)); } | JacobianCases '{' JacobianCase '}' { List_Add($$ = $1, &JacobianCase_S); } ; JacobianCase : /* none */ { JacobianCase_S.RegionIndex = -1; JacobianCase_S.TypeJacobian = JACOBIAN_VOL; } | JacobianCase JacobianCaseTerm ; JacobianCaseTerm : tRegion GroupRHS tEND { JacobianCase_S.RegionIndex = Num_Group(&Group_S, (char*)"JA_Region", $2); } | tRegion tAll tEND { JacobianCase_S.RegionIndex = -1; } | tJacobian String__Index ParametersForFunction tEND { JacobianCase_S.TypeJacobian = Get_Define1NbrForString(Jacobian_Type, $2, &FlagError, &JacobianCase_S.NbrParameters); if(!FlagError) { if(JacobianCase_S.NbrParameters == -2 && (List_Nbr($3))%2 != 0) vyyerror("Wrong number of parameters for Jacobian '%s' (%d is not even)", $2, List_Nbr($3)); if(JacobianCase_S.NbrParameters < 0) JacobianCase_S.NbrParameters = List_Nbr($3); if(List_Nbr($3) == JacobianCase_S.NbrParameters) { if(JacobianCase_S.NbrParameters) { JacobianCase_S.Para = (double *)Malloc(JacobianCase_S.NbrParameters * sizeof(double)); for(int i = 0; i < JacobianCase_S.NbrParameters; i++) List_Read($3, i, &JacobianCase_S.Para[i]); } } else vyyerror("Wrong number of parameters for Jacobian '%s' (%d instead of %d)", $2, List_Nbr($3), JacobianCase_S.NbrParameters); } else{ vyyerror("Unknown type of Jacobian: %s", $2); Get_Valid_SXD1N(Jacobian_Type); } Free($2); List_Delete($3); } ; /* ------------------------------------------------------------------------ */ /* I n t e g r a t i o n M e t h o d */ /* ------------------------------------------------------------------------ */ IntegrationMethods : /* none */ { if(!Problem_S.IntegrationMethod) Problem_S.IntegrationMethod = List_Create(5, 5, sizeof(struct IntegrationMethod)); } | IntegrationMethods '{' IntegrationMethod '}' { List_Add(Problem_S.IntegrationMethod, &IntegrationMethod_S); } ; IntegrationMethod : /* none */ { IntegrationMethod_S.Name = NULL; IntegrationMethod_S.IntegrationCase = NULL; IntegrationMethod_S.CriterionIndex = -1; } | IntegrationMethod IntegrationMethodTerm ; IntegrationMethodTerm : tName tSTRING tEND { Check_NameOfStructNotExist("IntegrationMethod", Problem_S.IntegrationMethod, $2, fcmp_IntegrationMethod_Name); IntegrationMethod_S.Name = $2; } | tCriterion Expression tEND { IntegrationMethod_S.CriterionIndex = $2; } | tCase '{' IntegrationCases '}' { IntegrationMethod_S.IntegrationCase = $3; } ; IntegrationCases : /* none */ { $$ = List_Create(5, 5, sizeof (struct IntegrationCase)); } | IntegrationCases '{' IntegrationCase '}' { List_Add($$ = $1, &IntegrationCase_S); } ; IntegrationCase : /* none */ { IntegrationCase_S.Type = GAUSS; IntegrationCase_S.SubType = STANDARD; } | IntegrationCase IntegrationCaseTerm ; IntegrationCaseTerm : tType tSTRING tEND { IntegrationCase_S.Type = Get_DefineForString(Integration_Type, $2, &FlagError); if(FlagError){ vyyerror("Unknown type of Integration method: %s", $2); Get_Valid_SXD(Integration_Type); } Free($2); } | tSubType tSTRING tEND { IntegrationCase_S.SubType = Get_DefineForString(Integration_SubType, $2, &FlagError); if(FlagError){ vyyerror("Unknown subtype of Integration method: %s", $2); Get_Valid_SXD(Integration_Type); } Free($2); } | tCase '{' QuadratureCases '}' { IntegrationCase_S.Case = $3; } ; QuadratureCases : /* none */ { $$ = List_Create(5, 5, sizeof (struct Quadrature)); } | QuadratureCases '{' QuadratureCase '}' { List_Add($$ = $1, &QuadratureCase_S); } ; QuadratureCase : /* none */ { QuadratureCase_S.ElementType = TRIANGLE; QuadratureCase_S.NumberOfPoints = 4; QuadratureCase_S.MaxNumberOfPoints = 4; QuadratureCase_S.NumberOfDivisions = 1; QuadratureCase_S.MaxNumberOfDivisions = 1; QuadratureCase_S.StoppingCriterion = 1.E-4; QuadratureCase_S.Function = 0; //FIXME(void (*)())Gauss_Triangle; } | QuadratureCase QuadratureCaseTerm ; QuadratureCaseTerm : tGeoElement tSTRING tEND { QuadratureCase_S.ElementType = Get_DefineForString(Element_Type, $2, &FlagError); if(FlagError){ vyyerror("Unknown type of Element: %s", $2); Get_Valid_SXD(Element_Type); } switch(IntegrationCase_S.SubType) { case STANDARD : switch (IntegrationCase_S.Type) { case GAUSS : Get_FunctionForDefine (FunctionForGauss, QuadratureCase_S.ElementType, &FlagError, (void (**)())&QuadratureCase_S.Function); break; case GAUSSLEGENDRE : Get_FunctionForDefine (FunctionForGaussLegendre, QuadratureCase_S.ElementType, &FlagError, (void (**)())&QuadratureCase_S.Function); break; default : vyyerror("Incompatible type of Integration method"); break; } break; case SINGULAR : switch (IntegrationCase_S.Type) { case GAUSS : Get_FunctionForDefine (FunctionForSingularGauss, QuadratureCase_S.ElementType, &FlagError, (void (**)())&QuadratureCase_S.Function); break; default : vyyerror("Incompatible type of Integration method"); break; } break; default : vyyerror("Incompatible type of Integration method"); break; } if(FlagError) vyyerror("Bad type of Integration method for Element: %s", $2); Free($2); } | tNumberOfPoints FExpr tEND { QuadratureCase_S.NumberOfPoints = (int)$2; } | tMaxNumberOfPoints FExpr tEND { QuadratureCase_S.MaxNumberOfPoints = (int)$2; } | tNumberOfDivisions FExpr tEND { QuadratureCase_S.NumberOfDivisions = (int)$2; } | tMaxNumberOfDivisions FExpr tEND { QuadratureCase_S.MaxNumberOfDivisions = (int)$2; } | tStoppingCriterion FExpr tEND { QuadratureCase_S.StoppingCriterion = $2; } ; /* ------------------------------------------------------------------------ */ /* C o n s t r a i n t */ /* ------------------------------------------------------------------------ */ Constraints : /* none */ { if(!Problem_S.Constraint) Problem_S.Constraint = List_Create(20, 20, sizeof (struct Constraint)); } | Constraints BracedConstraint ; BracedConstraint : '{' Constraint '}' { List_Add(Problem_S.Constraint, &Constraint_S); } | Loop ; Constraint : /* none */ { Constraint_S.Name = NULL; Constraint_S.Type = ASSIGN; Constraint_S.ConstraintPerRegion = NULL; Constraint_S.MultiConstraintPerRegion = NULL; } | Constraint ConstraintTerm ; ConstraintTerm : tName String__Index tEND { Check_NameOfStructNotExist("Constraint", Problem_S.Constraint, $2, fcmp_Constraint_Name); Constraint_S.Name = $2; } | tType tSTRING tEND { Constraint_S.Type = Get_DefineForString(Constraint_Type, $2, &FlagError); if(FlagError){ vyyerror("Unknown type of Constraint: %s", $2); Get_Valid_SXD(Constraint_Type); } Free($2); } | tCase '{' ConstraintCases '}' { Constraint_S.ConstraintPerRegion = $3; } | tCase tSTRING '{' ConstraintCases '}' { if(!Constraint_S.MultiConstraintPerRegion) Constraint_S.MultiConstraintPerRegion = List_Create(5, 5, sizeof(struct MultiConstraintPerRegion)); MultiConstraintPerRegion_S.Name = $2; MultiConstraintPerRegion_S.ConstraintPerRegion = $4; MultiConstraintPerRegion_S.Active = NULL; List_Add(Constraint_S.MultiConstraintPerRegion, &MultiConstraintPerRegion_S); } ; ConstraintCases : /* none */ { $$ = List_Create(6, 6, sizeof (struct ConstraintPerRegion)); } | ConstraintCases '{' ConstraintCase '}' { List_Add($$ = $1, &ConstraintPerRegion_S); } | ConstraintCases Loop { $$ = $1; } ; ConstraintCase : /* none */ { ConstraintPerRegion_S.Type = Constraint_S.Type; ConstraintPerRegion_S.RegionIndex = -1; ConstraintPerRegion_S.SubRegionIndex = -1; ConstraintPerRegion_S.TimeFunctionIndex = -1; } | ConstraintCase ConstraintCaseTerm ; ConstraintCaseTerm : tType tSTRING tEND { ConstraintPerRegion_S.Type = Get_DefineForString(Constraint_Type, $2, &FlagError); if(FlagError){ vyyerror("Unknown type of Constraint: %s", $2); Get_Valid_SXD(Constraint_Type); } Free($2); } | tRegion GroupRHS tEND { ConstraintPerRegion_S.RegionIndex = Num_Group(&Group_S, (char*)"CO_Region", $2); } | tSubRegion GroupRHS tEND { ConstraintPerRegion_S.SubRegionIndex = Num_Group(&Group_S, (char*)"CO_SubRegion", $2); } | tTimeFunction Expression tEND { ConstraintPerRegion_S.TimeFunctionIndex = $2; if(Is_ExpressionPieceWiseDefined($2)) vyyerror("TimeFunction should never be piece-wise defined"); } | tValue Expression tEND { if(ConstraintPerRegion_S.Type == ASSIGN || ConstraintPerRegion_S.Type == INIT){ ConstraintPerRegion_S.Case.Fixed.ExpressionIndex = $2; ConstraintPerRegion_S.Case.Fixed.ExpressionIndex2 = -1; } else vyyerror("Value incompatible with Type"); } | tValue '[' Expression ',' Expression ']' tEND { if(ConstraintPerRegion_S.Type == ASSIGN || ConstraintPerRegion_S.Type == INIT){ ConstraintPerRegion_S.Case.Fixed.ExpressionIndex = $5; ConstraintPerRegion_S.Case.Fixed.ExpressionIndex2 = $3; } else vyyerror("Value incompatible with Type"); } | tNameOfResolution String__Index tEND { if(ConstraintPerRegion_S.Type == ASSIGNFROMRESOLUTION || ConstraintPerRegion_S.Type == INITFROMRESOLUTION) ConstraintPerRegion_S.Case.Solve.ResolutionName = $2; else vyyerror("NameOfResolution incompatible with Type"); } | tBranch '{' OneFExpr Comma OneFExpr '}' tEND { if(ConstraintPerRegion_S.Type == NETWORK) { ConstraintPerRegion_S.Case.Network.Node1 = (int)$3; ConstraintPerRegion_S.Case.Network.Node2 = (int)$5; } else vyyerror("Branch incompatible with Type"); } | tRegionRef GroupRHS tEND { if(ConstraintPerRegion_S.Type == CST_LINK || ConstraintPerRegion_S.Type == CST_LINKCPLX) { ConstraintPerRegion_S.Case.Link.RegionRefIndex = Num_Group(&Group_S, (char*)"CO_RegionRef", $2); ConstraintPerRegion_S.Case.Link.SubRegionRefIndex = -1; ConstraintPerRegion_S.Case.Link.FilterIndex = -1; ConstraintPerRegion_S.Case.Link.FunctionIndex = -1; ConstraintPerRegion_S.Case.Link.CoefIndex = -1; ConstraintPerRegion_S.Case.Link.FilterIndex2 = -1; ConstraintPerRegion_S.Case.Link.FunctionIndex2 = -1; ConstraintPerRegion_S.Case.Link.CoefIndex2 = -1; } else vyyerror("RegionRef incompatible with Type"); } | tSubRegionRef GroupRHS tEND { if(ConstraintPerRegion_S.Type == CST_LINK || ConstraintPerRegion_S.Type == CST_LINKCPLX) ConstraintPerRegion_S.Case.Link.SubRegionRefIndex = Num_Group(&Group_S, (char*)"CO_RegionRef", $2); else vyyerror("SubRegionRef incompatible with Type"); } | tFunction Expression tEND { if(ConstraintPerRegion_S.Type == CST_LINK || ConstraintPerRegion_S.Type == CST_LINKCPLX) ConstraintPerRegion_S.Case.Link.FunctionIndex = $2; else vyyerror("Function incompatible with Type"); } | tCoefficient Expression tEND { if(ConstraintPerRegion_S.Type == CST_LINK || ConstraintPerRegion_S.Type == CST_LINKCPLX) ConstraintPerRegion_S.Case.Link.CoefIndex = $2; else vyyerror("Coefficient incompatible with Type"); } | tFilter Expression tEND { if(ConstraintPerRegion_S.Type == CST_LINK || ConstraintPerRegion_S.Type == CST_LINKCPLX) { ConstraintPerRegion_S.Case.Link.FilterIndex = $2; ConstraintPerRegion_S.Case.Link.FilterIndex2 = -1; } else vyyerror("Filter incompatible with Type"); } | tFunction '[' Expression ',' Expression ']' tEND { if(ConstraintPerRegion_S.Type == CST_LINK || ConstraintPerRegion_S.Type == CST_LINKCPLX) { ConstraintPerRegion_S.Case.Link.FunctionIndex = $3; ConstraintPerRegion_S.Case.Link.FunctionIndex2 = $5; } else vyyerror("Function incompatible with Type"); } | tCoefficient '[' Expression ',' Expression ']' tEND { if(ConstraintPerRegion_S.Type == CST_LINK || ConstraintPerRegion_S.Type == CST_LINKCPLX) { ConstraintPerRegion_S.Case.Link.CoefIndex = $3; ConstraintPerRegion_S.Case.Link.CoefIndex2 = $5; } else vyyerror("Coefficient incompatible with Type"); } | tFilter '[' Expression ',' Expression ']' tEND { if(ConstraintPerRegion_S.Type == CST_LINK || ConstraintPerRegion_S.Type == CST_LINKCPLX) { ConstraintPerRegion_S.Case.Link.FilterIndex = $3; ConstraintPerRegion_S.Case.Link.FilterIndex2 = $5; } else vyyerror("Filter incompatible with Type"); } ; /* ------------------------------------------------------------------------ */ /* F u n c t i o n S p a c e */ /* ------------------------------------------------------------------------ */ FunctionSpaces : /* none */ { if(!Problem_S.FunctionSpace) Problem_S.FunctionSpace = List_Create(10, 5, sizeof (struct FunctionSpace)); } | FunctionSpaces BracedFunctionSpace ; BracedFunctionSpace : '{' FunctionSpace '}' { List_Add(Problem_S.FunctionSpace, &FunctionSpace_S); } | Loop ; FunctionSpace : /* none */ { FunctionSpace_S.Name = NULL; FunctionSpace_S.Type = FORM0; FunctionSpace_S.BasisFunction = FunctionSpace_S.SubSpace = FunctionSpace_S.GlobalQuantity = FunctionSpace_S.Constraint = NULL; } | FunctionSpace FunctionSpaceTerm | FunctionSpace Loop ; FunctionSpaceTerm : tName String__Index tEND { Check_NameOfStructNotExist("FunctionSpace", Problem_S.FunctionSpace, $2, fcmp_FunctionSpace_Name); FunctionSpace_S.Name = $2; } | tType tSTRING tEND { FunctionSpace_S.Type = Get_DefineForString(Field_Type, $2, &FlagError); if(FlagError){ vyyerror("Unknown type of FunctionSpace: %s", $2); Get_Valid_SXD(Field_Type); } Free($2); } | tBasisFunction '{' BasisFunctions '}' { FunctionSpace_S.BasisFunction = $3; } | tSubSpace '{' SubSpaces '}' { FunctionSpace_S.SubSpace = $3; } | tGlobalQuantity '{' GlobalQuantities '}' { FunctionSpace_S.GlobalQuantity = $3; } | tConstraint '{' ConstraintInFSs '}' { FunctionSpace_S.Constraint = $3; } ; BasisFunctions : /* none */ { $$ = Current_BasisFunction_L = List_Create(6, 6, sizeof (struct BasisFunction)); } | BasisFunctions '{' BasisFunction '}' { int i; if((i = List_ISearchSeq($1, BasisFunction_S.Name, fcmp_BasisFunction_Name)) < 0) { /* BasisFunction_S.Num = Num_BasisFunction++; */ BasisFunction_S.Num = Num_BasisFunction; Num_BasisFunction += (BasisFunction_S.SubFunction)? List_Nbr(BasisFunction_S.SubFunction) : 1; } else /* BasisFunction definie par morceaux => meme Num */ BasisFunction_S.Num = ((struct BasisFunction *)List_Pointer($1, i))->Num; List_Add($$ = $1, &BasisFunction_S); } | BasisFunctions Loop { $$ = $1; } ; BasisFunction : /* none */ { BasisFunction_S.Name = NULL; BasisFunction_S.NameOfCoef = NULL; BasisFunction_S.Num = 0; BasisFunction_S.GlobalBasisFunction = NULL; BasisFunction_S.Function = NULL; BasisFunction_S.dFunction = NULL; BasisFunction_S.dInvFunction = NULL; BasisFunction_S.SubFunction = NULL; BasisFunction_S.SubdFunction = NULL; BasisFunction_S.SupportIndex = -1; BasisFunction_S.EntityIndex = -1; } | BasisFunction BasisFunctionTerm ; BasisFunctionTerm : tName String__Index tEND { BasisFunction_S.Name = $2; } | tNameOfCoef String__Index tEND { Check_NameOfStructNotExist("NameOfCoef", Current_BasisFunction_L, $2, fcmp_BasisFunction_NameOfCoef); BasisFunction_S.NameOfCoef = $2; BasisFunction_S.Dimension = 1; } | tFunction tSTRING OptionalParametersForBasisFunction tEND { Get_3Function3NbrForString (BF_Function, $2, &FlagError, &BasisFunction_S.Function, &BasisFunction_S.dFunction, &BasisFunction_S.dInvFunction, &BasisFunction_S.Order, &BasisFunction_S.ElementType, &BasisFunction_S.Orient); if(FlagError){ vyyerror("Unknown Function for BasisFunction: %s", $2); Get_Valid_SX3F3N(BF_Function); } Free($2); } | tdFunction '{' tSTRING Comma tSTRING '}' tEND { void (*FunctionDummy)(); int i, j; double d; Get_3Function3NbrForString (BF_Function, $3, &FlagError, &BasisFunction_S.dFunction, &FunctionDummy, &FunctionDummy, &d, &i, &j); if(FlagError){ vyyerror("Unknown dFunction (1) for BasisFunction: %s", $3); Get_Valid_SX3F3N(BF_Function); } Free($3); Get_3Function3NbrForString (BF_Function, $5, &FlagError, &BasisFunction_S.dInvFunction, &FunctionDummy, &FunctionDummy, &d, &i, &j); if(FlagError){ vyyerror("Unknown dFunction (2) for BasisFunction: %s", $5); Get_Valid_SX3F3N(BF_Function); } Free($5); } | tSubFunction ListOfExpression tEND { BasisFunction_S.SubFunction = List_Copy(ListOfInt_L); } | tSubdFunction ListOfExpression tEND { BasisFunction_S.SubdFunction = List_Copy(ListOfInt_L); } | tSupport GroupRHS tEND { BasisFunction_S.SupportIndex = Num_Group(&Group_S, (char*)"BF_Support", $2); } | tEntity GroupRHS tEND { BasisFunction_S.EntityIndex = Num_Group(&Group_S, (char*)"BF_Entity", $2); if(Group_S.InitialList) List_Sort(Group_S.InitialList, fcmp_Integer); /* Needed for Global Region */ if(BasisFunction_S.GlobalBasisFunction) { /* Function to be defined before Entity */ if(Group_S.FunctionType == GLOBAL) { if(List_Nbr(BasisFunction_S.GlobalBasisFunction) == List_Nbr(Group_S.InitialList)) { for(int k = 0; k < List_Nbr(Group_S.InitialList); k++) if(*((int*)List_Pointer(Group_S.InitialList, k)) != *((int*)List_Pointer(BasisFunction_S.GlobalBasisFunction, k))) { vyyerror("Bad correspondance between Group and Entity (elements differ)"); break; } } else if(List_Nbr(Group_S.InitialList) != 0 || GlobalBasisFunction_S.EntityIndex != -1) vyyerror("Bad correspondance between Group and Entity (#BF %d, #Global %d)", List_Nbr(BasisFunction_S.GlobalBasisFunction), List_Nbr(Group_S.InitialList)); } else vyyerror("Bad correspondance between Group and Entity (Entity must be Global)"); } } ; OptionalParametersForBasisFunction : /* none */ | '{' tQuantity tSTRING tEND tFormulation tSTRING '{' FExpr '}' tEND tGroup GroupRHS tEND tResolution tSTRING '{' FExpr '}' tEND '}' { int dim = $8; if(dim != $17) vyyerror("Number of formulations different from number of resolutions"); if(List_Nbr(Group_S.InitialList) != dim) vyyerror("Group sould have %d single regions", dim); BasisFunction_S.GlobalBasisFunction = List_Create(dim, 1, sizeof(struct GlobalBasisFunction)); for(int k = 0; k < dim; k++) { int i; List_Read(Group_S.InitialList, k, &i); GlobalBasisFunction_S.EntityIndex = i; char tmpstr[256]; sprintf(tmpstr, "%s_%d", $6, k+1); if((i = List_ISearchSeq(Problem_S.Formulation, tmpstr, fcmp_Formulation_Name)) >= 0) { GlobalBasisFunction_S.FormulationIndex = i; List_Read(Problem_S.Formulation, i, &Formulation_S); if((i = List_ISearchSeq(Formulation_S.DefineQuantity, $3, fcmp_DefineQuantity_Name)) >= 0) GlobalBasisFunction_S.DefineQuantityIndex = i; else { vyyerror("Unknown Quantity '%s' in Formulation '%s'", $3, Formulation_S.Name); break; } } else vyyerror("Unknown Formulation: %s", tmpstr); sprintf(tmpstr, "%s_%d", $15, k+1); if((i = List_ISearchSeq(Problem_S.Resolution, tmpstr, fcmp_Resolution_Name)) >= 0) GlobalBasisFunction_S.ResolutionIndex = i; else vyyerror("Unknown Resolution: %s", tmpstr); GlobalBasisFunction_S.QuantityStorage = NULL; List_Add(BasisFunction_S.GlobalBasisFunction, &GlobalBasisFunction_S); } List_Sort(BasisFunction_S.GlobalBasisFunction, fcmp_Integer); Free($3); Free($6); Free($15); } ; SubSpaces : /* none */ { $$ = Current_SubSpace_L = List_Create(6, 6, sizeof (struct SubSpace)); } | SubSpaces '{' SubSpace '}' { List_Add($$ = $1, &SubSpace_S); } ; SubSpace : /* none */ { SubSpace_S.Name = NULL; SubSpace_S.BasisFunction = NULL; } | SubSpace SubSpaceTerm ; SubSpaceTerm : tName tSTRING tEND { Check_NameOfStructNotExist("SubSpace", Current_SubSpace_L, $2, fcmp_SubSpace_Name); SubSpace_S.Name = $2; } | tNameOfBasisFunction ListOfBasisFunction tEND { SubSpace_S.BasisFunction = $2; } | tNameOfCoef ListOfBasisFunctionCoef tEND { SubSpace_S.BasisFunction = $2; } ; ListOfBasisFunction : tSTRING { $$ = List_Create(1, 1, sizeof(int)); int i; if((i = List_ISearchSeq(Current_BasisFunction_L, $1, fcmp_BasisFunction_Name)) < 0) vyyerror("Unknown BasisFunction: %s", $1); else { List_Add($$, &i); int j = i+1; while((i = List_ISearchSeqPartial(Current_BasisFunction_L, $1, j, fcmp_BasisFunction_Name)) >= 0) { List_Add($$, &i); j = i+1; /* for piecewise defined basis functions */ } } Free($1); } | '{' RecursiveListOfBasisFunction '}' { $$ = $2; } ; RecursiveListOfBasisFunction : /* none */ { $$ = List_Create(5, 5, sizeof(int)); } | RecursiveListOfBasisFunction Comma tSTRING { int i; if((i = List_ISearchSeq(Current_BasisFunction_L, $3, fcmp_BasisFunction_Name)) < 0) vyyerror("Unknown BasisFunction: %s", $3); else { List_Add($1, &i); int j = i+1; while((i = List_ISearchSeqPartial(Current_BasisFunction_L, $3, j, fcmp_BasisFunction_Name)) >= 0) { List_Add($1, &i); j = i+1; /* for piecewise defined basis functions */ } } $$ = $1; Free($3); } ; ListOfBasisFunctionCoef : tSTRING { $$ = List_Create(1, 1, sizeof(int)); int i; if((i = List_ISearchSeq(Current_BasisFunction_L, $1, fcmp_BasisFunction_NameOfCoef)) < 0) vyyerror("Unknown BasisFunctionCoef: %s", $1); else { List_Add($$, &i); } Free($1); } | '{' RecursiveListOfBasisFunctionCoef '}' { $$ = $2; } ; RecursiveListOfBasisFunctionCoef : /* none */ { $$ = List_Create(5, 5, sizeof(int)); } | RecursiveListOfBasisFunctionCoef Comma tSTRING { int i; if((i = List_ISearchSeq(Current_BasisFunction_L, $3, fcmp_BasisFunction_NameOfCoef)) < 0) vyyerror("Unknown BasisFunctionCoef: %s", $3); else { List_Add($1, &i); } $$ = $1; Free($3); } ; GlobalQuantities : /* none */ { $$ = Current_GlobalQuantity_L = List_Create(6, 6, sizeof (struct GlobalQuantity)); } | GlobalQuantities '{' GlobalQuantity '}' { GlobalQuantity_S.Num = Num_BasisFunction++; List_Add($$ = $1, &GlobalQuantity_S); } | GlobalQuantities Loop { $$ = $1; } ; GlobalQuantity : /* none */ { GlobalQuantity_S.Name = NULL; GlobalQuantity_S.Num = 0; GlobalQuantity_S.Type = ALIASOF; GlobalQuantity_S.ReferenceIndex = -1; } | GlobalQuantity GlobalQuantityTerm ; GlobalQuantityTerm : tName String__Index tEND { Check_NameOfStructNotExist("GlobalQuantity", Current_GlobalQuantity_L, $2, fcmp_GlobalQuantity_Name); GlobalQuantity_S.Name = $2; } | tType tSTRING tEND { GlobalQuantity_S.Type = Get_DefineForString(GlobalQuantity_Type, $2, &FlagError); if(FlagError){ vyyerror("Unknown type of GlobalQuantity: %s", $2); Get_Valid_SXD(GlobalQuantity_Type); } Free($2); } | tNameOfCoef String__Index tEND { int i; if((i = List_ISearchSeq(FunctionSpace_S.BasisFunction, $2, fcmp_BasisFunction_NameOfCoef)) < 0) vyyerror("Unknown NameOfCoef: %s", $2); else GlobalQuantity_S.ReferenceIndex = i; Free($2); } ; ConstraintInFSs : /* none */ { $$ = List_Create(6, 6, sizeof (struct ConstraintInFS)); } | ConstraintInFSs '{' ConstraintInFS '}' { Group_S.FunctionType = Type_Function; Group_S.SuppListType = Type_SuppList; switch (Group_S.FunctionType) { case ELEMENTSOF : Group_S.Type = ELEMENTLIST; break; default : Group_S.Type = REGIONLIST ; break; } if(Constraint_Index >= 0) { Constraint_P = (struct Constraint *) List_Pointer(Problem_S.Constraint, Constraint_Index); for(int i = 0; i < List_Nbr(Constraint_P->ConstraintPerRegion); i++) { ConstraintPerRegion_P = (struct ConstraintPerRegion *) List_Pointer(Constraint_P->ConstraintPerRegion, i); if(ConstraintPerRegion_P->RegionIndex >= 0) { Group_S.InitialList = ((struct Group *) List_Pointer(Problem_S.Group, ConstraintPerRegion_P->RegionIndex)) ->InitialList; Group_S.InitialSuppList = (ConstraintPerRegion_P->SubRegionIndex >= 0)? ((struct Group *) List_Pointer(Problem_S.Group, ConstraintPerRegion_P->SubRegionIndex)) ->InitialList : NULL; ConstraintInFS_S.EntityIndex = Add_Group(&Group_S, (char*)"CO_Entity", false, 1, 0); ConstraintInFS_S.ConstraintPerRegion = ConstraintPerRegion_P; List_Add($$ = $1, &ConstraintInFS_S); } } } } | ConstraintInFSs Loop { $$ = $1; } ; ConstraintInFS : /* none */ { ConstraintInFS_S.QuantityType = LOCALQUANTITY; ConstraintInFS_S.ReferenceIndex = -1; ConstraintInFS_S.EntityIndex = -1; ConstraintInFS_S.ConstraintPerRegion = NULL; ConstraintInFS_S.Active.ResolutionIndex = -1; ConstraintInFS_S.Active.Active = NULL; Constraint_Index = -1; } | ConstraintInFS ConstraintInFSTerm ; ConstraintInFSTerm : tNameOfCoef String__Index tEND { int i; if((i = List_ISearchSeq(FunctionSpace_S.BasisFunction, $2, fcmp_BasisFunction_NameOfCoef)) < 0) { if((i = List_ISearchSeq(FunctionSpace_S.GlobalQuantity, $2, fcmp_GlobalQuantity_Name)) < 0) vyyerror("Unknown NameOfCoef: %s", $2); else { ConstraintInFS_S.QuantityType = GLOBALQUANTITY; ConstraintInFS_S.ReferenceIndex = i; } } else { ConstraintInFS_S.QuantityType = LOCALQUANTITY; ConstraintInFS_S.ReferenceIndex = i; } Free($2); } | tEntityType FunctionForGroup tEND { Type_Function = $2; } | tEntitySubType SuppListTypeForGroup tEND { Type_SuppList = $2; } | tNameOfConstraint String__Index tEND { Constraint_Index = List_ISearchSeq(Problem_S.Constraint, $2, fcmp_Constraint_Name); if(Constraint_Index < 0) Message::Warning("Constraint '%s' is not provided", $2); Free($2); } ; /* ------------------------------------------------------------------------ */ /* F o r m u l a t i o n */ /* ------------------------------------------------------------------------ */ Formulations : /* none */ { if(!Problem_S.Formulation) Problem_S.Formulation = List_Create(10, 5, sizeof (struct Formulation)); } | Formulations BracedFormulation ; BracedFormulation : '{' Formulation '}' { List_Add(Problem_S.Formulation, &Formulation_S); } | Loop ; Formulation : /* none */ { Formulation_S.Name = NULL; Formulation_S.Type = FEMEQUATION; Formulation_S.DefineQuantity = NULL; Formulation_S.Equation = NULL; } | Formulation FormulationTerm ; FormulationTerm : tName String__Index tEND { Check_NameOfStructNotExist("Formulation", Problem_S.Formulation, $2, fcmp_Formulation_Name); Formulation_S.Name = $2; } | tType tSTRING tEND { Formulation_S.Type = Get_DefineForString(Formulation_Type, $2, &FlagError); if(FlagError){ vyyerror("Unknown type of Formulation: %s", $2); Get_Valid_SXD(Formulation_Type); } Free($2); } | tQuantity '{' DefineQuantities '}' | tSTRING '{' Equations '}' { Formulation_S.Equation = $3; Free($1); } ; DefineQuantities : /* none */ { Formulation_S.DefineQuantity = List_Create(6, 6, sizeof (struct DefineQuantity)); } | DefineQuantities '{' DefineQuantity '}' { List_Add(Formulation_S.DefineQuantity, &DefineQuantity_S); } | DefineQuantities Loop ; DefineQuantity : /* none */ { DefineQuantity_S.Name = NULL; DefineQuantity_S.Type = LOCALQUANTITY; DefineQuantity_S.IndexInFunctionSpace = NULL; DefineQuantity_S.FunctionSpaceIndex = -1; DefineQuantity_S.DofDataIndex = -1; DefineQuantity_S.DofData = NULL; DefineQuantity_S.DummyFrequency = NULL; DefineQuantity_S.IntegralQuantity.InIndex = -1; DefineQuantity_S.IntegralQuantity.IntegrationMethodIndex = -1; DefineQuantity_S.IntegralQuantity.JacobianMethodIndex = -1; DefineQuantity_S.IntegralQuantity.Symmetry = 0; DefineQuantity_S.IntegralQuantity.WholeQuantity = NULL; } | DefineQuantity DefineQuantityTerm ; DefineQuantityTerm : tName String__Index tEND { DefineQuantity_S.Name = $2; } | tType tGlobalQuantity tEND { DefineQuantity_S.Type = GLOBALQUANTITY; } /* Doit rester tant qu'on ne supprime pas l'association 'Integral <-> tGalerkin' */ | tType tGalerkin tEND { DefineQuantity_S.Type = INTEGRALQUANTITY; } | tType tSTRING tEND { DefineQuantity_S.Type = Get_DefineForString(DefineQuantity_Type, $2, &FlagError); if(FlagError){ vyyerror("Unknown type of Quantity: %s", $2); Get_Valid_SXD(DefineQuantity_Type); } Free($2); } | tDummyFrequency ListOfFExpr tEND { DefineQuantity_S.DummyFrequency = $2; } | tNameOfSpace String__Index { int i; if((i = List_ISearchSeq(Problem_S.FunctionSpace, $2, fcmp_FunctionSpace_Name)) < 0) vyyerror("Unknown FunctionSpace: %s", $2); else DefineQuantity_S.FunctionSpaceIndex = i; } IndexInFunctionSpace tEND { if(DefineQuantity_S.FunctionSpaceIndex >= 0) { if(DefineQuantity_S.Type == GLOBALQUANTITY && !DefineQuantity_S.IndexInFunctionSpace) { if(DefineQuantity_S.Name) { List_Read(Problem_S.FunctionSpace, DefineQuantity_S.FunctionSpaceIndex, &FunctionSpace_S); int i; if((i = List_ISearchSeq(FunctionSpace_S.GlobalQuantity, DefineQuantity_S.Name, fcmp_GlobalQuantity_Name)) < 0) { vyyerror("Unknown GlobalQuantity: %s", DefineQuantity_S.Name); } else { DefineQuantity_S.IndexInFunctionSpace = List_Create(1, 1, sizeof(int)); List_Add(DefineQuantity_S.IndexInFunctionSpace, &i); } } else vyyerror("No Name pre-defined for GlobalQuantity"); } } } | tIndexOfSystem FExpr tEND { DefineQuantity_S.DofDataIndex = (int)$2; } | '[' { Current_DofIndexInWholeQuantity = -1; Current_NoDofIndexInWholeQuantity = -1; List_Reset(ListOfPointer_L); } WholeQuantityExpression ']' tEND { DefineQuantity_S.IntegralQuantity.WholeQuantity = $3; DefineQuantity_S.IntegralQuantity.DofIndexInWholeQuantity = Current_DofIndexInWholeQuantity; WholeQuantity_P = (struct WholeQuantity*) List_Pointer(DefineQuantity_S.IntegralQuantity.WholeQuantity, 0); /* Ce qui suit ne suffit pas : il faudrait aussi gerer des Quantity_def sans Dof */ if(Current_DofIndexInWholeQuantity >= 0) { DefineQuantity_S.IntegralQuantity.TypeOperatorDof = (WholeQuantity_P+Current_DofIndexInWholeQuantity)-> Case.OperatorAndQuantity.TypeOperator; DefineQuantity_S.IntegralQuantity.DefineQuantityIndexDof = (WholeQuantity_P+Current_DofIndexInWholeQuantity)-> Case.OperatorAndQuantity.Index; DefineQuantity_S.FunctionSpaceIndex = ((struct DefineQuantity*) List_Pointer(Formulation_S.DefineQuantity, DefineQuantity_S.IntegralQuantity.DefineQuantityIndexDof))-> FunctionSpaceIndex; } else { /* No Dof{} */ DefineQuantity_S.IntegralQuantity.TypeOperatorDof = NOOP; DefineQuantity_S.IntegralQuantity.DefineQuantityIndexDof = -1; } if(Current_NoDofIndexInWholeQuantity >= 0) { DefineQuantity_S.IntegralQuantity.DefineQuantityIndexNoDof = (WholeQuantity_P+Current_NoDofIndexInWholeQuantity)-> Case.OperatorAndQuantity.Index; } else { /* No NoDof{} */ DefineQuantity_S.IntegralQuantity.DefineQuantityIndexNoDof = -1; } /* Check if the WholeQuantity is a Canonical Form */ DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_NONE; if(List_Nbr(DefineQuantity_S.IntegralQuantity.WholeQuantity) == 1){ /* GF_FUNCTION */ if((WholeQuantity_P+0)->Type == WQ_BUILTINFUNCTION) { Get_FunctionForFunction(GF_Function, (WholeQuantity_P+0)->Case.Function.Fct, &FlagError, &DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Fct); if(!FlagError){ DefineQuantity_S.IntegralQuantity.FunctionForCanonical.NbrParameters = (WholeQuantity_P+0)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Para = (WholeQuantity_P+0)->Case.Function.Para; } DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_GF; } } else if(List_Nbr(DefineQuantity_S.IntegralQuantity.WholeQuantity) == 3){ /* GF_FUNCTION OPER DOF */ if ((WholeQuantity_P+0)->Type == WQ_BUILTINFUNCTION && (WholeQuantity_P+1)->Type == WQ_OPERATORANDQUANTITY && (WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR && Current_DofIndexInWholeQuantity == 1) { Get_FunctionForFunction(GF_Function, (WholeQuantity_P+0)->Case.Function.Fct, &FlagError, &DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Fct); if(!FlagError){ DefineQuantity_S.IntegralQuantity.FunctionForCanonical.NbrParameters = (WholeQuantity_P+0)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Para = (WholeQuantity_P+0)->Case.Function.Para; } if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_GF_PSCA_DOF; if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_GF_PVEC_DOF; } /* DOF OPER GF_FUNCTION */ else if((WholeQuantity_P+0)->Type == WQ_OPERATORANDQUANTITY && (WholeQuantity_P+1)->Type == WQ_BUILTINFUNCTION && (WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR && Current_DofIndexInWholeQuantity == 0) { Get_FunctionForFunction(GF_Function, (WholeQuantity_P+1)->Case.Function.Fct, &FlagError, &DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Fct); if(!FlagError){ DefineQuantity_S.IntegralQuantity.FunctionForCanonical.NbrParameters = (WholeQuantity_P+1)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Para = (WholeQuantity_P+1)->Case.Function.Para; } if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_GF_PSCA_DOF;/* Scalar Prod Transitive */ if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_DOF_PVEC_GF; } /* GF_FUNCTION OPER EXPR */ else if((WholeQuantity_P+0)->Type == WQ_BUILTINFUNCTION && (WholeQuantity_P+1)->Type == WQ_EXPRESSION && (WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR ) { Get_FunctionForFunction(GF_Function, (WholeQuantity_P+0)->Case.Function.Fct, &FlagError, &DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Fct); if(!FlagError){ DefineQuantity_S.IntegralQuantity.FunctionForCanonical.NbrParameters = (WholeQuantity_P+0)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Para = (WholeQuantity_P+0)->Case.Function.Para; } DefineQuantity_S.IntegralQuantity.ExpressionIndexForCanonical = (WholeQuantity_P+1)->Case.Expression.Index; if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_GF_PSCA_EXP; if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_GF_PVEC_EXP; /* DefineQuantity_S.IntegralQuantity.FunctionForCanonical.NbrParameters = (WholeQuantity_P+0)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Para = (WholeQuantity_P+0)->Case.Function.Para; */ } /* EXPR OPER GF_FUNCTION */ else if((WholeQuantity_P+0)->Type == WQ_EXPRESSION && (WholeQuantity_P+1)->Type == WQ_BUILTINFUNCTION && (WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR ) { Get_FunctionForFunction(GF_Function, (WholeQuantity_P+1)->Case.Function.Fct, &FlagError, &DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Fct); if(!FlagError){ DefineQuantity_S.IntegralQuantity.FunctionForCanonical.NbrParameters = (WholeQuantity_P+1)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Para = (WholeQuantity_P+1)->Case.Function.Para; } DefineQuantity_S.IntegralQuantity.ExpressionIndexForCanonical = (WholeQuantity_P+0)->Case.Expression.Index; if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_GF_PSCA_EXP;/* Transitive product */ if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_EXP_PVEC_GF; } } else if(List_Nbr(DefineQuantity_S.IntegralQuantity.WholeQuantity) == 5){ /* EXPR OPER GF_FUNCTION OPER DOF */ if ((WholeQuantity_P+0)->Type == WQ_EXPRESSION && (WholeQuantity_P+1)->Type == WQ_BUILTINFUNCTION && (WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR && (WholeQuantity_P+3)->Type == WQ_OPERATORANDQUANTITY && (WholeQuantity_P+4)->Type == WQ_BINARYOPERATOR && Current_DofIndexInWholeQuantity == 3) { Get_FunctionForFunction(GF_Function, (WholeQuantity_P+1)->Case.Function.Fct, &FlagError, &DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Fct); if(!FlagError){ DefineQuantity_S.IntegralQuantity.FunctionForCanonical.NbrParameters = (WholeQuantity_P+1)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Para = (WholeQuantity_P+1)->Case.Function.Para; } DefineQuantity_S.IntegralQuantity.ExpressionIndexForCanonical = (WholeQuantity_P+0)->Case.Expression.Index; if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME){ if((WholeQuantity_P+4)->Case.Operator.TypeOperator == OP_TIME) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_EXP_TIME_GF_PSCA_DOF; if((WholeQuantity_P+4)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_EXP_TIME_GF_PVEC_DOF; } else if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_CROSSPRODUCT){ if((WholeQuantity_P+4)->Case.Operator.TypeOperator == OP_TIME) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_EXP_PVEC_GF_PSCA_DOF; if((WholeQuantity_P+4)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_EXP_PVEC_GF_PVEC_DOF; } } /* FCT OPER GF_FUNCTION OPER DOF */ else if((WholeQuantity_P+0)->Type == WQ_BUILTINFUNCTION && (WholeQuantity_P+1)->Type == WQ_BUILTINFUNCTION && (WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR && (WholeQuantity_P+3)->Type == WQ_OPERATORANDQUANTITY && (WholeQuantity_P+4)->Type == WQ_BINARYOPERATOR && Current_DofIndexInWholeQuantity == 3) { Get_FunctionForFunction(GF_Function, (WholeQuantity_P+1)->Case.Function.Fct, &FlagError, &DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Fct); if(!FlagError){ DefineQuantity_S.IntegralQuantity.FunctionForCanonical.NbrParameters = (WholeQuantity_P+1)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.FunctionForCanonical.Para = (WholeQuantity_P+1)->Case.Function.Para; } DefineQuantity_S.IntegralQuantity.AnyFunction.Fct = (WholeQuantity_P+0)->Case.Function.Fct; DefineQuantity_S.IntegralQuantity.AnyFunction.NbrParameters = (WholeQuantity_P+0)->Case.Function.NbrParameters; DefineQuantity_S.IntegralQuantity.AnyFunction.Para = (WholeQuantity_P+0)->Case.Function.Para; if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME){ if((WholeQuantity_P+4)->Case.Operator.TypeOperator == OP_TIME) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_FCT_TIME_GF_PSCA_DOF; if((WholeQuantity_P+4)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_FCT_TIME_GF_PVEC_DOF; } else if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_CROSSPRODUCT){ if((WholeQuantity_P+4)->Case.Operator.TypeOperator == OP_TIME) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_FCT_PVEC_GF_PSCA_DOF; if((WholeQuantity_P+4)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) DefineQuantity_S.IntegralQuantity.CanonicalWholeQuantity = CWQ_FCT_PVEC_GF_PVEC_DOF; } } } Pro_DefineQuantityIndex (DefineQuantity_S.IntegralQuantity.WholeQuantity, -1, &DefineQuantity_S.IntegralQuantity.NbrQuantityIndex, &DefineQuantity_S.IntegralQuantity.QuantityIndexTable, &DefineQuantity_S.IntegralQuantity.QuantityTraceGroupIndexTable); if(DefineQuantity_S.IntegralQuantity.NbrQuantityIndex > 1) vyyerror("More than one LocalQuantity in IntegralQuantity"); } | tIn GroupRHS tEND { DefineQuantity_S.IntegralQuantity.InIndex = Num_Group(&Group_S, (char*)"IQ_In", $2); } | tIntegration tSTRING tEND { int i; if((i = List_ISearchSeq(Problem_S.IntegrationMethod, $2, fcmp_IntegrationMethod_Name)) < 0) vyyerror("Unknown Integration method: %s", $2); else DefineQuantity_S.IntegralQuantity.IntegrationMethodIndex = i; Free($2); } | tJacobian String__Index tEND { int i; if((i = List_ISearchSeq(Problem_S.JacobianMethod, $2, fcmp_JacobianMethod_Name)) < 0) vyyerror("Unknown Jacobian method: %s", $2); else DefineQuantity_S.IntegralQuantity.JacobianMethodIndex = i; Free($2); } | tSymmetry tINT tEND { DefineQuantity_S.IntegralQuantity.Symmetry = $2; } ; IndexInFunctionSpace : /* none */ | '[' String__Index ']' { if(DefineQuantity_S.FunctionSpaceIndex >= 0) { if(DefineQuantity_S.Type == LOCALQUANTITY) { int i; if((i = List_ISearchSeq (((struct FunctionSpace *) List_Pointer(Problem_S.FunctionSpace, DefineQuantity_S.FunctionSpaceIndex))->SubSpace, $2, fcmp_SubSpace_Name)) < 0) vyyerror("Unknown SubSpace: %s", $2); else { DefineQuantity_S.IndexInFunctionSpace = ((struct SubSpace *) List_Pointer (((struct FunctionSpace *) List_Pointer(Problem_S.FunctionSpace, DefineQuantity_S.FunctionSpaceIndex))->SubSpace, i)) ->BasisFunction; } } else if(DefineQuantity_S.Type == GLOBALQUANTITY) { List_Read(Problem_S.FunctionSpace, DefineQuantity_S.FunctionSpaceIndex, &FunctionSpace_S); int i; if((i = List_ISearchSeq(FunctionSpace_S.GlobalQuantity, $2, fcmp_GlobalQuantity_Name)) < 0) { vyyerror("Unknown GlobalQuantity: %s", $2); } else { DefineQuantity_S.IndexInFunctionSpace = List_Create(1, 1, sizeof(int)); List_Add(DefineQuantity_S.IndexInFunctionSpace, &i); } } } Free($2); } ; Equations : /* none */ { $$ = List_Create(6, 6, sizeof(struct EquationTerm)); } | Equations EquationTerm { List_Add($$ = $1, &EquationTerm_S); } | Equations Loop { $$ = $1; } ; EquationTerm : tGalerkin '{' LocalTerm '}' { EquationTerm_S.Type = GALERKIN; } | tdeRham '{' LocalTerm '}' { EquationTerm_S.Type = DERHAM; } | tGlobalTerm '{' GlobalTerm '}' { EquationTerm_S.Type = GLOBALTERM; } | tGlobalEquation '{' GlobalEquation '}' { EquationTerm_S.Type = GLOBALEQUATION; } ; GlobalEquation : /* none */ { EquationTerm_S.Case.GlobalEquation.Type = NETWORK; EquationTerm_S.Case.GlobalEquation.ConstraintIndex = -1; EquationTerm_S.Case.GlobalEquation.GlobalEquationTerm = NULL; } | GlobalEquation GlobalEquationTerm ; GlobalEquationTerm : tType tSTRING tEND { EquationTerm_S.Case.GlobalEquation.Type = Get_DefineForString(Constraint_Type, $2, &FlagError); if(FlagError){ vyyerror("Unknown type of GlobalEquation: %s", $2); Get_Valid_SXD(Constraint_Type); } Free($2); } | tNameOfConstraint tSTRING tEND { int i; if((i = List_ISearchSeq(Problem_S.Constraint, $2, fcmp_Constraint_Name)) >= 0) EquationTerm_S.Case.GlobalEquation.ConstraintIndex = i; else EquationTerm_S.Case.GlobalEquation.ConstraintIndex = -1; Free($2); } | '{' GlobalEquationTermTerm '}' { if(!EquationTerm_S.Case.GlobalEquation.GlobalEquationTerm) EquationTerm_S.Case.GlobalEquation.GlobalEquationTerm = List_Create(3, 3, sizeof(struct GlobalEquationTerm)); List_Add(EquationTerm_S.Case.GlobalEquation.GlobalEquationTerm, &GlobalEquationTerm_S); } ; GlobalEquationTermTerm : /* none */ { GlobalEquationTerm_S.DefineQuantityIndexNode = -1; GlobalEquationTerm_S.DefineQuantityIndexLoop = -1; GlobalEquationTerm_S.DefineQuantityIndexEqu = -1; GlobalEquationTerm_S.InIndex = -1; } | GlobalEquationTermTerm GlobalEquationTermTermTerm ; GlobalEquationTermTermTerm : tSTRING Quantity_Def tEND { if(!strcmp($1, "Node")) GlobalEquationTerm_S.DefineQuantityIndexNode = $2.Int2; else if(!strcmp($1, "Loop")) GlobalEquationTerm_S.DefineQuantityIndexLoop = $2.Int2; else if(!strcmp($1, "Equation")) GlobalEquationTerm_S.DefineQuantityIndexEqu = $2.Int2; else vyyerror("Unknown global equation term: %s", $1); Free($1); } | tIn GroupRHS tEND { GlobalEquationTerm_S.InIndex = Num_Group(&Group_S, (char*)"FO_In", $2); } ; LocalTerm : /* none */ { EquationTerm_S.Case.LocalTerm.Term.TypeTimeDerivative = NODT_; EquationTerm_S.Case.LocalTerm.Term.TypeOperatorEqu = NOOP; EquationTerm_S.Case.LocalTerm.Term.TypeOperatorDof = NOOP; EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexEqu = -1; EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexDof = -1; EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexNoDof = -1; EquationTerm_S.Case.LocalTerm.Term.WholeQuantity = NULL; EquationTerm_S.Case.LocalTerm.Term.DofIndexInWholeQuantity = -1; EquationTerm_S.Case.LocalTerm.Term.DofInTrace = 0; EquationTerm_S.Case.LocalTerm.InIndex = -1; EquationTerm_S.Case.LocalTerm.IntegrationMethodIndex = -1; EquationTerm_S.Case.LocalTerm.MatrixIndex = -1; EquationTerm_S.Case.LocalTerm.JacobianMethodIndex = -1; EquationTerm_S.Case.LocalTerm.ExpressionIndexForMetricTensor = -1; EquationTerm_S.Case.LocalTerm.Active = NULL; EquationTerm_S.Case.LocalTerm.Full_Matrix = 0; } | LocalTerm LocalTermTerm ; LocalTermTerm : TermOperator '[' { EquationTerm_S.Case.LocalTerm.Term.TypeTimeDerivative = Type_TermOperator; Current_DofIndexInWholeQuantity = -1; Current_NoDofIndexInWholeQuantity = -1; List_Reset(ListOfPointer_L); } WholeQuantityExpression { EquationTerm_S.Case.LocalTerm.Term.WholeQuantity = $4; EquationTerm_S.Case.LocalTerm.Term.DofIndexInWholeQuantity = Current_DofIndexInWholeQuantity; WholeQuantity_P = (struct WholeQuantity*) List_Pointer(EquationTerm_S.Case.LocalTerm.Term.WholeQuantity, 0); if(Current_DofIndexInWholeQuantity == -4){ EquationTerm_S.Case.LocalTerm.Term.DofInTrace = 1; EquationTerm_S.Case.LocalTerm.Term.TypeOperatorDof = TypeOperatorDofInTrace; EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexDof = DefineQuantityIndexDofInTrace; } else if(Current_DofIndexInWholeQuantity >= 0) { EquationTerm_S.Case.LocalTerm.Term.TypeOperatorDof = (WholeQuantity_P+Current_DofIndexInWholeQuantity)-> Case.OperatorAndQuantity.TypeOperator; EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexDof = (WholeQuantity_P+Current_DofIndexInWholeQuantity)-> Case.OperatorAndQuantity.Index; } else { /* No Dof{} */ EquationTerm_S.Case.LocalTerm.Term.TypeOperatorDof = NOOP; EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexDof = -1; } if(Current_NoDofIndexInWholeQuantity >= 0) { EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexNoDof = (WholeQuantity_P+Current_NoDofIndexInWholeQuantity)-> Case.OperatorAndQuantity.Index; } else { /* No NoDof{} */ EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexNoDof = -1; } /* Check if the WholeQuantity is a Canonical Form of type 'expr[] * Dof{}'*/ if((List_Nbr(EquationTerm_S.Case.LocalTerm.Term.WholeQuantity) == 3) && ((WholeQuantity_P+0)->Type == WQ_EXPRESSION) && ((WholeQuantity_P+1)->Type == WQ_OPERATORANDQUANTITY) && ((WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR) && ((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME) && (Current_DofIndexInWholeQuantity == 1)) { EquationTerm_S.Case.LocalTerm.Term.CanonicalWholeQuantity = CWQ_EXP_TIME_DOF; EquationTerm_S.Case.LocalTerm.Term.ExpressionIndexForCanonical = (WholeQuantity_P+0)->Case.Expression.Index; } else if((List_Nbr(EquationTerm_S.Case.LocalTerm.Term.WholeQuantity) == 3) && ((WholeQuantity_P+0)->Type == WQ_BUILTINFUNCTION) && ((WholeQuantity_P+1)->Type == WQ_OPERATORANDQUANTITY) && ((WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR) && (Current_DofIndexInWholeQuantity == 1)) { if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME) EquationTerm_S.Case.LocalTerm.Term.CanonicalWholeQuantity = CWQ_FCT_TIME_DOF; if((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_CROSSPRODUCT) EquationTerm_S.Case.LocalTerm.Term.CanonicalWholeQuantity = CWQ_FCT_PVEC_DOF; EquationTerm_S.Case.LocalTerm.Term.FunctionForCanonical.Fct = (WholeQuantity_P+0)->Case.Function.Fct; EquationTerm_S.Case.LocalTerm.Term.FunctionForCanonical.NbrParameters = (WholeQuantity_P+0)->Case.Function.NbrParameters; EquationTerm_S.Case.LocalTerm.Term.FunctionForCanonical.Para = (WholeQuantity_P+0)->Case.Function.Para; } else if((List_Nbr(EquationTerm_S.Case.LocalTerm.Term.WholeQuantity) == 1) && ((WholeQuantity_P+0)->Type == WQ_OPERATORANDQUANTITY) && (Current_DofIndexInWholeQuantity == 0)) { EquationTerm_S.Case.LocalTerm.Term.CanonicalWholeQuantity = CWQ_DOF; } else { EquationTerm_S.Case.LocalTerm.Term.CanonicalWholeQuantity = CWQ_NONE; } } ',' WholeQuantityExpression ']' tEND { EquationTerm_S.Case.LocalTerm.Term.TypeOperatorEqu = Quantity_TypeOperator; EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexEqu = Quantity_Index; EquationTerm_S.Case.LocalTerm.Term.CanonicalWholeQuantity_Equ = CWQ_NONE; WholeQuantity_P = (struct WholeQuantity*) List_Pointer($7, 0); if(List_Nbr($7) == 1){ if((WholeQuantity_P+0)->Type != WQ_OPERATORANDQUANTITY) vyyerror("Missing Quantity in Equation"); } else if(List_Nbr($7) == 3 && ((WholeQuantity_P+0)->Type == WQ_EXPRESSION && (WholeQuantity_P+1)->Type == WQ_OPERATORANDQUANTITY && (WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR)) { // FIXME: should also add the case (BUILTINFUNCTION OPERATORANDQUANTITY BINARYOPERATOR) EquationTerm_S.Case.LocalTerm.Term.CanonicalWholeQuantity_Equ = CWQ_EXP_TIME_DOF; EquationTerm_S.Case.LocalTerm.Term.ExpressionIndexForCanonical_Equ = (WholeQuantity_P+0)->Case.Expression.Index; EquationTerm_S.Case.LocalTerm.Term.OperatorTypeForCanonical_Equ = (WholeQuantity_P+2)->Case.Operator.TypeOperator; } else if(List_Nbr($7) == 2 && ((WholeQuantity_P+0)->Type == WQ_OPERATORANDQUANTITY && (WholeQuantity_P+1)->Type == WQ_BUILTINFUNCTION)) { EquationTerm_S.Case.LocalTerm.Term.CanonicalWholeQuantity_Equ = CWQ_FCT_DOF; EquationTerm_S.Case.LocalTerm.Term.BuiltInFunction_Equ = (WholeQuantity_P+1)->Case.Function.Fct; } else{ vyyerror("Unrecognized quantity structure in Equation"); } Pro_DefineQuantityIndex (EquationTerm_S.Case.LocalTerm.Term.WholeQuantity, EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexEqu, &EquationTerm_S.Case.LocalTerm.Term.NbrQuantityIndex, &EquationTerm_S.Case.LocalTerm.Term.QuantityIndexTable, &EquationTerm_S.Case.LocalTerm.Term.QuantityTraceGroupIndexTable); EquationTerm_S.Case.LocalTerm.Term.QuantityIndexPost = 0; for(int i = 0; i < EquationTerm_S.Case.LocalTerm.Term.NbrQuantityIndex; i++) { if((EquationTerm_S.Case.LocalTerm.Term.QuantityIndexTable[i] != EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexEqu) && (EquationTerm_S.Case.LocalTerm.Term.QuantityIndexTable[i] != EquationTerm_S.Case.LocalTerm.Term.DefineQuantityIndexDof)) { EquationTerm_S.Case.LocalTerm.Term.QuantityIndexPost = 1; break; } } } | tIn GroupRHS tEND { EquationTerm_S.Case.LocalTerm.InIndex = Num_Group(&Group_S, (char*)"FO_In", $2); } | tJacobian String__Index tEND { int i; if((i = List_ISearchSeq(Problem_S.JacobianMethod, $2, fcmp_JacobianMethod_Name)) < 0) vyyerror("Unknown Jacobian method: %s",$2); else EquationTerm_S.Case.LocalTerm.JacobianMethodIndex = i; Free($2); } | tIntegration tSTRING tEND { int i; if((i = List_ISearchSeq(Problem_S.IntegrationMethod, $2, fcmp_IntegrationMethod_Name)) < 0) vyyerror("Unknown Integration method: %s", $2); else EquationTerm_S.Case.LocalTerm.IntegrationMethodIndex = i; Free($2); } | tFull_Matrix tEND { EquationTerm_S.Case.LocalTerm.Full_Matrix = 1; } | tMatrix '[' tINT ']' tEND { if($3 == 1 || $3 == 2 || $3 == 3) EquationTerm_S.Case.LocalTerm.MatrixIndex = $3; else vyyerror("Unknown Matrix123: %d", $3); } | tMetricTensor Expression tEND { EquationTerm_S.Case.LocalTerm.ExpressionIndexForMetricTensor = $2; } ; GlobalTerm : /* none */ { EquationTerm_S.Case.GlobalTerm.TypeTimeDerivative = NODT_; EquationTerm_S.Case.GlobalTerm.DefineQuantityIndex = -1; EquationTerm_S.Case.GlobalTerm.Term.TypeTimeDerivative = NODT_; EquationTerm_S.Case.GlobalTerm.Term.TypeOperatorEqu = NOOP; EquationTerm_S.Case.GlobalTerm.Term.TypeOperatorDof = NOOP; EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexEqu = -1; EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexDof = -1; EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexNoDof = -1; EquationTerm_S.Case.GlobalTerm.Term.WholeQuantity = NULL; EquationTerm_S.Case.GlobalTerm.Term.DofIndexInWholeQuantity = -1; EquationTerm_S.Case.GlobalTerm.InIndex = -1; } | GlobalTerm GlobalTermTerm ; GlobalTermTerm : tIn GroupRHS tEND { EquationTerm_S.Case.GlobalTerm.InIndex = Num_Group(&Group_S, (char*)"FO_In", $2); } | TermOperator '[' { EquationTerm_S.Case.GlobalTerm.Term.TypeTimeDerivative = Type_TermOperator; Current_DofIndexInWholeQuantity = -1; Current_NoDofIndexInWholeQuantity = -1; List_Reset(ListOfPointer_L); } WholeQuantityExpression { EquationTerm_S.Case.GlobalTerm.Term.WholeQuantity = $4; EquationTerm_S.Case.GlobalTerm.Term.DofIndexInWholeQuantity = Current_DofIndexInWholeQuantity; WholeQuantity_P = (struct WholeQuantity*) List_Pointer(EquationTerm_S.Case.GlobalTerm.Term.WholeQuantity, 0); if(Current_DofIndexInWholeQuantity >= 0) { EquationTerm_S.Case.GlobalTerm.Term.TypeOperatorDof = (WholeQuantity_P+Current_DofIndexInWholeQuantity)-> Case.OperatorAndQuantity.TypeOperator; EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexDof = (WholeQuantity_P+Current_DofIndexInWholeQuantity)-> Case.OperatorAndQuantity.Index; } else { /* No Dof{} */ EquationTerm_S.Case.GlobalTerm.Term.TypeOperatorDof = NOOP; EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexDof = -1; } if(Current_NoDofIndexInWholeQuantity >= 0) { EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexNoDof = (WholeQuantity_P+Current_NoDofIndexInWholeQuantity)-> Case.OperatorAndQuantity.Index; } else { /* No NoDof{} */ EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexNoDof = -1; } /* Check if the WholeQuantity is a Canonical Form of type 'expr[] * Dof{}'*/ if((List_Nbr(EquationTerm_S.Case.GlobalTerm.Term.WholeQuantity) == 3) && ((WholeQuantity_P+0)->Type == WQ_EXPRESSION) && ((WholeQuantity_P+1)->Type == WQ_OPERATORANDQUANTITY) && ((WholeQuantity_P+2)->Type == WQ_BINARYOPERATOR) && ((WholeQuantity_P+2)->Case.Operator.TypeOperator == OP_TIME) && (Current_DofIndexInWholeQuantity == 1)) { EquationTerm_S.Case.GlobalTerm.Term.CanonicalWholeQuantity = CWQ_EXP_TIME_DOF; EquationTerm_S.Case.GlobalTerm.Term.ExpressionIndexForCanonical = (WholeQuantity_P+0)->Case.Expression.Index; } else if((List_Nbr(EquationTerm_S.Case.GlobalTerm.Term.WholeQuantity) == 1) && ((WholeQuantity_P+0)->Type == WQ_OPERATORANDQUANTITY) && (Current_DofIndexInWholeQuantity == 0)) { EquationTerm_S.Case.GlobalTerm.Term.CanonicalWholeQuantity = CWQ_DOF; } else { EquationTerm_S.Case.GlobalTerm.Term.CanonicalWholeQuantity = CWQ_NONE; } } ',' Quantity_Def ']' tEND { EquationTerm_S.Case.GlobalTerm.Term.TypeOperatorEqu = $7.Int1; EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexEqu = $7.Int2; Pro_DefineQuantityIndex (EquationTerm_S.Case.GlobalTerm.Term.WholeQuantity, EquationTerm_S.Case.GlobalTerm.Term.DefineQuantityIndexEqu, &EquationTerm_S.Case.GlobalTerm.Term.NbrQuantityIndex, &EquationTerm_S.Case.GlobalTerm.Term.QuantityIndexTable, &EquationTerm_S.Case.GlobalTerm.Term.QuantityTraceGroupIndexTable); } ; TermOperator : /* none */ { Type_TermOperator = NODT_ ; } | tDt { Type_TermOperator = DT_ ; } | tDtDof { Type_TermOperator = DTDOF_ ; } | tDtDt { Type_TermOperator = DTDT_ ; } | tDtDtDof { Type_TermOperator = DTDTDOF_ ; } | tJacNL { Type_TermOperator = JACNL_ ; } | tDtDofJacNL { Type_TermOperator = DTDOFJACNL_; } | tNeverDt { Type_TermOperator = NEVERDT_ ; } | tDtNL { Type_TermOperator = DTNL_ ; } ; Quantity_Def : '{' tSTRING String__Index '}' { $$.Int1 = Get_DefineForString(Operator_Type, $2, &FlagError); if(FlagError){ vyyerror("Unknown Operator for discrete Quantity: %s", $2); Get_Valid_SXD(Operator_Type); } Free($2); int i; if((i = List_ISearchSeq(Formulation_S.DefineQuantity, $3, fcmp_DefineQuantity_Name)) < 0) vyyerror("Unknown discrete Quantity: %s", $3); $$.Int2 = i; /* the following should be suppressed as soon as the test function part in the formulations is correctly treated */ Quantity_TypeOperator = $$.Int1; Quantity_Index = $$.Int2; Free($3); } | '{' String__Index '}' { $$.Int1 = NOOP; int i; if((i = List_ISearchSeq(Formulation_S.DefineQuantity, $2, fcmp_DefineQuantity_Name)) < 0) vyyerror("Unknown discrete Quantity: %s", $2); $$.Int2 = i; /* the following should be suppressed as soon as the test function part in the formulations is correctly treated */ Quantity_TypeOperator = $$.Int1; Quantity_Index = $$.Int2; Free($2); } ; /* ------------------------------------------------------------------------ */ /* R e s o l u t i o n */ /* ------------------------------------------------------------------------ */ Resolutions : /* none */ { if(!Problem_S.Resolution) Problem_S.Resolution = List_Create(10, 5, sizeof (struct Resolution)); } | Resolutions BracedResolution ; BracedResolution : '{' Resolution '}' { List_Add(Problem_S.Resolution, &Resolution_S); } | Loop ; Resolution : /* none */ { Resolution_S.Name = NULL; Resolution_S.DefineSystem = NULL; Resolution_S.Operation = NULL; } | Resolution ResolutionTerm ; ResolutionTerm : tName String__Index tEND { Check_NameOfStructNotExist("Resolution", Problem_S.Resolution, $2, fcmp_Resolution_Name); Resolution_S.Name = $2; } | tDefineSystem '{' DefineSystems '}' { Resolution_S.DefineSystem = $3; } | tOperation { Operation_L = List_Create(5, 5, sizeof(struct Operation)); } '{' Operation '}' { Resolution_S.Operation = $4; List_Delete(Operation_L); } | Loop ; DefineSystems : /* none */ { $$ = Current_System_L = List_Create(6, 6, sizeof (struct DefineSystem)); } | DefineSystems '{' DefineSystem '}' { int i ; if ((i = List_ISearchSeq(Current_System_L, DefineSystem_S.Name, fcmp_DefineSystem_Name)) < 0) List_Add($$ = Current_System_L = $1, &DefineSystem_S) ; else List_Write(Current_System_L, i, &DefineSystem_S) ; } | DefineSystems Loop { $$ = $1; } ; DefineSystem : /* none */ { DefineSystem_S.Name = NULL; DefineSystem_S.Type = VAL_REAL; DefineSystem_S.FormulationIndex = NULL; DefineSystem_S.MeshName = NULL; DefineSystem_S.AdaptName = NULL; DefineSystem_S.FrequencyValue = NULL; DefineSystem_S.SolverDataFileName = NULL; DefineSystem_S.OriginSystemIndex = NULL; DefineSystem_S.DestinationSystemName = NULL; DefineSystem_S.DestinationSystemIndex = -1; } | DefineSystem DefineSystemTerm ; DefineSystemTerm : tName String__Index tEND { int i; if ((i = List_ISearchSeq(Current_System_L, $2, fcmp_DefineSystem_Name)) < 0) DefineSystem_S.Name = $2 ; else List_Read(Current_System_L, i, &DefineSystem_S) ; } | tType tSTRING tEND { DefineSystem_S.Type = Get_DefineForString(DefineSystem_Type, $2, &FlagError); if(FlagError){ vyyerror("Unknown type of System: %s", $2); Get_Valid_SXD(DefineSystem_Type); } Free($2); } | tNameOfFormulation ListOfFormulation tEND { DefineSystem_S.FormulationIndex = $2; } | tNameOfMesh CharExpr tEND { DefineSystem_S.MeshName = $2; } | tOriginSystem ListOfSystem tEND { if (!DefineSystem_S.OriginSystemIndex) { DefineSystem_S.OriginSystemIndex = $2 ; } else { for (int i = 0 ; i < List_Nbr($2) ; i++) List_Add(DefineSystem_S.OriginSystemIndex, (int *)List_Pointer($2, i) ) ; } } | tDestinationSystem String__Index tEND { DefineSystem_S.DestinationSystemName = $2; } | tFrequency ListOfFExpr tEND { DefineSystem_S.FrequencyValue = $2; DefineSystem_S.Type = VAL_COMPLEX; } | tSolver CharExpr tEND { DefineSystem_S.SolverDataFileName = $2; } | Loop ; ListOfFormulation : String__Index { $$ = List_Create(1, 1, sizeof(int)); int i; if((i = List_ISearchSeq(Problem_S.Formulation, $1, fcmp_Formulation_Name)) < 0) vyyerror("Unknown Formulation: %s", $1); else List_Add($$, &i); Free($1); } | '{' RecursiveListOfFormulation '}' { $$ = $2; } ; RecursiveListOfFormulation : /* none */ { $$ = List_Create(2, 2, sizeof(int)); } | RecursiveListOfFormulation Comma String__Index { int i; if((i = List_ISearchSeq(Problem_S.Formulation, $3, fcmp_Formulation_Name)) < 0) vyyerror("Unknown Formulation: %s", $3); else List_Add($1, &i); $$ = $1; Free($3); } ; ListOfSystem : String__Index { $$ = List_Create(1, 1, sizeof(int)); int i; if((i = List_ISearchSeq(Current_System_L, $1, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $1); else List_Add($$, &i); Free($1); } | '{' RecursiveListOfSystem '}' { $$ = $2; } ; RecursiveListOfSystem : /* none */ { $$ = List_Create(2, 2, sizeof(int)); } | RecursiveListOfSystem Comma String__Index { int i; if((i = List_ISearchSeq(Current_System_L, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); else List_Add($1, &i); $$ = $1; Free($3); } ; Operation : /* none */ { $$ = List_Create(6, 6, sizeof (struct Operation)); Operation_S.Type = OPERATION_NONE; Operation_S.DefineSystemIndex = -1; Operation_S.Rank = -1; List_Add(Operation_L, &Operation_S); } | Operation OperationTerm { if(((struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1))->Type != OPERATION_NONE) List_Add($$ = $1, (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1)); } ; CommaFExprOrNothing : { $$ = -1; } | ',' FExpr { $$ = (int)$2; } ; OperationTerm : /* OLD syntax */ tSTRING String__Index tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = Get_DefineForString(Operation_Type, $1, &FlagError); if(FlagError){ vyyerror("Unknown type of Operation: %s", $1); Get_Valid_SXD(Operation_Type); } Free($1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $2, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $2); Free($2); Operation_P->DefineSystemIndex = i; if(Operation_P->Type == OPERATION_GENERATE || Operation_P->Type == OPERATION_GENERATERHS || Operation_P->Type == OPERATION_GENERATEJAC || Operation_P->Type == OPERATION_GENERATESEPARATE) Operation_P->Case.Generate.GroupIndex = -1; } | tSetTime Expression tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SETTIME; Operation_P->Case.SetTime.ExpressionIndex = $2; } | tTimeLoopTheta '{' TimeLoopTheta '}' { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_TIMELOOPTHETA; } | tTimeLoopNewmark '{' TimeLoopNewmark '}' { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_TIMELOOPNEWMARK; } | tIterativeLoop '{' IterativeLoop '}' { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_ITERATIVELOOP; } | tIterativeTimeReduction '{' IterativeTimeReduction '}' { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_ITERATIVETIMEREDUCTION; } /* NEW syntax (function style): Only missing is IterativeTimeReduction */ | tSTRING '[' String__Index CommaFExprOrNothing ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = Get_DefineForString(Operation_Type, $1, &FlagError); if(FlagError){ vyyerror("Unknown type of Operation: %s", $1); Get_Valid_SXD(Operation_Type); } Free($1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; if(Operation_P->Type == OPERATION_GENERATE || Operation_P->Type == OPERATION_GENERATERHS || Operation_P->Type == OPERATION_GENERATEJAC || Operation_P->Type == OPERATION_GENERATESEPARATE) Operation_P->Case.Generate.GroupIndex = -1; if($4 >= -1) Operation_P->Rank = $4; else { Message::Warning("Negative MPI Rank"); Operation_P->Rank = -1; } } | tSetTime '[' Expression ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SETTIME; Operation_P->Case.SetTime.ExpressionIndex = $3; } | tSetCommSelf tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SETCOMMSELF; Operation_P->Rank = -1; } | tSetCommWorld tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SETCOMMWORLD; Operation_P->Rank = -1; } | tBarrier tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_BARRIER; Operation_P->Rank = -1; } | tBreak tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_BREAK; } | tIf '[' Expression ']' '{' Operation '}' { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_TEST; Operation_P->Case.Test.ExpressionIndex = $3; Operation_P->Case.Test.Operation_True = $6; Operation_P->Case.Test.Operation_False = NULL; } | tIf '[' Expression ']' '{' Operation '}' tElse '{' Operation '}' { List_Pop(Operation_L); List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_TEST; Operation_P->Case.Test.ExpressionIndex = $3; Operation_P->Case.Test.Operation_True = $6; Operation_P->Case.Test.Operation_False = $10; } | tSetFrequency '[' String__Index ',' Expression ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SETFREQUENCY; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.SetFrequency.ExpressionIndex = $5; } | tGenerateOnly '[' String__Index ',' ListOfFExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_GENERATEONLY; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.GenerateOnly.MatrixIndex_L = List_Create(List_Nbr($5),1,sizeof(int)); for(int i = 0; i < List_Nbr($5); i++){ double d; List_Read($5,i,&d); int j = (int)d; List_Add(Operation_P->Case.GenerateOnly.MatrixIndex_L, &j); } List_Delete($5); } | tGenerateOnlyJac '[' String__Index ',' ListOfFExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_GENERATEONLYJAC; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.GenerateOnly.MatrixIndex_L = List_Create(List_Nbr($5),1,sizeof(int)); for(int i = 0; i < List_Nbr($5); i++){ double d; List_Read($5,i,&d); int j = (int)d; List_Add(Operation_P->Case.GenerateOnly.MatrixIndex_L, &j); } List_Delete($5); } | tUpdate '[' String__Index ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_UPDATE; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.Update.ExpressionIndex = -1; } | tUpdate '[' String__Index ',' Expression ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_UPDATE; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.Update.ExpressionIndex = $5; } | tUpdateConstraint '[' String__Index ',' GroupRHS ',' String__Index ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_UPDATECONSTRAINT; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.UpdateConstraint.GroupIndex = Num_Group(&Group_S, (char*)"OP_UpdateCst", $5); Operation_P->Case.UpdateConstraint.Type = Get_DefineForString(Constraint_Type, $7, &FlagError); if(FlagError){ vyyerror("Unknown type of Constraint: %s", $7); Get_Valid_SXD(Constraint_Type); } Free($7); } | tUpdateConstraint '[' String__Index ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1) ; Operation_P->Type = OPERATION_UPDATECONSTRAINT ; int i; if ((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3) ; Free($3) ; Operation_P->DefineSystemIndex = i ; Operation_P->Case.UpdateConstraint.GroupIndex = -1; Operation_P->Case.UpdateConstraint.Type = ASSIGN; } | tFourierTransform '[' String__Index ',' String__Index ',' ListOfFExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_FOURIERTRANSFORM; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->Case.FourierTransform.DefineSystemIndex[0] = i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $5, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $5); Free($5); Operation_P->Case.FourierTransform.DefineSystemIndex[1] = i; Operation_P->Case.FourierTransform.Frequency = $7; } | tFourierTransformJ '[' String__Index ',' String__Index ',' FExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_FOURIERTRANSFORM2; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->Case.FourierTransform2.DefineSystemIndex[0] = i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $5, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $5); Free($5); Operation_P->Case.FourierTransform2.DefineSystemIndex[1] = i; Operation_P->Case.FourierTransform2.Period = $7; Operation_P->Case.FourierTransform2.Period_sofar = 0.; Operation_P->Case.FourierTransform2.Scales = NULL; } | tLanczos '[' String__Index ',' FExpr ',' ListOfFExpr ',' FExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_LANCZOS; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.Lanczos.Size = (int)$5; Operation_P->Case.Lanczos.Save = List_Create(List_Nbr($7), 1, sizeof(int)); for(int l = 0; l < List_Nbr($7); l++) { double d; List_Read($7, l, &d); int j = (int)d; List_Add(Operation_P->Case.Lanczos.Save, &j); } List_Delete($7); Operation_P->Case.Lanczos.Shift = $9; } | tEigenSolve '[' String__Index ',' FExpr ',' FExpr ',' FExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_EIGENSOLVE; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.EigenSolve.NumEigenvalues = (int)$5; Operation_P->Case.EigenSolve.Shift_r = $7; Operation_P->Case.EigenSolve.Shift_i = $9; } | tEigenSolveJac '[' String__Index ',' FExpr ',' FExpr ',' FExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_EIGENSOLVEJAC; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.EigenSolve.NumEigenvalues = (int)$5; Operation_P->Case.EigenSolve.Shift_r = $7; Operation_P->Case.EigenSolve.Shift_i = $9; } | tEvaluate '[' Expression CommaFExprOrNothing ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_EVALUATE; Operation_P->Case.Evaluate.ExpressionIndex = (int)$3; if($4 >= -1) Operation_P->Rank = $4; else { Message::Warning("Negative MPI Rank"); Operation_P->Rank = -1; } } | tSelectCorrection '[' String__Index ',' FExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1) ; Operation_P->Type = OPERATION_SELECTCORRECTION; int i; if ((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3) ; Free($3) ; Operation_P->DefineSystemIndex = i ; Operation_P->Case.SelectCorrection.Iteration = (int)$5 ; } | tAddCorrection '[' String__Index ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1) ; Operation_P->Type = OPERATION_ADDCORRECTION; int i; if ((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3) ; Free($3) ; Operation_P->DefineSystemIndex = i ; Operation_P->Case.AddCorrection.Alpha = 1. ; } | tAddCorrection '[' String__Index ',' FExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1) ; Operation_P->Type = OPERATION_ADDCORRECTION; int i; if ((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3) ; Free($3) ; Operation_P->DefineSystemIndex = i ; Operation_P->Case.AddCorrection.Alpha = $5 ; } | tMultiplySolution '[' String__Index ',' FExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1) ; Operation_P->Type = OPERATION_MULTIPLYSOLUTION; int i; if ((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3) ; Free($3) ; Operation_P->DefineSystemIndex = i ; Operation_P->Case.MultiplySolution.Alpha = $5 ; } | tAddOppositeFullSolution '[' String__Index ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1) ; Operation_P->Type = OPERATION_ADDOPPOSITEFULLSOLUTION; int i; if ((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3) ; Free($3) ; Operation_P->DefineSystemIndex = i ; } | tPerturbation '[' String__Index ',' String__Index ',' String__Index ',' FExpr ',' ListOfFExpr ',' FExpr ',' FExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_PERTURBATION; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $5, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $5); Free($5); Operation_P->Case.Perturbation.DefineSystemIndex2 = i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $7, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $7); Free($7); Operation_P->Case.Perturbation.DefineSystemIndex3 = i; Operation_P->Case.Perturbation.Size = (int)$9; Operation_P->Case.Perturbation.Save = List_Create(List_Nbr($11), 1, sizeof(int)); for(int l = 0; l < List_Nbr($11); l++) { double d; List_Read($11, l, &d); int j = (int)d; List_Add(Operation_P->Case.Perturbation.Save, &j); } List_Delete($11); Operation_P->Case.Perturbation.Shift = $13; Operation_P->Case.Perturbation.PertFreq = (int)$15; } | tTimeLoopTheta '[' FExpr ',' FExpr ',' Expression ',' Expression ']' '{' Operation '}' { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_TIMELOOPTHETA; Operation_P->Case.TimeLoopTheta.Time0 = $3; Operation_P->Case.TimeLoopTheta.TimeMax = $5; Operation_P->Case.TimeLoopTheta.DTimeIndex = $7; Operation_P->Case.TimeLoopTheta.ThetaIndex = $9; Operation_P->Case.TimeLoopTheta.Operation = $12; } | tTimeLoopNewmark '[' FExpr ',' FExpr ',' Expression ',' FExpr ',' FExpr ']' '{' Operation '}' { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_TIMELOOPNEWMARK; Operation_P->Case.TimeLoopNewmark.Time0 = $3; Operation_P->Case.TimeLoopNewmark.TimeMax = $5; Operation_P->Case.TimeLoopNewmark.DTimeIndex = $7; Operation_P->Case.TimeLoopNewmark.Beta = $9; Operation_P->Case.TimeLoopNewmark.Gamma = $11; Operation_P->Case.TimeLoopNewmark.Operation = $14; } | tTimeLoopRungeKutta '[' String__Index ',' FExpr ',' FExpr ',' Expression ',' ListOfFExpr ',' ListOfFExpr ',' ListOfFExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_TIMELOOPRUNGEKUTTA; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i ; Operation_P->Case.TimeLoopRungeKutta.Time0 = $5; Operation_P->Case.TimeLoopRungeKutta.TimeMax = $7; Operation_P->Case.TimeLoopRungeKutta.DTimeIndex = $9; Operation_P->Case.TimeLoopRungeKutta.ButcherA = $11; Operation_P->Case.TimeLoopRungeKutta.ButcherB = $13; Operation_P->Case.TimeLoopRungeKutta.ButcherC = $15; } | tTimeLoopAdaptive '[' FExpr ',' FExpr ',' FExpr ',' FExpr ',' FExpr ',' CharExpr ',' ListOfFExpr ',' LTEdefinitions TLAoptions ']' '{' Operation '}' '{' Operation '}' { List_Pop(Operation_L); List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_TIMELOOPADAPTIVE; Operation_P->Case.TimeLoopAdaptive.Time0 = $3; Operation_P->Case.TimeLoopAdaptive.TimeMax = $5; Operation_P->Case.TimeLoopAdaptive.DTimeInit = $7; Operation_P->Case.TimeLoopAdaptive.DTimeMin = $9; Operation_P->Case.TimeLoopAdaptive.DTimeMax = $11; Operation_P->Case.TimeLoopAdaptive.Scheme = $13; Operation_P->Case.TimeLoopAdaptive.Breakpoints_L = $15; Operation_P->Case.TimeLoopAdaptive.Operation = $21; Operation_P->Case.TimeLoopAdaptive.OperationEnd = $24; } | tIterativeLoopN '[' FExpr ',' Expression ',' IterativeLoopDefinitions ']' '{' Operation '}' { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_ITERATIVELOOPN; Operation_P->Case.IterativeLoop.NbrMaxIteration = (int)$3; Operation_P->Case.IterativeLoop.RelaxationFactorIndex = $5; Operation_P->Case.IterativeLoop.Operation = $10; } | tIterativeLoop '[' FExpr ',' FExpr ',' Expression ']' '{' Operation '}' { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_ITERATIVELOOP; Operation_P->Case.IterativeLoop.NbrMaxIteration = (int)$3; Operation_P->Case.IterativeLoop.Criterion = $5; Operation_P->Case.IterativeLoop.RelaxationFactorIndex = $7; Operation_P->Case.IterativeLoop.Flag = 0; Operation_P->Case.IterativeLoop.Operation = $10; } | tIterativeLoop '[' FExpr ',' FExpr ',' Expression ',' FExpr ']' '{' Operation '}' { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_ITERATIVELOOP; Operation_P->Case.IterativeLoop.NbrMaxIteration = (int)$3; Operation_P->Case.IterativeLoop.Criterion = $5; Operation_P->Case.IterativeLoop.RelaxationFactorIndex = $7; Operation_P->Case.IterativeLoop.Flag = (int)$9; Operation_P->Case.IterativeLoop.Operation = $12; } | tIterativeLinearSolver '[' CharExpr ',' CharExpr ',' FExpr ',' FExpr ',' FExpr',' ListOfFExpr',' ListOfFExpr',' ListOfFExpr ']' '{' Operation '}' '{' Operation '}' { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_ITERATIVELINEARSOLVER; Operation_P->Case.IterativeLinearSolver.OpMatMult = $3; Operation_P->Case.IterativeLinearSolver.Type = $5; Operation_P->Case.IterativeLinearSolver.Tolerance = $7; Operation_P->Case.IterativeLinearSolver.MaxIter = (int)$9; Operation_P->Case.IterativeLinearSolver.Restart = (int)$11; Operation_P->Case.IterativeLinearSolver.MyFieldTag = $13; Operation_P->Case.IterativeLinearSolver.NeighborFieldTag = $15; Operation_P->Case.IterativeLinearSolver.DeflationIndices = $17; Operation_P->Case.IterativeLinearSolver.Operations_Ax = $20; Operation_P->Case.IterativeLinearSolver.Operations_Mx = $23; } | tPrint { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_PRINT; Operation_P->Case.Print.Expression = NULL; Operation_P->DefineSystemIndex = -1; } '[' PrintOperation PrintOperationOptions ']' tEND | tWrite { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_WRITE; Operation_P->Case.Print.Expression = NULL; Operation_P->DefineSystemIndex = -1; } '[' PrintOperation PrintOperationOptions ']' tEND | tChangeOfCoordinates '[' GroupRHS ',' Expression ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_CHANGEOFCOORDINATES; Operation_P->Case.ChangeOfCoordinates.GroupIndex = Num_Group(&Group_S, (char*)"OP_ChgCoord", $3); Operation_P->Case.ChangeOfCoordinates.ExpressionIndex = $5; Operation_P->Case.ChangeOfCoordinates.ExpressionIndex2 = -1; } | tChangeOfCoordinates '[' GroupRHS ',' Expression ',' FExpr ',' Expression ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_CHANGEOFCOORDINATES; Operation_P->Case.ChangeOfCoordinates.GroupIndex = Num_Group(&Group_S, (char*)"OP_ChgCoord", $3); Operation_P->Case.ChangeOfCoordinates.ExpressionIndex = $5; Operation_P->Case.ChangeOfCoordinates.NumNode = (int)$7; Operation_P->Case.ChangeOfCoordinates.ExpressionIndex2 = $9; } | tPostOperation '[' String__Index CommaFExprOrNothing ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_POSTOPERATION; Operation_P->Case.PostOperation.PostOperations = List_Create(1,1,sizeof(char*)); List_Add(Operation_P->Case.PostOperation.PostOperations, &$3); if($4 >= -1) Operation_P->Rank = $4; else { Message::Warning("Negative MPI Rank"); Operation_P->Rank = -1; } } | tSystemCommand '[' CharExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SYSTEMCOMMAND; Operation_P->Case.SystemCommand.String = $3; } | tGmshRead '[' CharExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_GMSHREAD; Operation_P->Case.GmshRead.FileName = strSave(Get_AbsolutePath($3).c_str()); Operation_P->Case.GmshRead.ViewTag = -1; Free($3); } | tGmshRead '[' CharExpr ',' FExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_GMSHREAD; Operation_P->Case.GmshRead.FileName = strSave(Get_AbsolutePath($3).c_str()); Operation_P->Case.GmshRead.ViewTag = (int)$5; Free($3); } | tGmshClearAll tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_GMSHCLEARALL; } | tDeleteFile '[' CharExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_DELETEFILE; Operation_P->Case.DeleteFile.FileName = strSave(Get_AbsolutePath($3).c_str()); Free($3); } | tCreateDir '[' CharExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_CREATEDIR; Operation_P->Case.CreateDir.DirName = strSave(Get_AbsolutePath($3).c_str()); Free($3); } | tSolveJac_AdaptRelax '[' String__Index ',' ListOfFExpr ',' FExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SOLVEJACADAPTRELAX; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.SolveJac_AdaptRelax.CheckAll = (int)$7; Operation_P->Case.SolveJac_AdaptRelax.Factor_L = $5; } | tSaveSolutionWithEntityNum '[' String__Index ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SAVESOLUTION_WITH_ENTITY_NUM; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.SaveSolutionWithEntityNum.GroupIndex = -1; } | tSaveSolutionWithEntityNum '[' String__Index ',' GroupRHS CommaFExprOrNothing ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SAVESOLUTION_WITH_ENTITY_NUM; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.SaveSolutionWithEntityNum.GroupIndex = Num_Group(&Group_S, (char*)"OP_SaveSolutionWithEntityNum", $5); Operation_P->Case.SaveSolutionWithEntityNum.SaveFixed = ($6 >= 0) ? $6 : 0; } | tSaveSolutionExtendedMH '[' String__Index ',' FExpr ',' CharExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SAVESOLUTIONEXTENDEDMH; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.SaveSolutionExtendedMH.NbrFreq = (int)$5; Operation_P->Case.SaveSolutionExtendedMH.ResFile = $7; } | tSaveSolutionMHtoTime '[' String__Index ',' ListOfFExpr ',' CharExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SAVESOLUTIONMHTOTIME; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.SaveSolutionMHtoTime.Time = $5; Operation_P->Case.SaveSolutionMHtoTime.ResFile = $7; } | tInitMovingBand2D '[' String__Index ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Problem_S.Group, $3, fcmp_Group_Name)) < 0) vyyerror("Unknown Group: %s", $3); Operation_P->Type = OPERATION_INIT_MOVINGBAND2D; Operation_P->Case.Init_MovingBand2D.GroupIndex = i; Free($3); } | tMeshMovingBand2D '[' String__Index ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Problem_S.Group, $3, fcmp_Group_Name)) < 0) vyyerror("Unknown Group: %s", $3); Operation_P->Type = OPERATION_MESH_MOVINGBAND2D; Operation_P->Case.Mesh_MovingBand2D.GroupIndex = i; Free($3); } | tSaveMesh '[' String__Index ',' GroupRHS ',' CharExpr ',' Expression ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.SaveMesh.GroupIndex = Num_Group(&Group_S, (char*)"OP_SaveMesh", $5); Operation_P->Case.SaveMesh.FileName = $7; Operation_P->Case.SaveMesh.ExprIndex = $9; Operation_P->Type = OPERATION_SAVEMESH; } | tSaveMesh '[' String__Index ',' GroupRHS ',' CharExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.SaveMesh.GroupIndex = Num_Group(&Group_S, (char*)"OP_SaveMesh", $5); Operation_P->Case.SaveMesh.FileName = $7; Operation_P->Case.SaveMesh.ExprIndex = -1; Operation_P->Type = OPERATION_SAVEMESH; } | tGenerate_MH_Moving '[' String__Index ',' String__Index ',' FExpr ',' FExpr ']' '{' Operation '}' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; if((i = List_ISearchSeq(Problem_S.Group, $5, fcmp_Group_Name)) < 0) vyyerror("Unknown Group: %s", $5); Free($5); Operation_P->Type = OPERATION_GENERATE_MH_MOVING; Operation_P->Case.Generate_MH_Moving.GroupIndex = i; Operation_P->Case.Generate_MH_Moving.Period = $7; Operation_P->Case.Generate_MH_Moving.NbrStep = (int)$9; Operation_P->Case.Generate_MH_Moving.Operation = $12; } | tGenerate_MH_Moving_Separate '[' String__Index ',' String__Index ',' FExpr ',' FExpr ']' '{' Operation '}' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; if((i = List_ISearchSeq(Problem_S.Group, $5, fcmp_Group_Name)) < 0) vyyerror("Unknown Group: %s", $5); Free($5); Operation_P->Type = OPERATION_GENERATE_MH_MOVING_S; Operation_P->Case.Generate_MH_Moving_S.GroupIndex = i; Operation_P->Case.Generate_MH_Moving_S.Period = $7; Operation_P->Case.Generate_MH_Moving_S.NbrStep = (int)$9; Operation_P->Case.Generate_MH_Moving_S.Operation = $12; } | tAdd_MH_Moving '[' String__Index ',' FExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->Type = OPERATION_ADD_MH_MOVING; Operation_P->Case.Add_MH_Moving.dummy = $5; } | tDeformeMesh '[' tSTRING ',' tSTRING ',' tNameOfMesh CharExpr ',' FExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.DeformeMesh.Quantity = $5; Operation_P->Case.DeformeMesh.Name_MshFile = $8; Operation_P->Case.DeformeMesh.GeoDataIndex = -1; Operation_P->Case.DeformeMesh.Factor = $10; Operation_P->Type = OPERATION_DEFORMEMESH; } | tDeformeMesh '[' tSTRING ',' tSTRING ',' tNameOfMesh CharExpr ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.DeformeMesh.Quantity = $5; Operation_P->Case.DeformeMesh.Name_MshFile = $8; Operation_P->Case.DeformeMesh.GeoDataIndex = -1; Operation_P->Case.DeformeMesh.Factor = 1; Operation_P->Type = OPERATION_DEFORMEMESH; } | tDeformeMesh '[' tSTRING ',' tSTRING ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Case.DeformeMesh.Quantity = $5; Operation_P->Case.DeformeMesh.Name_MshFile = NULL; Operation_P->Case.DeformeMesh.GeoDataIndex = -1; Operation_P->Case.DeformeMesh.Factor = 1; Operation_P->Type = OPERATION_DEFORMEMESH; } | tGenerateGroup '[' String__Index ',' String__Index CommaFExprOrNothing ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; if((i = List_ISearchSeq(Problem_S.Group, $5, fcmp_Group_Name)) < 0) vyyerror("Unknown Group: %s", $5); Free($5); Operation_P->Type = OPERATION_GENERATE; Operation_P->Case.Generate.GroupIndex = i; if($6 >= -1) Operation_P->Rank = $6; else { Message::Warning("Negative MPI Rank"); Operation_P->Rank = -1; } } | tGenerateJacGroup '[' String__Index ',' String__Index CommaFExprOrNothing ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; if((i = List_ISearchSeq(Problem_S.Group, $5, fcmp_Group_Name)) < 0) vyyerror("Unknown Group: %s", $5); Free($5); Operation_P->Type = OPERATION_GENERATEJAC; Operation_P->Case.Generate.GroupIndex = i; if($6 >= -1) Operation_P->Rank = $6; else { Message::Warning("Negative MPI Rank"); Operation_P->Rank = -1; } } | tGenerateRHSGroup '[' String__Index ',' GroupRHS CommaFExprOrNothing ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; Operation_P->Type = OPERATION_GENERATERHS; Operation_P->Case.Generate.GroupIndex = $5; if($6 >= -1) Operation_P->Rank = $6; else { Message::Warning("Negative MPI Rank"); Operation_P->Rank = -1; } } | tSolveAgainWithOther '[' String__Index ',' String__Index CommaFExprOrNothing ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = OPERATION_SOLVEAGAINWITHOTHER; int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); Free($3); Operation_P->DefineSystemIndex = i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $5, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $5); Free($5); Operation_P->Case.SolveAgainWithOther.DefineSystemIndex = i; if($6 >= -1) Operation_P->Rank = $6; else { Message::Warning("Negative MPI Rank"); Operation_P->Rank = -1; } } // FIXME: Roman | tTensorProductSolve '[' '{' RecursiveListOfString__Index '}' ',' '{' RecursiveListOfString__Index '}' ',' ListOfFExpr ',' '{' RecursiveListOfListOfFExpr '}' ']' tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TensorProductSolve.SystemIndex = List_Create(4, 4, sizeof(int)); for(int j = 0; j < List_Nbr($4); j++){ char *sys; List_Read($4, j, &sys); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, sys, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", sys); Free(sys); List_Add(Operation_P->Case.TensorProductSolve.SystemIndex, &i); } List_Delete($4); Operation_P->Case.TensorProductSolve.ExpectationIndex = List_Create(4, 4, sizeof(int)); for(int j = 0; j < List_Nbr($8); j++){ char *sys; List_Read($8, j, &sys); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, sys, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", sys); Free(sys); List_Add(Operation_P->Case.TensorProductSolve.ExpectationIndex, &i); } List_Delete($8); Operation_P->Case.TensorProductSolve.LocalMatrixIndex = $11; Operation_P->Case.TensorProductSolve.ExpansionCoef = $14; Operation_P->Type = OPERATION_TENSORPRODUCTSOLVE; } | Loop { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Type = NONE; } ; PrintOperation : ListOfExpression { Operation_P->Case.Print.Expression = List_Copy(ListOfInt_L); } | String__Index { int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $1, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $1); Free($1); Operation_P->DefineSystemIndex = i; } ; PrintOperationOptions : { Operation_P->Case.Print.FileOut = NULL; Operation_P->Case.Print.TimeStep = NULL; Operation_P->Case.Print.DofNumber = NULL; } | PrintOperationOptions PrintOperationOption ; PrintOperationOption : ',' tFile CharExpr { Operation_P->Case.Print.FileOut = $3; } | ',' tTimeStep ListOfFExpr { Operation_P->Case.Print.TimeStep = List_Create(List_Nbr($3), 1, sizeof(int)); for(int i = 0; i < List_Nbr($3); i++){ double d; List_Read($3,i,&d); int j = (int)d; List_Add(Operation_P->Case.Print.TimeStep, &j); } List_Delete($3); } | ',' ListOfFExpr { Operation_P->Case.Print.DofNumber = List_Create(List_Nbr($2), 1, sizeof(int)); for(int i = 0; i < List_Nbr($2); i++) { double d; List_Read($2, i, &d); int j = (int)d; List_Add(Operation_P->Case.Print.DofNumber, &j); } List_Delete($2); } ; TLAoptions : /* none */ { Operation_P->Case.TimeLoopAdaptive.LTEtarget = -1.; Operation_P->Case.TimeLoopAdaptive.DTimeMaxScal = -1.; Operation_P->Case.TimeLoopAdaptive.DTimeScal_NotConverged = -1.; } | ',' FExpr { Operation_P->Case.TimeLoopAdaptive.LTEtarget = $2; Operation_P->Case.TimeLoopAdaptive.DTimeMaxScal = -1.; Operation_P->Case.TimeLoopAdaptive.DTimeScal_NotConverged = -1.; } | ',' FExpr ',' FExpr { Operation_P->Case.TimeLoopAdaptive.LTEtarget = $2; Operation_P->Case.TimeLoopAdaptive.DTimeMaxScal = $4; Operation_P->Case.TimeLoopAdaptive.DTimeScal_NotConverged = -1.; } | ',' FExpr ',' FExpr ',' FExpr { Operation_P->Case.TimeLoopAdaptive.LTEtarget = $2; Operation_P->Case.TimeLoopAdaptive.DTimeMaxScal = $4; Operation_P->Case.TimeLoopAdaptive.DTimeScal_NotConverged = $6; } ; LTEdefinitions : /* none */ { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopAdaptive.TimeLoopAdaptiveSystems_L = NULL; Operation_P->Case.TimeLoopAdaptive.TimeLoopAdaptivePOs_L = NULL; } | LTEdefinitions tDefineSystem '{' TimeLoopAdaptiveSystems '}' { Operation_P->Case.TimeLoopAdaptive.TimeLoopAdaptiveSystems_L = $4; } | LTEdefinitions tPostOperation '{' TimeLoopAdaptivePOs '}' { Operation_P->Case.TimeLoopAdaptive.TimeLoopAdaptivePOs_L = $4; } ; TimeLoopAdaptiveSystems : /* none */ { $$ = List_Create(4, 4, sizeof(struct TimeLoopAdaptiveSystem)); } | TimeLoopAdaptiveSystems '{' String__Index ',' FExpr ',' FExpr ',' tSTRING '}' { int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); TimeLoopAdaptiveSystem_S.SystemIndex = i; TimeLoopAdaptiveSystem_S.SystemLTEreltol = $5; TimeLoopAdaptiveSystem_S.SystemLTEabstol = $7; TimeLoopAdaptiveSystem_S.NormType = Get_DefineForString(ErrorNorm_Type, $9, &FlagError); if(FlagError){ vyyerror("Unknown error norm type of TimeLoopAdaptive system %s", $3); Get_Valid_SXD(ChangeOfState_Type); } TimeLoopAdaptiveSystem_S.NormTypeString = $9; List_Add($$ = $1, &TimeLoopAdaptiveSystem_S); Free($3); } ; TimeLoopAdaptivePOs : /* none */ { $$ = List_Create(4, 4, sizeof(struct LoopErrorPostOperation)); } | TimeLoopAdaptivePOs '{' String__Index ',' FExpr ',' FExpr ',' tSTRING '}' { TimeLoopAdaptivePO_S.PostOperationName = $3; TimeLoopAdaptivePO_S.PostOperationReltol = $5; TimeLoopAdaptivePO_S.PostOperationAbstol = $7; TimeLoopAdaptivePO_S.NormType = Get_DefineForString(ErrorNorm_Type, $9, &FlagError); if(FlagError){ vyyerror("Unknown error norm type of TimeLoopAdaptive PostOperation %s", $3); Get_Valid_SXD(ChangeOfState_Type); } TimeLoopAdaptivePO_S.NormTypeString = $9; List_Add($$ = $1, &TimeLoopAdaptivePO_S); } ; IterativeLoopDefinitions : /* none */ { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeLoop.IterativeLoopSystems_L = NULL; Operation_P->Case.IterativeLoop.IterativeLoopPOs_L = NULL; } | IterativeLoopDefinitions tDefineSystem '{' IterativeLoopSystems '}' { Operation_P->Case.IterativeLoop.IterativeLoopSystems_L = $4; } | IterativeLoopDefinitions tPostOperation '{' IterativeLoopPOs '}' { Operation_P->Case.IterativeLoop.IterativeLoopPOs_L = $4; } ; IterativeLoopSystems : /* none */ { $$ = List_Create(4, 4, sizeof(struct IterativeLoopSystem)); } | IterativeLoopSystems '{' String__Index ',' FExpr ',' FExpr ',' tSTRING tSTRING '}' { int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $3, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $3); IterativeLoopSystem_S.SystemIndex = i; IterativeLoopSystem_S.SystemILreltol = $5; IterativeLoopSystem_S.SystemILabstol = $7; IterativeLoopSystem_S.NormOf = Get_DefineForString(NormOf_Type, $9, &FlagError); if(FlagError){ vyyerror("Unknown object for error norm of IterativeLoop system: %s", $3); Get_Valid_SXD(ChangeOfState_Type); } IterativeLoopSystem_S.NormOfString = $9; IterativeLoopSystem_S.NormType = Get_DefineForString(ErrorNorm_Type, $10, &FlagError); if(FlagError){ vyyerror("Unknown error norm type of IterativeLoop system: %s", $3); Get_Valid_SXD(ChangeOfState_Type); } IterativeLoopSystem_S.NormTypeString = $10; List_Add($$ = $1, &IterativeLoopSystem_S); Free($3); } ; IterativeLoopPOs : /* none */ { $$ = List_Create(4, 4, sizeof(struct LoopErrorPostOperation)); } | IterativeLoopPOs '{' String__Index ',' FExpr ',' FExpr ',' tSTRING '}' { IterativeLoopPO_S.PostOperationName = $3; IterativeLoopPO_S.PostOperationReltol = $5; IterativeLoopPO_S.PostOperationAbstol = $7; IterativeLoopPO_S.NormType = Get_DefineForString(ErrorNorm_Type, $9, &FlagError); if(FlagError){ vyyerror("Unknown error norm type of IterativeLoopN PostOperation %s", $3); Get_Valid_SXD(ChangeOfState_Type); } IterativeLoopPO_S.NormTypeString = $9; List_Add($$ = $1, &IterativeLoopPO_S); } ; /* ------ the following should disapear with the new syntax ------------- */ TimeLoopTheta : /* none */ { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopTheta.Time0 = 0.; Operation_P->Case.TimeLoopTheta.TimeMax = 1.; Operation_P->Case.TimeLoopTheta.DTimeIndex = -1; Operation_P->Case.TimeLoopTheta.ThetaIndex = -1; Operation_P->Case.TimeLoopTheta.Operation = NULL; } | TimeLoopTheta TimeLoopThetaTerm ; TimeLoopThetaTerm : tTime0 FExpr tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopTheta.Time0 = $2; } | tTimeMax FExpr tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopTheta.TimeMax = $2; } | tDTime Expression tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopTheta.DTimeIndex = $2; } | tTheta Expression tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopTheta.ThetaIndex = $2; } | tOperation '{' Operation '}' { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopTheta.Operation = $3; } ; TimeLoopNewmark : /* none */ { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopNewmark.Time0 = 0.; Operation_P->Case.TimeLoopNewmark.TimeMax = 1.; Operation_P->Case.TimeLoopNewmark.DTimeIndex = -1; Operation_P->Case.TimeLoopNewmark.Beta = 0.25; Operation_P->Case.TimeLoopNewmark.Gamma = 0.5; Operation_P->Case.TimeLoopNewmark.Operation = NULL; } | TimeLoopNewmark TimeLoopNewmarkTerm ; TimeLoopNewmarkTerm : tTime0 FExpr tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopNewmark.Time0 = $2; } | tTimeMax FExpr tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopNewmark.TimeMax = $2; } | tDTime Expression tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopNewmark.DTimeIndex = $2; } | tBeta FExpr tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopNewmark.Beta = $2; } | tGamma FExpr tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopNewmark.Gamma = $2; } | tOperation '{' Operation '}' { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.TimeLoopNewmark.Operation = $3; } ; IterativeLoop : /* none */ { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeLoop.NbrMaxIteration = 20; Operation_P->Case.IterativeLoop.Criterion = 1.e-3; Operation_P->Case.IterativeLoop.RelaxationFactorIndex = -1; Operation_P->Case.IterativeLoop.Flag = 0; Operation_P->Case.IterativeLoop.Operation = NULL; } | IterativeLoop IterativeLoopTerm ; IterativeLoopTerm : tNbrMaxIteration FExpr tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeLoop.NbrMaxIteration = (int)$2; } | tCriterion FExpr tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeLoop.Criterion = $2; } | tRelaxationFactor Expression tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeLoop.RelaxationFactorIndex = $2; } | tFlag FExpr tEND /* Attention: phase test */ { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeLoop.Flag = (int)$2; } | tOperation '{' Operation '}' { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeLoop.Operation = $3; } ; IterativeTimeReduction : /* none */ { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeTimeReduction.NbrMaxIteration = 20; Operation_P->Case.IterativeTimeReduction.DivisionCoefficient = 2.; Operation_P->Case.IterativeTimeReduction.Criterion = 1.e-3; Operation_P->Case.IterativeTimeReduction.Flag = 0; Current_System = Operation_P->DefineSystemIndex = -1; Operation_P->Case.IterativeTimeReduction.ChangeOfState = NULL; Operation_P->Case.IterativeTimeReduction.Operation = NULL; Operation_P->Case.IterativeTimeReduction.OperationEnd = NULL; } | IterativeTimeReduction IterativeTimeReductionTerm ; IterativeTimeReductionTerm : tNbrMaxIteration FExpr tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeTimeReduction.NbrMaxIteration = (int)$2; } | tDivisionCoefficient FExpr tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeTimeReduction.DivisionCoefficient = $2; } | tCriterion FExpr tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeTimeReduction.Criterion = $2; } | tFlag FExpr tEND /* Attention: phase test */ { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeTimeReduction.Flag = (int)$2; } | tDefineSystem String__Index tEND { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); int i; if((i = List_ISearchSeq(Resolution_S.DefineSystem, $2, fcmp_DefineSystem_Name)) < 0) vyyerror("Unknown System: %s", $2); Free($2); Current_System = Operation_P->DefineSystemIndex = i; } | tChangeOfState '{' ChangeOfStates '}' { Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeTimeReduction.ChangeOfState = $3; } | tOperation '{' Operation '}' { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeTimeReduction.Operation = $3; } | tOperationEnd '{' Operation '}' { List_Pop(Operation_L); Operation_P = (struct Operation*) List_Pointer(Operation_L, List_Nbr(Operation_L)-1); Operation_P->Case.IterativeTimeReduction.OperationEnd = $3; } ; ChangeOfStates : /* none */ { $$ = List_Create(3, 3, sizeof (struct ChangeOfState)); } | ChangeOfStates '{' ChangeOfState '}' { List_Add($$ = $1, &ChangeOfState_S); } ; ChangeOfState : /* none */ { ChangeOfState_S.Type = CHANGEOFSTATE_CHANGESIGN; ChangeOfState_S.QuantityIndex = -1; ChangeOfState_S.FormulationIndex = -1; ChangeOfState_S.InIndex = -1; ChangeOfState_S.Criterion = 1.e-2; ChangeOfState_S.ExpressionIndex = ChangeOfState_S.ExpressionIndex2 = -1; ChangeOfState_S.FlagIndex = -1; ChangeOfState_S.ActiveList[0] = NULL; ChangeOfState_S.ActiveList[1] = NULL; } | ChangeOfState ChangeOfStateTerm ; ChangeOfStateTerm : tType tSTRING tEND { ChangeOfState_S.Type = Get_DefineForString(ChangeOfState_Type, $2, &FlagError); if(FlagError){ vyyerror("Unknown type of ChangeOfState: %s", $2); Get_Valid_SXD(ChangeOfState_Type); } Free($2); } | tQuantity tSTRING tEND { if(Current_System >= 0) { List_T *ListOfInt_Lnew = ((struct DefineSystem *)List_Pointer(Resolution_S.DefineSystem, Current_System))->FormulationIndex; int *ListOfInt_P =(int *)List_Pointer(ListOfInt_Lnew, 0); int i = 0, j; for(j = 0; j < List_Nbr(ListOfInt_Lnew); j++) { Formulation_S.DefineQuantity = ((struct Formulation *) List_Pointer(Problem_S.Formulation, ListOfInt_P[j]))->DefineQuantity; if((i = List_ISearchSeq(Formulation_S.DefineQuantity, $2, fcmp_DefineQuantity_Name)) >= 0) break; } if(j tGalerkin' */ | SubPostQuantities tGalerkin '{' SubPostQuantity '}' { PostQuantityTerm_S.EvaluationType = INTEGRAL; List_Add($$ = $1, &PostQuantityTerm_S); } | SubPostQuantities tSTRING '{' SubPostQuantity '}' { PostQuantityTerm_S.EvaluationType = Get_DefineForString(PostQuantityTerm_EvaluationType, $2, &FlagError); if(FlagError){ vyyerror("Unknown EvaluationType for PostQuantityTerm: %s", $2); Get_Valid_SXD(PostQuantityTerm_EvaluationType); } Free($2); List_Add($$ = $1, &PostQuantityTerm_S); } | SubPostQuantities Loop { $$ = $1 ; } ; SubPostQuantity : /* none */ { PostQuantityTerm_S.Type = 0; PostQuantityTerm_S.TypeTimeDerivative = NODT_; PostQuantityTerm_S.WholeQuantity = NULL; PostQuantityTerm_S.InIndex = -1; PostQuantityTerm_S.JacobianMethodIndex = -1; PostQuantityTerm_S.IntegrationMethodIndex = -1; } | SubPostQuantity SubPostQuantityTerm ; SubPostQuantityTerm : TermOperator '[' { PostQuantityTerm_S.TypeTimeDerivative = Type_TermOperator; Current_DofIndexInWholeQuantity = -2; List_Reset(ListOfPointer_L); } WholeQuantityExpression ']' tEND { PostQuantityTerm_S.WholeQuantity = $4; Pro_DefineQuantityIndex (PostQuantityTerm_S.WholeQuantity, -1, &PostQuantityTerm_S.NbrQuantityIndex, &PostQuantityTerm_S.QuantityIndexTable, &PostQuantityTerm_S.QuantityTraceGroupIndexTable); if(!PostQuantityTerm_S.Type) { PostQuantityTerm_S.Type = 0; for(int i = 0; i < PostQuantityTerm_S.NbrQuantityIndex; i++) { int j = -1; if(PostQuantityTerm_S.QuantityIndexTable[i] >= 0) j = ((struct DefineQuantity *) List_Pointer (((struct Formulation *) List_Pointer(Problem_S.Formulation, PostProcessing_S.FormulationIndex))->DefineQuantity, PostQuantityTerm_S.QuantityIndexTable[i])) -> Type; if(PostQuantityTerm_S.Type == 0) PostQuantityTerm_S.Type = j; else if(PostQuantityTerm_S.Type != j) vyyerror("Mixed discrete Quantity types in term (should be split in separate terms)"); } if(PostQuantityTerm_S.Type == 0) PostQuantityTerm_S.Type = LOCALQUANTITY; } } | tType tSTRING tEND { /* force the Type */ PostQuantityTerm_S.Type = Get_DefineForString(DefineQuantity_Type, $2, &FlagError); if(FlagError){ vyyerror("Unknown type of Operation: %s", $2); Get_Valid_SXD(DefineQuantity_Type); } Free($2); } | tIn GroupRHS tEND { PostQuantityTerm_S.InIndex = Num_Group(&Group_S, (char*)"PQ_In", $2); } | tJacobian String__Index tEND { int i; if((i = List_ISearchSeq(Problem_S.JacobianMethod, $2, fcmp_JacobianMethod_Name)) < 0) vyyerror("Unknown Jacobian method: %s",$2); else PostQuantityTerm_S.JacobianMethodIndex = i; Free($2); } | tIntegration tSTRING tEND { int i; if((i = List_ISearchSeq(Problem_S.IntegrationMethod, $2, fcmp_IntegrationMethod_Name)) < 0) vyyerror("Unknown Integration method: %s",$2); else PostQuantityTerm_S.IntegrationMethodIndex = i; Free($2); } ; /* ------------------------------------------------------------------------ */ /* P o s t O p e r a t i o n */ /* ------------------------------------------------------------------------ */ PostOperations : /* none */ { if(!Problem_S.PostOperation) Problem_S.PostOperation = List_Create(10, 5, sizeof (struct PostOperation)); } | PostOperations BracedPostOperation ; BracedPostOperation : '{' PostOperation '}' { List_Add(Problem_S.PostOperation, &PostOperation_S); } | Loop ; PostOperation : /* none */ { PostOperation_S.Name = NULL; PostOperation_S.AppendString = NULL; PostOperation_S.Format = FORMAT_GMSH; PostOperation_S.PostProcessingIndex = -1; PostOperation_S.ResampleTime = false; } | PostOperation PostOperationTerm ; PostOperationTerm : tName String__Index tEND { Check_NameOfStructNotExist("PostOperation", Problem_S.PostOperation, $2, fcmp_PostOperation_Name); PostOperation_S.Name = $2; } | tNameOfPostProcessing String__Index tEND { int i; if((i = List_ISearchSeq(Problem_S.PostProcessing, $2, fcmp_PostProcessing_Name)) < 0) vyyerror("Unknown PostProcessing: %s", $2); else { PostOperation_S.PostProcessingIndex = i; List_Read(Problem_S.PostProcessing, i, &InteractivePostProcessing_S); } Free($2); } | tFormat tSTRING tEND { PostOperation_S.Format = Get_DefineForString(PostSubOperation_Format, $2, &FlagError); if(FlagError){ vyyerror("Unknown PostProcessing Format: %s", $2); Get_Valid_SXD(PostSubOperation_Format); } Free($2); } | tAppend CharExpr tEND { PostOperation_S.AppendString = $2; } | tResampleTime '[' FExpr ',' FExpr ',' FExpr ']' tEND { PostOperation_S.ResampleTime = true; PostOperation_S.ResampleTimeStart = $3; PostOperation_S.ResampleTimeStop = $5; PostOperation_S.ResampleTimeStep = $7; } | tOperation '{' PostSubOperations '}' { PostOperation_S.PostSubOperation = $3; } ; SeparatePostOperation : tPostOperation String__Index tUsingPost String__Index { PostOperation_S.PostProcessingIndex = -1; PostOperation_S.AppendString = NULL; PostOperation_S.Format = FORMAT_GMSH; int i; if((i = List_ISearchSeq(Problem_S.PostProcessing, $4, fcmp_PostProcessing_Name)) < 0) vyyerror("Unknown PostProcessing: %s", $4); else { PostOperation_S.PostProcessingIndex = i; List_Read(Problem_S.PostProcessing, i, &InteractivePostProcessing_S); if(!Problem_S.PostOperation) Problem_S.PostOperation = List_Create(5, 5, sizeof (struct PostOperation)); PostOperation_S.Name = $2; } Free($4); } '{' PostSubOperations '}' { PostOperation_S.PostSubOperation = $7; if(PostOperation_S.PostProcessingIndex >= 0) List_Add(Problem_S.PostOperation, &PostOperation_S); } ; PostSubOperations : /* none */ { $$ = List_Create(5, 5, sizeof (struct PostSubOperation)); } | PostSubOperations { PostSubOperation_S.Format = -1; } PostSubOperation { if(PostSubOperation_S.Type != POP_NONE) { if(PostSubOperation_S.Format < 0) PostSubOperation_S.Format = PostOperation_S.Format; List_Add($$ = $1, &PostSubOperation_S); } } ; PostSubOperation : tPlot '[' PostQuantitiesToPrint PrintSubType PrintOptions ']' tEND { vyyerror("Plot has been superseded by Print (Plot OnRegion becomes Print OnElementsOf)"); } | tPrint '[' PostQuantitiesToPrint PrintSubType PrintOptions ']' tEND { PostSubOperation_S.Type = POP_PRINT; } | tPrint '[' tBIGSTR ',' Expression PrintOptions ']' tEND { PostSubOperation_S.Type = POP_EXPRESSION; PostSubOperation_S.Case.Expression.String = $3; PostSubOperation_S.Case.Expression.String2 = NULL; PostSubOperation_S.Case.Expression.ExpressionIndex = $5; PostSubOperation_S.PostQuantityIndex[0] = -1; } | tPrint '[' tBIGSTR ',' tStr '[' CharExpr ']' PrintOptions ']' tEND { PostSubOperation_S.Type = POP_EXPRESSION; PostSubOperation_S.Case.Expression.String = $3; PostSubOperation_S.Case.Expression.String2 = $7; PostSubOperation_S.Case.Expression.ExpressionIndex = -1; PostSubOperation_S.PostQuantityIndex[0] = -1; } | tEcho '[' tBIGSTR PrintOptions ']' tEND { PostSubOperation_S.Type = POP_EXPRESSION; PostSubOperation_S.Case.Expression.String = $3; PostSubOperation_S.Case.Expression.String2 = NULL; PostSubOperation_S.Case.Expression.ExpressionIndex = -1; PostSubOperation_S.PostQuantityIndex[0] = -1; } | tPrintGroup '[' GroupRHS { PostSubOperation_S.Type = POP_GROUP; PostSubOperation_S.Case.Group.ExtendedGroupIndex = Num_Group(&Group_S, (char*)"PO_Group", $3); PostSubOperation_S.PostQuantityIndex[0] = -1; } ',' tIn GroupRHS PrintOptions ']' tEND { PostSubOperation_S.Case.Group.GroupIndex = Num_Group(&Group_S, (char*)"PO_Group", $7); } | Loop { PostSubOperation_S.Type = POP_NONE; } ; PostQuantitiesToPrint : String__Index PostQuantitySupport ',' { int i; if((i = List_ISearchSeq(InteractivePostProcessing_S.PostQuantity, $1, fcmp_PostQuantity_Name)) < 0) vyyerror("Unknown PostProcessing Quantity: %s", $1); PostSubOperation_S.PostQuantityIndex[0] = i; PostSubOperation_S.PostQuantityIndex[1] = -1; PostSubOperation_S.PostQuantitySupport[0] = $2; PostSubOperation_S.PostQuantitySupport[1] = -1; Free($1); } | String__Index PostQuantitySupport Combination tSTRING PostQuantitySupport ',' { int i; if((i = List_ISearchSeq(InteractivePostProcessing_S.PostQuantity, $1, fcmp_PostQuantity_Name)) < 0) vyyerror("Unknown PostProcessing Quantity: %s", $1); PostSubOperation_S.PostQuantityIndex[0] = i; PostSubOperation_S.PostQuantitySupport[0] = $2; int j = -1; if((j = List_ISearchSeq(InteractivePostProcessing_S.PostQuantity, $4, fcmp_PostQuantity_Name)) < 0) vyyerror("Unknown PostProcessing Quantity: %s", $4); PostSubOperation_S.PostQuantityIndex[1] = j; PostSubOperation_S.PostQuantitySupport[1] = $5; if(($2 < 0 && $5 < 0) || ($2 >= 0 && $5 >= 0)) { vyyerror("Postprocessing Quantities '%s' and '%s' of same type (%s)", $1, $4, ($2>0)? "with Support":"without Support"); } Free($1); Free($4); } ; Combination : '*' { PostSubOperation_S.CombinationType = MULTIPLICATION; } | '/' { PostSubOperation_S.CombinationType = DIVISION; } | '+' { PostSubOperation_S.CombinationType = ADDITION; } | '-' { PostSubOperation_S.CombinationType = SOUSTRACTION; } ; PostQuantitySupport : /* none */ { $$ = -1; } | '[' GroupRHS ']' { $$ = Num_Group(&Group_S, (char*)"PO_Support", $2); } ; PrintSubType : tOnGlobal { PostSubOperation_S.SubType = PRINT_ONREGION; PostSubOperation_S.Case.OnRegion.RegionIndex = -1; } | tOnRegion GroupRHS { PostSubOperation_S.SubType = PRINT_ONREGION; PostSubOperation_S.Case.OnRegion.RegionIndex = Num_Group(&Group_S, (char*)"PO_OnRegion", $2); } | tOnElementsOf GroupRHS { PostSubOperation_S.SubType = PRINT_ONELEMENTSOF; PostSubOperation_S.Case.OnRegion.RegionIndex = Num_Group(&Group_S, (char*)"PO_OnElementsOf", $2); } | tOnSection '{' '{' RecursiveListOfFExpr '}' '{' RecursiveListOfFExpr '}' '{' RecursiveListOfFExpr '}' '}' { PostSubOperation_S.SubType = PRINT_ONSECTION_2D; if(List_Nbr($4) != 3 || List_Nbr($7) != 3 || List_Nbr($10) != 3) vyyerror("Expected {3}{3}{3} coordinates, got {%d}{%d}{%d}", List_Nbr($4), List_Nbr($7), List_Nbr($10)); else{ List_Read($4, 0, &PostSubOperation_S.Case.OnSection.x[0]); List_Read($4, 1, &PostSubOperation_S.Case.OnSection.y[0]); List_Read($4, 2, &PostSubOperation_S.Case.OnSection.z[0]); List_Read($7, 0, &PostSubOperation_S.Case.OnSection.x[1]); List_Read($7, 1, &PostSubOperation_S.Case.OnSection.y[1]); List_Read($7, 2, &PostSubOperation_S.Case.OnSection.z[1]); List_Read($10, 0, &PostSubOperation_S.Case.OnSection.x[2]); List_Read($10, 1, &PostSubOperation_S.Case.OnSection.y[2]); List_Read($10, 2, &PostSubOperation_S.Case.OnSection.z[2]); } List_Delete($4); List_Delete($7); List_Delete($10); } | tOnGrid GroupRHS { PostSubOperation_S.SubType = PRINT_ONGRID; PostSubOperation_S.Case.OnRegion.RegionIndex = Num_Group(&Group_S, (char*)"PO_OnGrid", $2); } | tOnGrid '{' Expression ',' Expression ',' Expression '}' '{' ListOfFExpr ',' ListOfFExpr ',' ListOfFExpr '}' { PostSubOperation_S.SubType = PRINT_ONGRID_PARAM; PostSubOperation_S.Case.OnParamGrid.ExpressionIndex[0] = $3; PostSubOperation_S.Case.OnParamGrid.ExpressionIndex[1] = $5; PostSubOperation_S.Case.OnParamGrid.ExpressionIndex[2] = $7; PostSubOperation_S.Case.OnParamGrid.ParameterValue[0] = $10; PostSubOperation_S.Case.OnParamGrid.ParameterValue[1] = $12; PostSubOperation_S.Case.OnParamGrid.ParameterValue[2] = $14; } | tOnPoint '{' RecursiveListOfFExpr '}' { PostSubOperation_S.SubType = PRINT_ONGRID_0D; if(List_Nbr($3) != 3) vyyerror("Expected {3} coordinates, got {%d}", List_Nbr($3)); else{ List_Read($3, 0, &PostSubOperation_S.Case.OnGrid.x[0]); List_Read($3, 1, &PostSubOperation_S.Case.OnGrid.y[0]); List_Read($3, 2, &PostSubOperation_S.Case.OnGrid.z[0]); } List_Delete($3); } | tOnLine '{' '{' RecursiveListOfFExpr '}' '{' RecursiveListOfFExpr '}' '}' '{' FExpr '}' { PostSubOperation_S.SubType = PRINT_ONGRID_1D; if(List_Nbr($4) != 3 || List_Nbr($7) != 3) vyyerror("Expected {3}{3} coordinates, got {%d}{%d}", List_Nbr($4), List_Nbr($7)); else{ List_Read($4, 0, &PostSubOperation_S.Case.OnGrid.x[0]); List_Read($4, 1, &PostSubOperation_S.Case.OnGrid.y[0]); List_Read($4, 2, &PostSubOperation_S.Case.OnGrid.z[0]); List_Read($7, 0, &PostSubOperation_S.Case.OnGrid.x[1]); List_Read($7, 1, &PostSubOperation_S.Case.OnGrid.y[1]); List_Read($7, 2, &PostSubOperation_S.Case.OnGrid.z[1]); } PostSubOperation_S.Case.OnGrid.n[0] = (int)$11; List_Delete($4); List_Delete($7); } | tOnPlane '{' '{' RecursiveListOfFExpr '}' '{' RecursiveListOfFExpr '}' '{' RecursiveListOfFExpr '}' '}' '{' FExpr ',' FExpr '}' { PostSubOperation_S.SubType = PRINT_ONGRID_2D; if(List_Nbr($4) != 3 || List_Nbr($7) != 3 || List_Nbr($10) != 3) vyyerror("Expected {3}{3}{3} coordinates, got {%d}{%d}{%d}", List_Nbr($4), List_Nbr($7), List_Nbr($10)); else{ List_Read($4, 0, &PostSubOperation_S.Case.OnGrid.x[0]); List_Read($4, 1, &PostSubOperation_S.Case.OnGrid.y[0]); List_Read($4, 2, &PostSubOperation_S.Case.OnGrid.z[0]); List_Read($7, 0, &PostSubOperation_S.Case.OnGrid.x[1]); List_Read($7, 1, &PostSubOperation_S.Case.OnGrid.y[1]); List_Read($7, 2, &PostSubOperation_S.Case.OnGrid.z[1]); List_Read($10, 0, &PostSubOperation_S.Case.OnGrid.x[2]); List_Read($10, 1, &PostSubOperation_S.Case.OnGrid.y[2]); List_Read($10, 2, &PostSubOperation_S.Case.OnGrid.z[2]); } PostSubOperation_S.Case.OnGrid.n[0] = (int)$14; PostSubOperation_S.Case.OnGrid.n[1] = (int)$16; List_Delete($4); List_Delete($7); List_Delete($10); } | tOnBox '{' '{' RecursiveListOfFExpr '}' '{' RecursiveListOfFExpr '}' '{' RecursiveListOfFExpr '}' '{' RecursiveListOfFExpr '}' '}' '{' FExpr ',' FExpr ',' FExpr '}' { PostSubOperation_S.SubType = PRINT_ONGRID_3D; if(List_Nbr($4) != 3 || List_Nbr($7) != 3 || List_Nbr($10) != 3 || List_Nbr($13) != 3) vyyerror("Expected {3}{3}{3}{3} coordinates, got {%d}{%d}{%d}{%d}", List_Nbr($4), List_Nbr($7), List_Nbr($10), List_Nbr($13)); else{ List_Read($4, 0, &PostSubOperation_S.Case.OnGrid.x[0]); List_Read($4, 1, &PostSubOperation_S.Case.OnGrid.y[0]); List_Read($4, 2, &PostSubOperation_S.Case.OnGrid.z[0]); List_Read($7, 0, &PostSubOperation_S.Case.OnGrid.x[1]); List_Read($7, 1, &PostSubOperation_S.Case.OnGrid.y[1]); List_Read($7, 2, &PostSubOperation_S.Case.OnGrid.z[1]); List_Read($10, 0, &PostSubOperation_S.Case.OnGrid.x[2]); List_Read($10, 1, &PostSubOperation_S.Case.OnGrid.y[2]); List_Read($10, 2, &PostSubOperation_S.Case.OnGrid.z[2]); List_Read($13, 0, &PostSubOperation_S.Case.OnGrid.x[3]); List_Read($13, 1, &PostSubOperation_S.Case.OnGrid.y[3]); List_Read($13, 2, &PostSubOperation_S.Case.OnGrid.z[3]); } PostSubOperation_S.Case.OnGrid.n[0] = (int)$17; PostSubOperation_S.Case.OnGrid.n[1] = (int)$19; PostSubOperation_S.Case.OnGrid.n[2] = (int)$21; List_Delete($4); List_Delete($7); List_Delete($10); List_Delete($13); } /* should be generalized with a '{' RecursiveListOfFExpr '}' */ | tOnRegion GroupRHS tWithArgument tSTRING '{' FExpr ',' FExpr '}' '{' FExpr '}' { PostSubOperation_S.SubType = PRINT_WITHARGUMENT; PostSubOperation_S.Case.WithArgument.RegionIndex = Num_Group(&Group_S, (char*)"PO_On", $2); int i; if((i = List_ISearchSeq(Problem_S.Expression, $4, fcmp_Expression_Name)) < 0) vyyerror("Unknown Name of Expression: %s", $4); Free($4); PostSubOperation_S.Case.WithArgument.ArgumentIndex = i; PostSubOperation_S.Case.WithArgument.x[0] = $6; PostSubOperation_S.Case.WithArgument.x[1] = $8; PostSubOperation_S.Case.WithArgument.n = (int)$11; } ; PrintOptions : /* none */ { PostSubOperation_S.FileOut = NULL; PostSubOperation_S.Depth = 1; PostSubOperation_S.Smoothing = 0; PostSubOperation_S.Skin = 0; PostSubOperation_S.Comma = 0; PostSubOperation_S.Dimension = _ALL; PostSubOperation_S.Adapt = 0; PostSubOperation_S.Target = -1.; PostSubOperation_S.HarmonicToTime = 1; PostSubOperation_S.FrozenTimeStepList = 0; PostSubOperation_S.TimeStep_L = List_Create(10,10,sizeof(int));; PostSubOperation_S.Frequency_L = List_Create(10,10,sizeof(double));; PostSubOperation_S.Value_L = List_Create(10,10,sizeof(double));; PostSubOperation_S.Iso = 0; PostSubOperation_S.Iso_L = List_Create(10,10,sizeof(double));; PostSubOperation_S.Sort = 0; PostSubOperation_S.NoNewLine = 0; PostSubOperation_S.NoTitle = 0; PostSubOperation_S.DecomposeInSimplex = 0; PostSubOperation_S.NewCoordinates = 0; PostSubOperation_S.NewCoordinatesFile = NULL; PostSubOperation_S.ChangeOfCoordinates[0] = -1; PostSubOperation_S.ChangeOfCoordinates[1] = -1; PostSubOperation_S.ChangeOfCoordinates[2] = -1; PostSubOperation_S.ChangeOfValues = NULL; PostSubOperation_S.Legend = LEGEND_NONE; PostSubOperation_S.LegendPosition[0] = 0.; PostSubOperation_S.LegendPosition[1] = 0.; PostSubOperation_S.LegendPosition[2] = 0.; PostSubOperation_S.EvaluationPoints = NULL; PostSubOperation_S.StoreInRegister = -1; PostSubOperation_S.StoreInField = -1; PostSubOperation_S.LastTimeStepOnly = 0; PostSubOperation_S.AppendTimeStepToFileName = 0; PostSubOperation_S.OverrideTimeStepValue = -1; PostSubOperation_S.NoMesh = 0; PostSubOperation_S.SendToServer = NULL; PostSubOperation_S.Color = NULL; PostSubOperation_S.ValueIndex = 0; PostSubOperation_S.ValueName = NULL; PostSubOperation_S.Label = NULL; } | PrintOptions PrintOption ; PrintOption : ',' tFile CharExpr { if(!PostOperation_S.AppendString){ PostSubOperation_S.FileOut = $3; } else{ PostSubOperation_S.FileOut = (char *)Malloc((strlen($3)+strlen(PostOperation_S.AppendString)+1)*sizeof(char)); strcpy(PostSubOperation_S.FileOut, $3); strcat(PostSubOperation_S.FileOut, PostOperation_S.AppendString); Free($3); } PostSubOperation_S.CatFile = 0; } | ',' tFile '>' CharExpr { if(!PostOperation_S.AppendString){ PostSubOperation_S.FileOut = $4; } else{ PostSubOperation_S.FileOut = (char *)Malloc((strlen($4)+strlen(PostOperation_S.AppendString)+1)*sizeof(char)); strcpy(PostSubOperation_S.FileOut, $4); strcat(PostSubOperation_S.FileOut, PostOperation_S.AppendString); Free($4); } PostSubOperation_S.CatFile = 1; } | ',' tFile tGREATERGREATER CharExpr { if(!PostOperation_S.AppendString){ PostSubOperation_S.FileOut = $4; } else{ PostSubOperation_S.FileOut = (char *)Malloc((strlen($4)+strlen(PostOperation_S.AppendString)+1)*sizeof(char)); strcpy(PostSubOperation_S.FileOut, $4); strcat(PostSubOperation_S.FileOut, PostOperation_S.AppendString); Free($4); } PostSubOperation_S.CatFile = 2; } | ',' tDepth FExpr { PostSubOperation_S.Depth = (int)$3; } | ',' tSkin { PostSubOperation_S.Skin = 1; } | ',' tSmoothing { PostSubOperation_S.Smoothing = 1; } | ',' tHarmonicToTime FExpr { PostSubOperation_S.HarmonicToTime = (int)$3; } | ',' tFormat tSTRING { PostSubOperation_S.Format = Get_DefineForString(PostSubOperation_Format, $3, &FlagError); if(FlagError){ vyyerror("Unknown PostProcessing Format: %s", $3); Get_Valid_SXD(PostSubOperation_Format); } Free($3); } | ',' tComma { PostSubOperation_S.Comma = 1; } | ',' tValueIndex FExpr { PostSubOperation_S.ValueIndex = $3; } | ',' tValueName CharExpr { PostSubOperation_S.ValueName = $3; } | ',' tName CharExpr { PostSubOperation_S.Label = $3; } | ',' tDimension FExpr { if((int)$3 >= 1 && (int)$3 <= 3) PostSubOperation_S.Dimension = (int)$3; else vyyerror("Wrong Dimension in Print"); } | ',' tTimeStep ListOfFExpr { PostSubOperation_S.FrozenTimeStepList = 1; for(int i = 0; i < List_Nbr($3); i++){ double d; List_Read($3,i,&d); int j = (int)d; List_Add(PostSubOperation_S.TimeStep_L, &j); } List_Delete($3); } | ',' tAdapt tSTRING { PostSubOperation_S.Adapt = Get_DefineForString(PostSubOperation_AdaptationType, $3, &FlagError); if(FlagError){ vyyerror("Unknown Adaptation method: %s", $3); Get_Valid_SXD(PostSubOperation_AdaptationType); } } | ',' tSort tSTRING { PostSubOperation_S.Sort = Get_DefineForString(PostSubOperation_SortType, $3, &FlagError); if(FlagError){ vyyerror("Unknown Sort method: %s", $3); Get_Valid_SXD(PostSubOperation_SortType); } } | ',' tTarget FExpr { if($3 >= 0.) PostSubOperation_S.Target = $3; else vyyerror("Bad Target value"); } | ',' tValue ListOfFExpr { for(int i = 0; i < List_Nbr($3); i++){ double d; List_Read($3,i,&d); List_Add(PostSubOperation_S.Value_L, &d); } List_Delete($3); } | ',' tIso FExpr { PostSubOperation_S.Iso = (int)$3; } | ',' tIso '{' RecursiveListOfFExpr '}' { PostSubOperation_S.Iso = -1; for(int i = 0; i < List_Nbr($4); i++){ double d; List_Read($4,i,&d); List_Add(PostSubOperation_S.Iso_L, &d); } List_Delete($4); } | ',' tNoNewLine { PostSubOperation_S.NoNewLine = 1; } | ',' tNoTitle { PostSubOperation_S.NoTitle = 1; } | ',' tDecomposeInSimplex { PostSubOperation_S.DecomposeInSimplex = 1; } | ',' tFrequency ListOfFExpr { for(int i = 0; i < List_Nbr($3); i++){ double d; List_Read($3,i,&d); List_Add(PostSubOperation_S.Frequency_L, &d); } List_Delete($3); } | ',' tChangeOfCoordinates '{' Expression ',' Expression ',' Expression '}' { PostSubOperation_S.ChangeOfCoordinates[0] = $4; PostSubOperation_S.ChangeOfCoordinates[1] = $6; PostSubOperation_S.ChangeOfCoordinates[2] = $8; } | ',' tChangeOfValues ListOfExpression { PostSubOperation_S.ChangeOfValues = List_Copy(ListOfInt_L); } | ',' tTimeLegend { PostSubOperation_S.Legend = LEGEND_TIME; PostSubOperation_S.LegendPosition[0] = 1.e5; PostSubOperation_S.LegendPosition[1] = 30.; /* (align<<16)|(font<<8)|(fontsize) */ PostSubOperation_S.LegendPosition[2] = 66574; } | ',' tTimeLegend '{' FExpr ',' FExpr ',' FExpr '}' { PostSubOperation_S.Legend = LEGEND_TIME; PostSubOperation_S.LegendPosition[0] = $4; PostSubOperation_S.LegendPosition[1] = $6; PostSubOperation_S.LegendPosition[2] = $8; } | ',' tFrequencyLegend { PostSubOperation_S.Legend = LEGEND_FREQUENCY; PostSubOperation_S.LegendPosition[0] = 1.e5; PostSubOperation_S.LegendPosition[1] = 30.; /* (align<<16)|(font<<8)|(fontsize) */ PostSubOperation_S.LegendPosition[2] = 66574; } | ',' tFrequencyLegend '{' FExpr ',' FExpr ',' FExpr '}' { PostSubOperation_S.Legend = LEGEND_FREQUENCY; PostSubOperation_S.LegendPosition[0] = $4; PostSubOperation_S.LegendPosition[1] = $6; PostSubOperation_S.LegendPosition[2] = $8; } | ',' tEigenvalueLegend { PostSubOperation_S.Legend = LEGEND_EIGENVALUES; PostSubOperation_S.LegendPosition[0] = 1.e5; PostSubOperation_S.LegendPosition[1] = 30.; /* (align<<16)|(font<<8)|(fontsize) */ PostSubOperation_S.LegendPosition[2] = 66574; } | ',' tEigenvalueLegend '{' FExpr ',' FExpr ',' FExpr '}' { PostSubOperation_S.Legend = LEGEND_EIGENVALUES; PostSubOperation_S.LegendPosition[0] = $4; PostSubOperation_S.LegendPosition[1] = $6; PostSubOperation_S.LegendPosition[2] = $8; } | ',' tEvaluationPoints '{' RecursiveListOfFExpr '}' { if(List_Nbr($4)%3 != 0) vyyerror("Expected 3n coordinates, got %d", List_Nbr($4)); else { PostSubOperation_S.EvaluationPoints = $4; } } | ',' tStoreInRegister tINT { PostSubOperation_S.StoreInRegister = $3 - 1; } | ',' tStoreInField FExpr { PostSubOperation_S.StoreInField = $3; } | ',' tLastTimeStepOnly { PostSubOperation_S.LastTimeStepOnly = 1; } | ',' tAppendTimeStepToFileName { PostSubOperation_S.AppendTimeStepToFileName = 1; } | ',' tAppendTimeStepToFileName FExpr { PostSubOperation_S.AppendTimeStepToFileName = $3; } | ',' tOverrideTimeStepValue FExpr { PostSubOperation_S.OverrideTimeStepValue = $3; } | ',' tNoMesh { PostSubOperation_S.NoMesh = 1; } | ',' tSendToServer CharExpr { PostSubOperation_S.SendToServer = $3; } | ',' tColor CharExpr { PostSubOperation_S.Color = $3; } | ',' tNewCoordinates CharExpr { PostSubOperation_S.NewCoordinates = 1; PostSubOperation_S.NewCoordinatesFile = $3; } ; /* ------------------------------------------------------------------------ */ /* L o o p */ /* ------------------------------------------------------------------------ */ Loop : tFor '(' FExpr tDOTS FExpr ')' { LoopControlVariablesTab[ImbricatedLoop][0] = $3; LoopControlVariablesTab[ImbricatedLoop][1] = $5; LoopControlVariablesTab[ImbricatedLoop][2] = 1.0; LoopControlVariablesNameTab[ImbricatedLoop] = (char*)""; fgetpos(getdp_yyin, &FposImbricatedLoopsTab[ImbricatedLoop]); LinenoImbricatedLoopsTab[ImbricatedLoop] = getdp_yylinenum; if($3 > $5) skipUntil("For", "EndFor"); else ImbricatedLoop++; if(ImbricatedLoop > MAX_RECUR_LOOPS-1){ vyyerror("Reached maximum number of imbricated loops"); ImbricatedLoop = MAX_RECUR_LOOPS-1; } } | tFor '(' FExpr tDOTS FExpr tDOTS FExpr ')' { LoopControlVariablesTab[ImbricatedLoop][0] = $3; LoopControlVariablesTab[ImbricatedLoop][1] = $5; LoopControlVariablesTab[ImbricatedLoop][2] = $7; LoopControlVariablesNameTab[ImbricatedLoop] = (char*)""; fgetpos(getdp_yyin, &FposImbricatedLoopsTab[ImbricatedLoop]); LinenoImbricatedLoopsTab[ImbricatedLoop] = getdp_yylinenum; if(($7 > 0. && $3 > $5) || ($7 < 0. && $3 < $5)) skipUntil("For", "EndFor"); else ImbricatedLoop++; if(ImbricatedLoop > MAX_RECUR_LOOPS-1){ vyyerror("Reached maximum number of imbricated loops"); ImbricatedLoop = MAX_RECUR_LOOPS-1; } } | tFor tSTRING tIn '{' FExpr tDOTS FExpr '}' { LoopControlVariablesTab[ImbricatedLoop][0] = $5; LoopControlVariablesTab[ImbricatedLoop][1] = $7; LoopControlVariablesTab[ImbricatedLoop][2] = 1.0; LoopControlVariablesNameTab[ImbricatedLoop] = $2; Constant_S.Name = $2; Constant_S.Type = VAR_FLOAT; Constant_S.Value.Float = $5; Tree_Replace(ConstantTable_L, &Constant_S); fgetpos(getdp_yyin, &FposImbricatedLoopsTab[ImbricatedLoop]); /* hack_fsetpos_printf(); */ LinenoImbricatedLoopsTab[ImbricatedLoop] = getdp_yylinenum; if($5 > $7) skipUntil("For", "EndFor"); else ImbricatedLoop++; if(ImbricatedLoop > MAX_RECUR_LOOPS-1){ vyyerror("Reached maximum number of imbricated loops"); ImbricatedLoop = MAX_RECUR_LOOPS-1; } } | tFor tSTRING tIn '{' FExpr tDOTS FExpr tDOTS FExpr '}' { LoopControlVariablesTab[ImbricatedLoop][0] = $5; LoopControlVariablesTab[ImbricatedLoop][1] = $7; LoopControlVariablesTab[ImbricatedLoop][2] = $9; LoopControlVariablesNameTab[ImbricatedLoop] = $2; Constant_S.Name = $2; Constant_S.Type = VAR_FLOAT; Constant_S.Value.Float = $5; Tree_Replace(ConstantTable_L, &Constant_S); fgetpos(getdp_yyin, &FposImbricatedLoopsTab[ImbricatedLoop]); LinenoImbricatedLoopsTab[ImbricatedLoop] = getdp_yylinenum; if(($9 > 0. && $5 > $7) || ($9 < 0. && $5 < $7)) skipUntil("For", "EndFor"); else ImbricatedLoop++; if(ImbricatedLoop > MAX_RECUR_LOOPS-1){ vyyerror("Reached maximum number of imbricated loops"); ImbricatedLoop = MAX_RECUR_LOOPS-1; } } | tEndFor { if(ImbricatedLoop <= 0){ vyyerror("Invalid For/EndFor loop"); ImbricatedLoop = 0; } else{ double x0 = LoopControlVariablesTab[ImbricatedLoop-1][0]; double x1 = LoopControlVariablesTab[ImbricatedLoop-1][1]; double step = LoopControlVariablesTab[ImbricatedLoop-1][2]; int do_next = (step > 0.) ? (x0+step <= x1) : (x0+step >= x1); if(do_next){ LoopControlVariablesTab[ImbricatedLoop-1][0] += LoopControlVariablesTab[ImbricatedLoop-1][2]; if(strlen(LoopControlVariablesNameTab[ImbricatedLoop-1])){ Constant_S.Name = LoopControlVariablesNameTab[ImbricatedLoop-1]; Constant_S.Type = VAR_FLOAT; Constant_S.Value.Float = LoopControlVariablesTab[ImbricatedLoop-1][0]; if(!Tree_Search(ConstantTable_L, &Constant_S)) vyyerror("Unknown For/EndFor loop control variable %s", Constant_S.Name); Tree_Replace(ConstantTable_L, &Constant_S); } fsetpos(getdp_yyin, &FposImbricatedLoopsTab[ImbricatedLoop-1]); /* fsetpos() seems to position the file just after the For but with one additional character (the one after EndFor) at the beginning. I do not understand why there is such a mixing of two separate data. hack_fsetpos() removes the useless additional character. */ hack_fsetpos(); /* hack_fsetpos_printf(); */ getdp_yylinenum = LinenoImbricatedLoopsTab[ImbricatedLoop-1]; } else{ ImbricatedLoop--; } } } | tIf '(' FExpr ')' { if(!$3) skipUntil("If", "EndIf"); } | tEndIf { } | Affectation ; /* ------------------------------------------------------------------------ */ /* C o n s t a n t E x p r e s s i o n s (FExpr) */ /* ------------------------------------------------------------------------ */ Affectation : tDefineConstant '[' DefineConstants ']' tEND | tUndefineConstant '[' UndefineConstants ']' tEND | String__Index tDEF ListOfFExpr tEND { Constant_S.Name = $1; if(List_Nbr($3) == 1){ Constant_S.Type = VAR_FLOAT; List_Read($3, 0, &Constant_S.Value.Float); List_Delete($3); } else{ Constant_S.Type = VAR_LISTOFFLOAT; Constant_S.Value.ListOfFloat = $3; } Tree_Replace(ConstantTable_L, &Constant_S); } | String__Index '(' RecursiveListOfFExpr ')' tDEF ListOfFExpr tEND { Constant_S.Name = $1; Constant *c = (Constant*)Tree_PQuery(ConstantTable_L, &Constant_S); if(c && (c->Type == VAR_LISTOFFLOAT)){ if(List_Nbr($3) == List_Nbr($6)){ for(int i = 0; i < List_Nbr($3); i++){ double d; List_Read($3, i, &d); int idx = (int)d; if(idx >= 0 && idx < List_Nbr(c->Value.ListOfFloat)){ double *pd = (double*)List_Pointer(c->Value.ListOfFloat, idx); double d2 = *(double*)List_Pointer($6, i); *pd = d2; } else vyyerror("Index %d out of range", idx); } } else vyyerror("Bad list sizes for affectation %d != %d", List_Nbr($3), List_Nbr($6)); } else vyyerror("Unknown list Constant: %s", $1); List_Delete($3); List_Delete($6); } | String__Index '+' tDEF ListOfFExpr tEND { Constant_S.Name = $1; Constant *c = (Constant*)Tree_PQuery(ConstantTable_L, &Constant_S); if(c){ if(c->Type == VAR_FLOAT && List_Nbr($4) == 1){ double d; List_Read($4, 0, &d); c->Value.Float += d; } else if(c->Type == VAR_LISTOFFLOAT){ for(int i = 0; i < List_Nbr($4); i++) List_Add(c->Value.ListOfFloat, List_Pointer($4, i)); } else vyyerror("Cannot append list to float"); } else vyyerror("Unknown Constant: %s", $1); List_Delete($4); } | String__Index '-' tDEF ListOfFExpr tEND { Constant_S.Name = $1; Constant *c = (Constant*)Tree_PQuery(ConstantTable_L, &Constant_S); if(c){ if(c->Type == VAR_FLOAT && List_Nbr($4) == 1){ double d; List_Read($4, 0, &d); c->Value.Float -= d; } else if(c->Type == VAR_LISTOFFLOAT){ std::vector tmp; for(int i = 0; i < List_Nbr(c->Value.ListOfFloat); i++){ double d; List_Read(c->Value.ListOfFloat, i, &d); tmp.push_back(d); } for(int i = 0; i < List_Nbr($4); i++){ double d; List_Read($4, i, &d); std::vector::iterator it = std::find(tmp.begin(), tmp.end(), d); if(it != tmp.end()) tmp.erase(it); } List_Reset(c->Value.ListOfFloat); for(unsigned int i = 0; i < tmp.size(); i++) List_Add(c->Value.ListOfFloat, &tmp[i]); } else vyyerror("Cannot erase list from float"); } else vyyerror("Unknown Constant: %s", $1); List_Delete($4); } | String__Index tDEF tBIGSTR tEND { Constant_S.Name = $1; Constant_S.Type = VAR_CHAR; Constant_S.Value.Char = $3; Tree_Replace(ConstantTable_L, &Constant_S); } | String__Index tDEF tStr '[' CharExpr ']' tEND { Constant_S.Name = $1; Constant_S.Type = VAR_CHAR; Constant_S.Value.Char = $5; Tree_Replace(ConstantTable_L, &Constant_S); } | String__Index tDEF tStr '(' CharExpr ')' tEND { Constant_S.Name = $1; Constant_S.Type = VAR_CHAR; Constant_S.Value.Char = $5; Tree_Replace(ConstantTable_L, &Constant_S); } | String__Index tDEF StrCat tEND { Constant_S.Name = $1; Constant_S.Type = VAR_CHAR; Constant_S.Value.Char = $3; Tree_Replace(ConstantTable_L, &Constant_S); } | String__Index tDEF tListFromFile '[' CharExpr ']' tEND { Constant_S.Name = $1; Constant_S.Type = VAR_LISTOFFLOAT; Message::Barrier(); FILE *File; if(!(File = FOpen($5, "r"))){ Message::Warning("Could not open file '%s'", $5); Constant_S.Value.ListOfFloat = NULL; } else{ Constant_S.Value.ListOfFloat = List_Create(100,100,sizeof(double)); double d; while(!feof(File)) if(fscanf(File, "%lf", &d) != EOF) List_Add(Constant_S.Value.ListOfFloat, &d); fclose(File); } Tree_Replace(ConstantTable_L, &Constant_S); } // deprectated | tPrintf '(' tBIGSTR ')' tEND { Message::Direct($3); } | tPrintf '[' tBIGSTR ']' tEND { Message::Direct($3); } | tPrintf String__Index tEND { Constant_S.Name = $2; if(!Tree_Query(ConstantTable_L, &Constant_S)) vyyerror("Unknown Constant: %s", $2); else if(Constant_S.Type != VAR_LISTOFFLOAT) Message::Direct("%s: %g", $2, Constant_S.Value.Float); else Message::Direct("%s: Dimension %d", $2, List_Nbr(Constant_S.Value.ListOfFloat)); for(int i = 0; i < List_Nbr(Constant_S.Value.ListOfFloat); i++) { double d; List_Read(Constant_S.Value.ListOfFloat, i, &d); Message::Direct(" (%d) %g", i, d); } } | tPrintf '#' tEND { Message::Direct("Line number: %d", getdp_yylinenum); } // deprectated | tPrintf '(' tBIGSTR ',' RecursiveListOfFExpr ')' tEND { char tmpstr[256]; int i = Print_ListOfDouble($3, $5, tmpstr); if(i < 0) vyyerror("Too few arguments in Printf"); else if(i > 0) vyyerror("Too many arguments (%d) in Printf", i); else Message::Direct(tmpstr); List_Delete($5); } | tPrintf '[' tBIGSTR ',' RecursiveListOfFExpr ']' tEND { char tmpstr[256]; int i = Print_ListOfDouble($3, $5, tmpstr); if(i < 0) vyyerror("Too few arguments in Printf"); else if(i > 0) vyyerror("Too many arguments (%d) in Printf", i); else Message::Direct(tmpstr); List_Delete($5); } // deprectated | tRead '(' String__Index ')' tEND { Message::Info("? "); char tmpstr[256]; fgets(tmpstr, sizeof(tmpstr), stdin); Constant_S.Value.Float = atof(tmpstr); Constant_S.Name = $3; Constant_S.Type = VAR_FLOAT; Tree_Replace(ConstantTable_L, &Constant_S); } | tRead '[' String__Index ']' tEND { Message::Info("? "); char tmpstr[256]; fgets(tmpstr, sizeof(tmpstr), stdin); Constant_S.Value.Float = atof(tmpstr); Constant_S.Name = $3; Constant_S.Type = VAR_FLOAT; Tree_Replace(ConstantTable_L, &Constant_S); } // deprectated | tRead '(' String__Index ')' '[' FExpr ']' tEND { Message::Info("[=%g] ? ",$6); char tmpstr[256]; fgets(tmpstr, sizeof(tmpstr), stdin); if(!strcmp(tmpstr,"\n")) Constant_S.Value.Float = $6; else Constant_S.Value.Float = atof(tmpstr); Constant_S.Name = $3; Constant_S.Type = VAR_FLOAT; Tree_Replace(ConstantTable_L, &Constant_S); } | tRead '[' String__Index ',' FExpr '}' tEND { Message::Info("[=%g] ? ",$5); char tmpstr[256]; fgets(tmpstr, sizeof(tmpstr), stdin); if(!strcmp(tmpstr,"\n")) Constant_S.Value.Float = $5; else Constant_S.Value.Float = atof(tmpstr); Constant_S.Name = $3; Constant_S.Type = VAR_FLOAT; Tree_Replace(ConstantTable_L, &Constant_S); } | tPrintConstants tEND { Print_Constants(); } ; Enumeration : FExpr tDEF CharExpr { $$ = List_Create(20,20,sizeof(doubleXstring)); doubleXstring v = {$1, $3}; List_Add($$, &v); } | Enumeration ',' FExpr tDEF CharExpr { doubleXstring v = {$3, $5}; List_Add($$, &v); } ; FloatParameterOptions : | FloatParameterOptions FloatParameterOption ; FloatParameterOption : ',' tSTRING ListOfFExpr { std::string key($2); for(int i = 0; i < List_Nbr($3); i++){ double v; List_Read($3, i, &v); FloatOptions_S[key].push_back(v); } Free($2); List_Delete($3); } | ',' tSTRING '{' Enumeration '}' { std::string key($2); for(int i = 0; i < List_Nbr($4); i++){ doubleXstring v; List_Read($4, i, &v); FloatOptions_S[key].push_back(v.d); CharOptions_S[key].push_back(v.s); } Free($2); for(int i = 0; i < List_Nbr($4); i++) Free(((doubleXstring*)List_Pointer($4, i))->s); List_Delete($4); } | ',' tSTRING CharExprNoVar { std::string key($2); std::string val($3); CharOptions_S[key].push_back(val); Free($2); Free($3); } ; CharParameterOptions : | CharParameterOptions CharParameterOption ; CharParameterOption : ',' tSTRING FExpr { std::string key($2); double val = $3; FloatOptions_S[key].push_back(val); Free($2); } | ',' tSTRING CharExprNoVar { std::string key($2); std::string val($3); CharOptions_S[key].push_back(val); Free($2); Free($3); } | ',' tSTRING '{' RecursiveListOfCharExpr '}' { std::string key($2); for(int i = 0; i < List_Nbr($4); i++){ char *s; List_Read($4, i, &s); std::string val(s); Free(s); CharOptions_S[key].push_back(val); } Free($2); List_Delete($4); } ; DefineConstants : /* none */ | DefineConstants Comma String__Index { Constant_S.Name = $3; Constant_S.Type = VAR_FLOAT; Constant_S.Value.Float = 0.; FloatOptions_S.clear(); CharOptions_S.clear(); if(!Tree_Search(ConstantTable_L, &Constant_S)){ Tree_Replace(ConstantTable_L, &Constant_S); } } | DefineConstants Comma String__Index '{' FExpr '}' { Constant_S.Type = VAR_FLOAT ; Constant_S.Value.Float = 0. ; FloatOptions_S.clear(); CharOptions_S.clear(); for (int k = 0 ; k < (int)$5 ; k++) { char tmpstr[256]; sprintf(tmpstr, "%s_%d", $3, k+1) ; Constant_S.Name = tmpstr ; if (!Tree_Search(ConstantTable_L, &Constant_S)) { Constant_S.Name = strSave(tmpstr); Tree_Replace(ConstantTable_L, &Constant_S) ; } } Free($3) ; } | DefineConstants Comma String__Index tDEF FExpr { Constant_S.Name = $3; Constant_S.Type = VAR_FLOAT; Constant_S.Value.Float = $5; FloatOptions_S.clear(); CharOptions_S.clear(); if(!Tree_Search(ConstantTable_L, &Constant_S)){ Message::ExchangeOnelabParameter(&Constant_S, FloatOptions_S, CharOptions_S); Tree_Replace(ConstantTable_L, &Constant_S); } } | DefineConstants Comma String__Index tDEF '{' FExpr { FloatOptions_S.clear(); CharOptions_S.clear(); } FloatParameterOptions '}' { Constant_S.Name = $3; Constant_S.Type = VAR_FLOAT; Constant_S.Value.Float = $6; if(!Tree_Search(ConstantTable_L, &Constant_S)){ Message::ExchangeOnelabParameter(&Constant_S, FloatOptions_S, CharOptions_S); Tree_Replace(ConstantTable_L, &Constant_S); } } | DefineConstants Comma String__Index tDEF tBIGSTR { Constant_S.Name = $3; Constant_S.Type = VAR_CHAR; Constant_S.Value.Char = $5; FloatOptions_S.clear(); CharOptions_S.clear(); if(!Tree_Search(ConstantTable_L, &Constant_S)){ Message::ExchangeOnelabParameter(&Constant_S, FloatOptions_S, CharOptions_S); Tree_Replace(ConstantTable_L, &Constant_S); } } | DefineConstants Comma String__Index tDEF '{' tBIGSTR { FloatOptions_S.clear(); CharOptions_S.clear(); } CharParameterOptions '}' { Constant_S.Name = $3; Constant_S.Type = VAR_CHAR; Constant_S.Value.Char = $6; if(!Tree_Search(ConstantTable_L, &Constant_S)){ Message::ExchangeOnelabParameter(&Constant_S, FloatOptions_S, CharOptions_S); Tree_Replace(ConstantTable_L, &Constant_S); } } ; UndefineConstants : /* none */ | UndefineConstants Comma CharExprNoVar { // undefine the onelab parameter std::string name($3); Message::UndefineOnelabParameter(name); Free($3); } | UndefineConstants Comma String__Index { // undefine the onelab parameter and the getdp constant std::string name($3); Message::UndefineOnelabParameter(name); Constant_S.Name = $3; Tree_Suppress(ConstantTable_L, &Constant_S); Free($3); } /* Ce bricolage affreux (?) est necessaire pour permettre la meme syntaxe dans les expressions constantes et dans les whole_expressions */ NameForMathFunction : tExp { $$ = (char*)"Exp"; } | tLog { $$ = (char*)"Log"; } | tLog10 { $$ = (char*)"Log10"; } | tSqrt { $$ = (char*)"Sqrt"; } | tSin { $$ = (char*)"Sin"; } | tAsin { $$ = (char*)"Asin"; } | tCos { $$ = (char*)"Cos"; } | tAcos { $$ = (char*)"Acos"; } | tTan { $$ = (char*)"Tan"; } | tAtan { $$ = (char*)"Atan"; } | tAtan2 { $$ = (char*)"Atan2"; } | tSinh { $$ = (char*)"Sinh"; } | tCosh { $$ = (char*)"Cosh"; } | tTanh { $$ = (char*)"Tanh"; } | tFabs { $$ = (char*)"Fabs"; } | tFloor { $$ = (char*)"Floor"; } | tCeil { $$ = (char*)"Ceil"; } | tRound { $$ = (char*)"Round"; } | tSign { $$ = (char*)"Sign"; } | tFmod { $$ = (char*)"Fmod"; } | tModulo { $$ = (char*)"Modulo"; } | tHypot { $$ = (char*)"Hypot"; } | tRand { $$ = (char*)"Rand"; } ; NameForFunction : NameForMathFunction { $$ = $1; } | String__Index { $$ = $1; } ; FExpr : OneFExpr { $$ = $1; } | '(' FExpr ')' { $$ = $2; } | '-' FExpr %prec UNARYPREC { $$ = -$2; } | '!' FExpr { $$ = !$2; } | FExpr '-' FExpr { $$ = $1 - $3; } | FExpr '+' FExpr { $$ = $1 + $3; } | FExpr '*' FExpr { $$ = $1 * $3; } | FExpr '|' FExpr { $$ = (int)$1 | (int)$3; } | FExpr '&' FExpr { $$ = (int)$1 & (int)$3; } | FExpr '/' FExpr { $$ = $1 / $3; } | FExpr '%' FExpr { $$ = (int)$1 % (int)$3; } | FExpr '^' FExpr { $$ = pow($1,$3); } | FExpr '<' FExpr { $$ = $1 < $3; } | FExpr '>' FExpr { $$ = $1 > $3; } | FExpr tLESSOREQUAL FExpr { $$ = $1 <= $3; } | FExpr tGREATEROREQUAL FExpr { $$ = $1 >= $3; } | FExpr tEQUAL FExpr { $$ = $1 == $3; } | FExpr tNOTEQUAL FExpr { $$ = $1 != $3; } | FExpr tAND FExpr { $$ = $1 && $3; } | FExpr tOR FExpr { $$ = $1 || $3; } | tExp '[' FExpr ']' { $$ = exp($3); } | tLog '[' FExpr ']' { $$ = log($3); } | tLog10 '[' FExpr ']' { $$ = log10($3); } | tSqrt '[' FExpr ']' { $$ = sqrt($3); } | tSin '[' FExpr ']' { $$ = sin($3); } | tAsin '[' FExpr ']' { $$ = asin($3); } | tCos '[' FExpr ']' { $$ = cos($3); } | tAcos '[' FExpr ']' { $$ = acos($3); } | tTan '[' FExpr ']' { $$ = tan($3); } | tAtan '[' FExpr ']' { $$ = atan($3); } | tAtan2 '[' FExpr ',' FExpr ']' { $$ = atan2($3,$5); } | tSinh '[' FExpr ']' { $$ = sinh($3); } | tCosh '[' FExpr ']' { $$ = cosh($3); } | tTanh '[' FExpr ']' { $$ = tanh($3); } | tFabs '[' FExpr ']' { $$ = fabs($3); } | tFloor '[' FExpr ']' { $$ = floor($3); } | tCeil '[' FExpr ']' { $$ = ceil($3); } | tRound '[' FExpr ']' { $$ = floor($3 + 0.5); } | tSign '[' FExpr ']' { $$ = (($3 > 0.) ? 1. : ($3 < 0.) ? -1. : 0.); } | tFmod '[' FExpr ',' FExpr ']' { $$ = fmod($3,$5); } | tModulo '[' FExpr ',' FExpr ']' { $$ = fmod($3,$5); } | tHypot '[' FExpr ',' FExpr ']' { $$ = sqrt($3*$3+$5*$5); } | tRand '[' FExpr ']' { $$ = $3 * (double)rand() / (double)RAND_MAX; } | FExpr '?' FExpr tDOTS FExpr { $$ = $1? $3 : $5; } | StrCmp { $$ = $1; } | NbrRegions { $$ = $1; } | FExpr '#' { Message::Direct("Value (line %ld) --> %.16g", getdp_yylinenum, $1); } ; OneFExpr : tFLOAT { $$ = $1; } | tINT { $$ = (double)$1; } | tPi { $$ = 3.1415926535897932; } | t0D { $$ = (double)_0D; } | t1D { $$ = (double)_1D; } | t2D { $$ = (double)_2D; } | t3D { $$ = (double)_3D; } | tMPI_Rank { $$ = Message::GetCommRank(); } | tMPI_Size { $$ = Message::GetCommSize(); } | String__Index { Constant_S.Name = $1; if(!Tree_Query(ConstantTable_L, &Constant_S)) { vyyerror("Unknown Constant: %s", $1); $$ = 0.; } else { if(Constant_S.Type == VAR_FLOAT) $$ = Constant_S.Value.Float; else { vyyerror("Single value Constant needed: %s", $1); $$ = 0.; } } Free($1); } | '#' tSTRING '(' ')' { Constant_S.Name = $2; int ret = 0; if(!Tree_Query(ConstantTable_L, &Constant_S)) vyyerror("Unknown Constant: %s", $2); else{ if(Constant_S.Type != VAR_LISTOFFLOAT) vyyerror("Multi value Constant needed: %s", $2); else ret = List_Nbr(Constant_S.Value.ListOfFloat); } $$ = ret; Free($2); } | tSTRING '(' FExpr ')' { Constant_S.Name = $1; double ret = 0.; if(!Tree_Query(ConstantTable_L, &Constant_S)) vyyerror("Unknown Constant: %s", $1); else{ if(Constant_S.Type != VAR_LISTOFFLOAT) vyyerror("Multi value Constant needed: %s", $1); else{ int j = (int)$3; if(j >= 0 && j < List_Nbr(Constant_S.Value.ListOfFloat)) List_Read(Constant_S.Value.ListOfFloat, j, &ret); else vyyerror("Index %d out of range", j); } } $$ = ret; Free($1); } ; ListOfFExpr : /* none */ { $$ = NULL; } | '{' '}' { $$ = List_Create(1,1,sizeof(double)); } | FExpr { $$ = List_Create(1,1,sizeof(double)); List_Add($$, &($1)); } | MultiFExpr { $$ = $1; } | '{' RecursiveListOfFExpr '}' { $$ = $2; } ; RecursiveListOfFExpr : FExpr { $$ = List_Create(20,20,sizeof(double)); List_Add($$, &($1)); } | MultiFExpr { $$ = $1; } | RecursiveListOfFExpr ',' FExpr { List_Add($$, &($3)); } | RecursiveListOfFExpr ',' MultiFExpr { for(int i = 0; i < List_Nbr($3); i++){ double d; List_Read($3, i, &d); List_Add($$, &d); } List_Delete($3); } ; RecursiveListOfListOfFExpr : ListOfFExpr { $$ = List_Create(2, 1, sizeof(List_T*)); List_Add($$, &($1)); } | RecursiveListOfListOfFExpr ',' ListOfFExpr { List_Add($$, &($3)); } ; MultiFExpr : '-' MultiFExpr %prec UNARYPREC { $$ = $2; for(int i = 0; i < List_Nbr($$); i++){ double *pd = (double*)List_Pointer($$, i); *pd *= -1.0; } } | FExpr '*' MultiFExpr { $$ = $3; for(int i = 0; i < List_Nbr($$); i++){ double *pd = (double*)List_Pointer($$, i); *pd *= $1; } } | MultiFExpr '*' FExpr { $$ = $1; for(int i = 0; i < List_Nbr($$); i++){ double *pd = (double*)List_Pointer($$, i); *pd *= $3; } } | FExpr '/' MultiFExpr { $$ = $3; for(int i = 0; i < List_Nbr($$); i++){ double *pd = (double*)List_Pointer($$, i); if(*pd) *pd = $1 / *pd; } } | MultiFExpr '/' FExpr { $$ = $1; for(int i = 0; i < List_Nbr($$); i++){ double *pd = (double*)List_Pointer($$, i); if($3) *pd /= $3; } } | MultiFExpr '^' FExpr { $$ = $1; for(int i = 0; i < List_Nbr($$); i++){ double *pd = (double*)List_Pointer($$, i); *pd = pow(*pd, $3); } } | MultiFExpr '+' MultiFExpr { $$ = $1; if(List_Nbr($$) == List_Nbr($3)){ for(int i = 0; i < List_Nbr($$); i++){ double *pd = (double*)List_Pointer($$, i); double d = *(double*)List_Pointer($3, i); *pd += d; } } else vyyerror("Wrong list sizes %d != %d", List_Nbr($$), List_Nbr($3)); List_Delete($3); } | MultiFExpr '-' MultiFExpr { $$ = $1; if(List_Nbr($$) == List_Nbr($3)){ for(int i = 0; i < List_Nbr($$); i++){ double *pd = (double*)List_Pointer($$, i); double d = *(double*)List_Pointer($3, i); *pd -= d; } } else vyyerror("Wrong list sizes %d != %d", List_Nbr($$), List_Nbr($3)); List_Delete($3); } | MultiFExpr '*' MultiFExpr { $$ = $1; if(List_Nbr($$) == List_Nbr($3)){ for(int i = 0; i < List_Nbr($$); i++){ double *pd = (double*)List_Pointer($$, i); double d = *(double*)List_Pointer($3, i); *pd *= d; } } else vyyerror("Wrong list sizes %d != %d", List_Nbr($$), List_Nbr($3)); List_Delete($3); } | MultiFExpr '/' MultiFExpr { $$ = $1; if(List_Nbr($$) == List_Nbr($3)){ for(int i = 0; i < List_Nbr($$); i++){ double *pd = (double*)List_Pointer($$, i); double d = *(double*)List_Pointer($3, i); if(d) *pd /= d; } } else vyyerror("Wrong list sizes %d != %d", List_Nbr($$), List_Nbr($3)); List_Delete($3); } | FExpr tDOTS FExpr { $$ = List_Create(20,20,sizeof(double)); for(double d = $1; ($1 < $3) ? (d <= $3) : (d >= $3); ($1 < $3) ? (d += 1.) : (d -= 1.)) List_Add($$, &d); } | FExpr tDOTS FExpr tDOTS FExpr { $$ = List_Create(20,20,sizeof(double)); if(!$5 || ($1<$3 && $5<0) || ($1>$3 && $5>0)){ vyyerror("Wrong increment in '%g : %g : %g'", $1, $3, $5); List_Add($$, &($1)); } else for(double d = $1; ($5 > 0) ? (d <= $3) : (d >= $3); d += $5) List_Add($$, &d); } | tSTRING '(' ')' { $$ = List_Create(20,20,sizeof(double)); Constant_S.Name = $1; if(!Tree_Query(ConstantTable_L, &Constant_S)) vyyerror("Unknown Constant: %s", $1); else if(Constant_S.Type != VAR_LISTOFFLOAT) /* vyyerror("Multi value Constant needed: %s", $1); */ List_Add($$, &Constant_S.Value.Float); else for(int i = 0; i < List_Nbr(Constant_S.Value.ListOfFloat); i++) { double d; List_Read(Constant_S.Value.ListOfFloat, i, &d); List_Add($$, &d); } } // deprecated | tSTRING '{' '}' { $$ = List_Create(20,20,sizeof(double)); Constant_S.Name = $1; if(!Tree_Query(ConstantTable_L, &Constant_S)) vyyerror("Unknown Constant: %s", $1); else if(Constant_S.Type != VAR_LISTOFFLOAT) /* vyyerror("Multi value Constant needed: %s", $1); */ List_Add($$, &Constant_S.Value.Float); else for(int i = 0; i < List_Nbr(Constant_S.Value.ListOfFloat); i++) { double d; List_Read(Constant_S.Value.ListOfFloat, i, &d); List_Add($$, &d); } } | tSTRING '(' '{' RecursiveListOfFExpr '}' ')' { $$ = List_Create(20,20,sizeof(double)); Constant_S.Name = $1; if(!Tree_Query(ConstantTable_L, &Constant_S)) vyyerror("Unknown Constant: %s", $1); else if(Constant_S.Type != VAR_LISTOFFLOAT) vyyerror("Multi value Constant needed: %s", $1); else for(int i = 0; i < List_Nbr($4); i++) { int j = (int)(*(double*)List_Pointer($4, i)); if(j >= 0 && j < List_Nbr(Constant_S.Value.ListOfFloat)){ double d; List_Read(Constant_S.Value.ListOfFloat, j, &d); List_Add($$, &d); } else{ vyyerror("Index %d out of range", j); double d = 0.; List_Add($$, &d); } } Free($4); } // same as tSTRING '(' ')' | tList '[' tSTRING ']' { $$ = List_Create(20,20,sizeof(double)); Constant_S.Name = $3; if(!Tree_Query(ConstantTable_L, &Constant_S)) vyyerror("Unknown Constant: %s", $3); else if(Constant_S.Type != VAR_LISTOFFLOAT) vyyerror("Multi value Constant needed: %s", $3); else for(int i = 0; i < List_Nbr(Constant_S.Value.ListOfFloat); i++) { double d; List_Read(Constant_S.Value.ListOfFloat, i, &d); List_Add($$, &d); } } | tListAlt '[' tSTRING ',' tSTRING ']' { $$ = List_Create(20,20,sizeof(double)); Constant1_S.Name = $3; Constant2_S.Name = $5; if(!Tree_Query(ConstantTable_L, &Constant1_S)) { vyyerror("Unknown Constant: %s", $3); } else if(Constant1_S.Type != VAR_LISTOFFLOAT) { vyyerror("Multi value Constant needed: %s", $3); } else { if(!Tree_Query(ConstantTable_L, &Constant2_S)) { vyyerror("Unknown Constant: %s", $5); } else if(Constant2_S.Type != VAR_LISTOFFLOAT) { vyyerror("Multi value Constant needed: %s", $5); } else { if(List_Nbr(Constant1_S.Value.ListOfFloat) != List_Nbr(Constant2_S.Value.ListOfFloat)) { vyyerror("Different dimensions of Multi value Constants: " "%s {%d}, %s {%d}", $3, List_Nbr(Constant1_S.Value.ListOfFloat), $5, List_Nbr(Constant2_S.Value.ListOfFloat)); } else { for(int i = 0; i < List_Nbr(Constant1_S.Value.ListOfFloat); i++) { double d; List_Read(Constant1_S.Value.ListOfFloat, i, &d); List_Add($$, &d); List_Read(Constant2_S.Value.ListOfFloat, i, &d); List_Add($$, &d); } } } } } | tLinSpace '[' FExpr ',' FExpr ',' FExpr ']' { $$ = List_Create(20,20,sizeof(double)); for(int i = 0; i < (int)$7; i++) { double d = $3 + ($5-$3)*(double)i/($7-1); List_Add($$, &d); } } | tLogSpace '[' FExpr ',' FExpr ',' FExpr ']' { $$ = List_Create(20,20,sizeof(double)); for(int i = 0; i < (int)$7; i++) { double d = pow(10,$3 + ($5-$3)*(double)i/($7-1)); List_Add($$, &d); } } ; StringIndex : tSTRING '~' '{' FExpr '}' { char tmpstr[256]; sprintf(tmpstr, "_%d", (int)$4); $$ = (char *)Malloc((strlen($1)+strlen(tmpstr)+1)*sizeof(char)); strcpy($$, $1); strcat($$, tmpstr); Free($1); } | StringIndex '~' '{' FExpr '}' { char tmpstr[256]; sprintf(tmpstr, "_%d", (int)$4); $$ = (char *)Malloc((strlen($1)+strlen(tmpstr)+1)*sizeof(char)) ; strcpy($$, $1) ; strcat($$, tmpstr) ; Free($1); } ; String__Index : tSTRING { $$ = $1; } | StringIndex { $$ = $1; } ; RecursiveListOfString__Index : String__Index { $$ = List_Create(20,20,sizeof(char*)); List_Add($$, &($1)); } | RecursiveListOfString__Index ',' String__Index { List_Add($$, &($3)); } ; CharExprNoVar : tBIGSTR { $$ = $1; } | StrCat { $$ = $1; } | tStr '[' RecursiveListOfCharExpr ']' { int size = 0; for(int i = 0; i < List_Nbr($3); i++) size += strlen(*(char**)List_Pointer($3, i)) + 1; $$ = (char*)Malloc(size * sizeof(char)); $$[0] = '\0'; for(int i = 0; i < List_Nbr($3); i++){ char *s; List_Read($3, i, &s); strcat($$, s); //Free(s);//FIXME if(i != List_Nbr($3) - 1) strcat($$, "\n"); } List_Delete($3); } // deprecated | tSprintf '(' CharExpr ')' { $$ = $3; } | tSprintf '[' CharExpr ']' { $$ = $3; } // deprecated | tSprintf '(' CharExpr ',' RecursiveListOfFExpr ')' { char tmpstr[256]; int i = Print_ListOfDouble($3,$5,tmpstr); if(i<0){ vyyerror("Too few arguments in Sprintf"); $$ = $3; } else if(i>0){ vyyerror("Too many arguments (%d) in Sprintf", i); $$ = $3; } else{ $$ = (char*)Malloc((strlen(tmpstr)+1)*sizeof(char)); strcpy($$, tmpstr); Free($3); } List_Delete($5); } | tSprintf '[' CharExpr ',' RecursiveListOfFExpr ']' { char tmpstr[256]; int i = Print_ListOfDouble($3,$5,tmpstr); if(i<0){ vyyerror("Too few arguments in Sprintf"); $$ = $3; } else if(i>0){ vyyerror("Too many arguments (%d) in Sprintf", i); $$ = $3; } else{ $$ = (char*)Malloc((strlen(tmpstr)+1)*sizeof(char)); strcpy($$, tmpstr); Free($3); } List_Delete($5); } | tDate { time_t date_info; time(&date_info); $$ = (char *)Malloc((strlen(ctime(&date_info))+1)*sizeof(char)); strcpy($$, ctime(&date_info)); $$[strlen($$)-1] = 0; } ; CharExpr : CharExprNoVar { $$ = $1; } | String__Index { Constant_S.Name = $1; if(!Tree_Query(ConstantTable_L, &Constant_S)) { vyyerror("Unknown Constant: %s", $1); $$ = NULL; } else { if(Constant_S.Type == VAR_CHAR) $$ = Constant_S.Value.Char; else { vyyerror("String Constant needed: %s", $1); $$ = NULL; } } Free($1); } ; RecursiveListOfCharExpr : CharExpr { $$ = List_Create(20,20,sizeof(char*)); List_Add($$, &($1)); } | RecursiveListOfCharExpr ',' CharExpr { List_Add($$, &($3)); } ; StrCat : tStrCat '[' CharExpr ',' CharExpr ']' { if($3 != NULL && $5 != NULL) { $$ = (char *)Malloc((strlen($3)+strlen($5)+1)*sizeof(char)); strcpy($$, $3); strcat($$, $5); } else { vyyerror("Undefined argument for StrCat function"); $$ = NULL; } } | tStrCat '(' CharExpr ',' CharExpr ')' { if($3 != NULL && $5 != NULL) { $$ = (char *)Malloc((strlen($3)+strlen($5)+1)*sizeof(char)); strcpy($$, $3); strcat($$, $5); } else { vyyerror("Undefined argument for StrCat function"); $$ = NULL; } } ; StrCmp : tStrCmp '[' CharExpr ',' CharExpr ']' { if ($3 != NULL && $5 != NULL) { $$ = strcmp($3, $5); } else { vyyerror("Undefined argument for StrCmp function") ; $$ = 1 ; } } ; NbrRegions : tNbrRegions '[' String__Index ']' { int i; if ( (i = List_ISearchSeq(Problem_S.Group, $3, fcmp_Group_Name)) >= 0 ) { $$ = List_Nbr(((struct Group *)List_Pointer(Problem_S.Group, i)) ->InitialList) ; } else { vyyerror("Unknown Group: %s", $3) ; $$ = 0 ; } } ; %% // This is a hack... Bison redefines 'const' if !__cplusplus and !__STDC__ #ifdef const #undef const #endif void Alloc_ParserVariables() { if(!ConstantTable_L) { ConstantTable_L = Tree_Create(sizeof(struct Constant), fcmp_Constant); for(std::map::iterator it = CommandLineNumbers.begin(); it != CommandLineNumbers.end(); it++){ Message::Info("Adding number %s = %g", it->first.c_str(), it->second); Constant_S.Name = strdup(it->first.c_str()); Constant_S.Type = VAR_FLOAT; Constant_S.Value.Float = it->second; Tree_Add(ConstantTable_L, &Constant_S); } for(std::map::iterator it = CommandLineStrings.begin(); it != CommandLineStrings.end(); it++){ Message::Info("Adding string %s = \"%s\"", it->first.c_str(), it->second.c_str()); Constant_S.Name = strdup(it->first.c_str()); Constant_S.Type = VAR_CHAR; Constant_S.Value.Char = strdup(it->second.c_str()); Tree_Add(ConstantTable_L, &Constant_S); } ListOfInt_L = List_Create(20, 10, sizeof(int)); ListOfPointer_L = List_Create(10, 10, sizeof(void *)); ListOfPointer2_L= List_Create(10, 10, sizeof(void *)); ListOfChar_L = List_Create(128, 128, sizeof(char)); ListOfFormulation = List_Create(5,5, sizeof(int)); ListOfBasisFunction = List_Create(5,5, sizeof(List_T *)); ListOfEntityIndex = List_Create(5,5, sizeof(int)); } } void Free_ParserVariables() { Tree_Delete(ConstantTable_L); ConstantTable_L = 0; List_Delete(ListOfInt_L); ListOfInt_L = 0; List_Delete(ListOfPointer_L); ListOfPointer_L = 0; List_Delete(ListOfPointer2_L); ListOfPointer2_L = 0; List_Delete(ListOfChar_L); ListOfChar_L = 0; List_Delete(ListOfFormulation); ListOfFormulation = 0; List_Delete(ListOfBasisFunction); ListOfBasisFunction = 0; List_Delete(ListOfEntityIndex); ListOfEntityIndex = 0; strcpy(getdp_yyname, ""); strcpy(getdp_yyincludename, ""); getdp_yylinenum = 0; getdp_yycolnum = 0; getdp_yyincludenum = 0; getdp_yyerrorlevel = 0; CommandLineNumbers.clear(); CommandLineStrings.clear(); } /* A d d _ G r o u p & C o . */ int Add_Group(struct Group *Group_P, char *Name, bool Flag_Add, int Flag_Plus, int Num_Index) { if(!Problem_S.Group) Problem_S.Group = List_Create(50, 50, sizeof (struct Group)); char tmpstr[256]; switch (Flag_Plus) { case 1 : sprintf(tmpstr, "_%s_%d", Name, List_Nbr(Problem_S.Group)); Group_P->Name = strSave(tmpstr); break; case 2 : sprintf(tmpstr, "%s_%d", Name, Num_Index); Group_P->Name = strSave(tmpstr); break; default : Group_P->Name = Name; } int i; if((i = List_ISearchSeq(Problem_S.Group, Group_P->Name, fcmp_Group_Name)) < 0) { i = Group_P->Num = List_Nbr(Problem_S.Group); Group_P->ExtendedList = NULL; Group_P->ExtendedSuppList = NULL; List_Add(Problem_S.Group, Group_P); } else if(Flag_Add) { List_T *InitialList = ((struct Group *)List_Pointer(Problem_S.Group, i))->InitialList; for(int j = 0; j < List_Nbr(Group_P->InitialList); j++) { List_Add(InitialList, (int *)List_Pointer(Group_P->InitialList, j)); } } else List_Write(Problem_S.Group, i, Group_P); return i; } int Num_Group(struct Group *Group_P, char *Name, int Num_Group) { if (Num_Group >= 0) /* OK */; else if(Num_Group == -1) Num_Group = Add_Group(Group_P, Name, false, 1, 0); else vyyerror("Bad Group right hand side"); return Num_Group; } void Fill_GroupInitialListFromString(List_T *list, const char *str) { bool found = false; // try to find a group with name "str" for(int i = 0; i < List_Nbr(Problem_S.Group); i++){ struct Group *Group_P = (struct Group*)List_Pointer(Problem_S.Group, i); if(!strcmp(str, Group_P->Name)){ List_Copy(Group_P->InitialList, list); found = true; break; } } // try to find a constant with name "str" Constant_S.Name = (char*)str; Constant *Constant_P = (Constant*)Tree_PQuery(ConstantTable_L, &Constant_S); if(Constant_P){ switch(Constant_P->Type){ case VAR_FLOAT: { int num = (int)Constant_P->Value.Float; List_Add(list, &num); } found = true; break; case VAR_LISTOFFLOAT: for(int j = 0; j < List_Nbr(Constant_P->Value.ListOfFloat); j++){ double d; List_Read(Constant_P->Value.ListOfFloat, j, &d); int num = (int)d; List_Add(list, &num); } found = true; break; } } // if not, try to convert "str" to an integer if(!found){ int num = atoi(str); if(num > 0){ List_Add(list, &num); found = true; } } if(!found) vyyerror("Unknown Group '%s'", str); } /* A d d _ E x p r e s s i o n */ int Add_Expression(struct Expression *Expression_P, char *Name, int Flag_Plus) { if(!Problem_S.Expression) Problem_S.Expression = List_Create(50, 50, sizeof (struct Expression)); switch (Flag_Plus) { case 1 : char tmpstr[256]; sprintf(tmpstr, "_%s_%d", Name, List_Nbr(Problem_S.Expression)) ; Expression_P->Name = strSave(tmpstr) ; break ; case 2 : Expression_P->Name = strSave(Name) ; break ; default : Expression_P->Name = Name ; } int i; if((i = List_ISearchSeq (Problem_S.Expression, Name, fcmp_Expression_Name)) < 0) { i = List_Nbr(Problem_S.Expression); List_Add(Problem_S.Expression, Expression_P); } else List_Write(Problem_S.Expression, i, Expression_P); return i; } bool Is_ExpressionPieceWiseDefined(int index) { struct Expression *e = (struct Expression *)List_Pointer(Problem_S.Expression, index); if(e->Type == PIECEWISEFUNCTION) return true; else if(e->Type == WHOLEQUANTITY){ for(int i = 0; i < List_Nbr(e->Case.WholeQuantity); i++){ struct WholeQuantity *w = (struct WholeQuantity *)List_Pointer(e->Case.WholeQuantity, i); if(w->Type == WQ_EXPRESSION) return Is_ExpressionPieceWiseDefined(w->Case.Expression.Index); } } return false; } /* L i s t e I n d e x d e s D e f i n e Q u a n t i t y */ void Pro_DefineQuantityIndex_1(List_T *WholeQuantity_L, int TraceGroupIndex, std::vector > &pairs) { struct WholeQuantity *WholeQuantity_P; WholeQuantity_P = (List_Nbr(WholeQuantity_L) > 0)? (struct WholeQuantity*)List_Pointer(WholeQuantity_L, 0) : NULL; for(int i = 0; i < List_Nbr(WholeQuantity_L); i++) switch ((WholeQuantity_P+i)->Type) { case WQ_OPERATORANDQUANTITY : case WQ_OPERATORANDQUANTITYEVAL : case WQ_SOLIDANGLE : case WQ_ORDER : { std::pair p((WholeQuantity_P+i)->Case.OperatorAndQuantity.Index, TraceGroupIndex); if(std::find(pairs.begin(), pairs.end(), p) == pairs.end()) pairs.push_back(p); } break; case WQ_MHTRANSFORM : Pro_DefineQuantityIndex_1 ((WholeQuantity_P+i)->Case.MHTransform.WholeQuantity, TraceGroupIndex, pairs); case WQ_TIMEDERIVATIVE : Pro_DefineQuantityIndex_1 ((WholeQuantity_P+i)->Case.TimeDerivative.WholeQuantity, TraceGroupIndex, pairs); break; case WQ_ATANTERIORTIMESTEP : Pro_DefineQuantityIndex_1 ((WholeQuantity_P+i)->Case.AtAnteriorTimeStep.WholeQuantity, TraceGroupIndex, pairs); break; case WQ_CAST : Pro_DefineQuantityIndex_1 ((WholeQuantity_P+i)->Case.Cast.WholeQuantity, TraceGroupIndex, pairs); break; case WQ_TRACE : Pro_DefineQuantityIndex_1 ((WholeQuantity_P+i)->Case.Trace.WholeQuantity, (WholeQuantity_P+i)->Case.Trace.InIndex, pairs); break; case WQ_TEST : Pro_DefineQuantityIndex_1 ((WholeQuantity_P+i)->Case.Test.WholeQuantity_True, TraceGroupIndex, pairs); Pro_DefineQuantityIndex_1 ((WholeQuantity_P+i)->Case.Test.WholeQuantity_False, TraceGroupIndex, pairs); break; } std::sort(pairs.begin(), pairs.end()); } void Pro_DefineQuantityIndex(List_T *WholeQuantity_L, int DefineQuantityIndexEqu, int *NbrQuantityIndex, int **QuantityIndexTable, int **QuantityTraceGroupIndexTable) { std::vector > pairs; /* special case for the Equ part (right of the comma) FIXME: change this when we allow a full WholeQuantity expression there */ Pro_DefineQuantityIndex_1(WholeQuantity_L, -1, pairs); if(DefineQuantityIndexEqu >= 0){ std::pair p(DefineQuantityIndexEqu, -1); pairs.push_back(p); } *NbrQuantityIndex = pairs.size(); *QuantityIndexTable = (int *)Malloc(pairs.size() * sizeof(int)); *QuantityTraceGroupIndexTable = (int *)Malloc(pairs.size() * sizeof(int)); for(unsigned int i = 0; i < pairs.size(); i++){ (*QuantityIndexTable)[i] = pairs[i].first; (*QuantityTraceGroupIndexTable)[i] = pairs[i].second; } } /* C h e c k _ N a m e O f S t r u c t N o t E x i s t */ void Check_NameOfStructNotExist(const char *Struct, List_T *List_L, void *data, int (*fcmp)(const void *a, const void *b)) { if(List_ISearchSeq(List_L, data, fcmp) >= 0) vyyerror("Redefinition of %s %s", Struct, (char*)data); } /* P r i n t _ C o n s t a n t */ int Print_ListOfDouble(char *format, List_T *list, char *buffer) { char tmp1[256], tmp2[256]; int j = 0; while(format[j] != '%') j++; strncpy(buffer, format, j); buffer[j] = '\0'; for(int i = 0; i < List_Nbr(list); i++){ int k = j; j++; if(j < (int)strlen(format)){ if(format[j] == '%'){ strcat(buffer, "%"); j++; } while(format[j] != '%' && j < (int)strlen(format)) j++; if(k != j){ strncpy(tmp1, &(format[k]),j-k); tmp1[j-k] = '\0'; sprintf(tmp2, tmp1, *(double*)List_Pointer(list,i)); strcat(buffer, tmp2); } } else{ return List_Nbr(list) - i; break; } } if(j != (int)strlen(format)) return -1; return 0; } void Print_Constants() { struct Constant *Constant_P; Message::Check("Constants:\n"); List_T *tmp = Tree2List(ConstantTable_L); for(int i = 0; i < List_Nbr(tmp); i++){ Constant_P = (struct Constant*)List_Pointer(tmp, i); switch(Constant_P->Type){ case VAR_FLOAT: Message::Check("%s = %g;\n", Constant_P->Name, Constant_P->Value.Float); break; case VAR_LISTOFFLOAT: { std::string str(Constant_P->Name); str += " = {"; for(int j = 0; j < List_Nbr(Constant_P->Value.ListOfFloat); j++){ if(j) str += ","; double d; List_Read(Constant_P->Value.ListOfFloat, j, &d); char tmp[32]; sprintf(tmp, "%g", d); str += tmp; } str += "};\n"; Message::Check(str.c_str()); } break; case VAR_CHAR: Message::Check("%s = \"%s\";\n", Constant_P->Name, Constant_P->Value.Char); break; } } List_Delete(tmp); } /* E r r o r h a n d l i n g */ void yyerror(const char *s) { extern char *getdp_yytext; Message::Error("'%s', line %ld : %s (%s)", getdp_yyname, getdp_yylinenum, s, getdp_yytext); getdp_yyerrorlevel = 1; } void vyyerror(const char *fmt, ...) { char str[256]; va_list args; va_start(args, fmt); vsprintf(str, fmt, args); va_end(args); Message::Error("'%s', line %ld : %s", getdp_yyname, getdp_yylinenum, str); getdp_yyerrorlevel = 1; } getdp-2.4.2-source/Interface/CMakeLists.txt000644 001750 001750 00000000566 12116424200 022237 0ustar00geuzainegeuzaine000000 000000 # GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine # # See the LICENSE.txt file for license information. Please report all # bugs and problems to the public mailing list . set(SRC ProData.cpp ProDefine.cpp ProParser.yy.cpp ProParser.tab.cpp ) file(GLOB HDR RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} *.h) append_getdp_src(Interface "${SRC};${HDR}") getdp-2.4.2-source/Legacy/F_BiotSavart.cpp000644 001750 001750 00000004513 12116424202 022030 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Ruth Sabariego // #include #include "ProData.h" #include "F.h" #include "Message.h" #define ONE_OVER_TWO_PI 1.5915494309189534E-01 #define ONE_OVER_FOUR_PI 7.9577471545947668E-02 #define SQU(a) ((a)*(a)) #define CUB(a) ((a)*(a)*(a)) extern struct CurrentData Current ; /* ------------------------------------------------------------------------ */ /* F _ B i o t S a v a r t */ /* ------------------------------------------------------------------------ */ void F_BiotSavart(F_ARG) { double r, xxs, yys, zzs ; V->Type = VECTOR ; switch((int)Fct->Para[0]){ case _2D : xxs = Current.x-Current.xs ; yys = Current.y-Current.ys ; r = SQU(xxs)+SQU(yys) ; if(!r) Message::Error("1/0 in 'F_BiotSavart'") ; V->Val[0] = ONE_OVER_TWO_PI * xxs / r ; V->Val[1] = ONE_OVER_TWO_PI * yys / r ; V->Val[2] = 0. ; V->Val[MAX_DIM ] = V->Val[MAX_DIM + 1] = V->Val[MAX_DIM + 2] = 0. ; break; case _3D : xxs = Current.x-Current.xs ; yys = Current.y-Current.ys ; zzs = Current.z-Current.zs ; r = sqrt(SQU(xxs)+SQU(yys)+SQU(zzs)) ; if(!r) Message::Error("1/0 in 'F_BiotSavart'") ; V->Val[0] = ONE_OVER_FOUR_PI * xxs/ CUB(r) ; V->Val[1] = ONE_OVER_FOUR_PI * yys/ CUB(r) ; V->Val[2] = ONE_OVER_FOUR_PI * zzs/ CUB(r) ; V->Val[MAX_DIM] = V->Val[MAX_DIM + 1 ] = V->Val[MAX_DIM + 2 ] =0. ; break; default: Message::Error("Bad dimension for BiotSavart"); break; } } void F_Pocklington(F_ARG) { double r, xxs, yys, zzs ; double k , kr, cte, a, re, im ; V->Type = SCALAR ; k = Fct->Para[0] ; a = Fct->Para[1] ; xxs = Current.x-Current.xs ; yys = Current.y-Current.ys ; zzs = Current.z-Current.zs ; r = sqrt(SQU(xxs)+SQU(yys)+SQU(zzs)+ a*a ) ; if(!r) Message::Error("1/0 in 'F_Pocklington'") ; kr = k*r ; cte = ONE_OVER_FOUR_PI/(r*r*r*r*r); re = 2*SQU(r)-3*SQU(a) + SQU(kr*a); im = kr * (2*SQU(r)-3*SQU(a)) ; V->Val[0] = cte * (cos(kr)* re + sin(kr)*im) ; V->Val[MAX_DIM] = cte * (-sin(kr) * re + cos(kr)*im) ; } #undef F_ARG getdp-2.4.2-source/Legacy/Cal_AnalyticIntegration.cpp000644 001750 001750 00000005534 12116424202 024240 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "ProData.h" #include "BF.h" #include "Message.h" /* ------------------------------------------------------------------------ */ /* C a l _ A n a l y t i c I n t e g r a t i o n */ /* ------------------------------------------------------------------------ */ double Cal_AnalyticIntegration(struct Element * E, void (*BFEqu)(), void (*BFDof)(), int i, int j, double (*Cal_Productx)()) { double DetJ ; if ((E->Type != TRIANGLE) || (BFEqu != (void (*)())BF_GradNode) || (BFDof != (void (*)())BF_GradNode) ) { Message::Error("Unknown analytic method for integration") ; return 0.; } DetJ = (E->x[2] - E->x[0]) * (E->y[1] - E->y[0]) - (E->x[1] - E->x[0]) * (E->y[2] - E->y[0]) ; switch (i) { case 0 : switch (j) { case 0 : return( ((E->y[2]-E->y[1])*(E->y[2]-E->y[1]) + (E->x[1]-E->x[2])*(E->x[1]-E->x[2])) * fabs(DetJ) / (2. * DetJ * DetJ) ) ; case 1 : return( ((E->y[2]-E->y[1])*(E->y[0]-E->y[2]) + (E->x[1]-E->x[2])*(E->x[2]-E->x[0])) * fabs(DetJ) / (2. * DetJ * DetJ) ) ; case 2 : return( ((E->y[2]-E->y[1])*(E->y[1]-E->y[0]) + (E->x[1]-E->x[2])*(E->x[0]-E->x[1])) * fabs(DetJ) / (2. * DetJ * DetJ) ) ; default : Message::Error("Something wrong in Cal_AnalyticIntegration"); return 0. ; } case 1 : switch (j) { case 0 : return( ((E->y[2]-E->y[1])*(E->y[0]-E->y[2]) + (E->x[1]-E->x[2])*(E->x[2]-E->x[0])) * fabs(DetJ) / (2. * DetJ * DetJ) ) ; case 1 : return( ((E->y[0]-E->y[2])*(E->y[0]-E->y[2]) + (E->x[2]-E->x[0])*(E->x[2]-E->x[0])) * fabs(DetJ) / (2. * DetJ * DetJ) ) ; case 2 : return( ((E->y[0]-E->y[2])*(E->y[1]-E->y[0]) + (E->x[2]-E->x[0])*(E->x[0]-E->x[1])) * fabs(DetJ) / (2. * DetJ * DetJ) ) ; default : Message::Error("Something wrong in Cal_AnalyticIntegration"); return 0. ; } case 2 : switch (j) { case 0 : return( ((E->y[2]-E->y[1])*(E->y[1]-E->y[0]) + (E->x[1]-E->x[2])*(E->x[0]-E->x[1])) * fabs(DetJ) / (2. * DetJ * DetJ) ) ; case 1 : return( ((E->y[0]-E->y[2])*(E->y[1]-E->y[0]) + (E->x[2]-E->x[0])*(E->x[0]-E->x[1])) * fabs(DetJ) / (2. * DetJ * DetJ) ) ; case 2 : return( ((E->y[1]-E->y[0])*(E->y[1]-E->y[0]) + (E->x[0]-E->x[1])*(E->x[0]-E->x[1])) * fabs(DetJ) / (2. * DetJ * DetJ) ) ; default : Message::Error("Something wrong in Cal_AnalyticIntegration"); return 0.; } default : Message::Error("Something wrong in Cal_AnalyticIntegration"); return 0. ; } } getdp-2.4.2-source/Legacy/Pos_Formulation.h000644 001750 001750 00000001631 12116424202 022270 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _POS_FORMULATION_H_ #define _POS_FORMULATION_H_ #include "ProData.h" #include "ListUtils.h" void Pos_Formulation(struct Formulation *Formulation_P, struct PostProcessing *PostProcessing_P, struct PostSubOperation *PostSubOperation_P); void Pos_FemFormulation(struct Formulation * Formulation_P, struct PostQuantity * LocalPQ, struct PostQuantity * CummulativePQ, int Order, struct PostSubOperation * PostSubOperation_P) ; int Pos_InitTimeSteps(struct PostSubOperation * PostSubOperation_P) ; void Pos_InitAllSolutions(List_T * TimeStep_L, int Index_TimeStep) ; void Pos_ResampleTime(struct PostOperation *PostOperation_P); #endif getdp-2.4.2-source/Legacy/Cal_AssembleTerm.cpp000644 001750 001750 00000040655 12221300353 022653 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Johan Gyselinck // #include "ProData.h" #include "DofData.h" #include "Message.h" #include #define SQU(a) ((a)*(a)) extern struct CurrentData Current ; static int Warning_Dt = 0, Warning_DtStatic = 0 ; static int Warning_DtDt = 0, Warning_DtDtStatic = 0, Warning_DtDtFirstOrder = 0 ; /* ------------------------------------------------------------------------ */ /* No Time Derivative */ /* ------------------------------------------------------------------------ */ void Cal_AssembleTerm_NoDt(struct Dof * Equ, struct Dof * Dof, double Val[]) { int k ; double tmp[2] ; if(Current.TypeAssembly == ASSEMBLY_SEPARATE){ if (!Current.DofData->Flag_Init[1]) { Current.DofData->Flag_Init[1] = 1 ; LinAlg_CreateMatrix(&Current.DofData->M1, &Current.DofData->Solver, Current.DofData->NbrDof, Current.DofData->NbrDof) ; LinAlg_CreateVector(&Current.DofData->m1, &Current.DofData->Solver, Current.DofData->NbrDof) ; LinAlg_ZeroMatrix(&Current.DofData->M1); LinAlg_ZeroVector(&Current.DofData->m1); Current.DofData->m1s = List_Create(10, 10, sizeof(gVector)); for(int i = 0; i < List_Nbr(Current.DofData->TimeFunctionIndex); i++){ gVector m; LinAlg_CreateVector(&m, &Current.DofData->Solver, Current.DofData->NbrDof) ; LinAlg_ZeroVector(&m); List_Add(Current.DofData->m1s, &m); } } for (k = 0 ; k < Current.NbrHar ; k += 2) Dof_AssembleInMat(Equ+k, Dof+k, Current.NbrHar, &Val[k], &Current.DofData->M1, &Current.DofData->m1, Current.DofData->m1s) ; } else { if (Current.NbrHar == 1) { switch (Current.TypeTime) { case TIME_STATIC : Dof_AssembleInMat(Equ, Dof, Current.NbrHar, &Val[0], &Current.DofData->A, &Current.DofData->b) ; break ; case TIME_THETA : tmp[0] = Val[0]*Current.Theta ; Dof_AssembleInMat(Equ, Dof, Current.NbrHar, tmp, &Current.DofData->A, &Current.DofData->b) ; tmp[0] = Val[0]*(Current.Theta-1.) ; Dof_AssembleInVec(Equ, Dof, Current.NbrHar, tmp, Current.DofData->CurrentSolution-1, &(Current.DofData->CurrentSolution-1)->x, &Current.DofData->b) ; break ; case TIME_NEWMARK : tmp[0] = Val[0]*Current.Beta ; Dof_AssembleInMat(Equ, Dof, Current.NbrHar, tmp, &Current.DofData->A, &Current.DofData->b) ; tmp[0] = Val[0]*(2*Current.Beta-Current.Gamma-0.5) ; Dof_AssembleInVec(Equ, Dof, Current.NbrHar, tmp, Current.DofData->CurrentSolution-1, &(Current.DofData->CurrentSolution-1)->x, &Current.DofData->b) ; tmp[0] = Val[0]*(Current.Gamma-Current.Beta-0.5) ; Dof_AssembleInVec(Equ, Dof, Current.NbrHar, tmp, Current.DofData->CurrentSolution-2, &(Current.DofData->CurrentSolution-2)->x, &Current.DofData->b) ; break ; case TIME_GEAR : Dof_AssembleInMat(Equ, Dof, Current.NbrHar, Val, &Current.DofData->A, &Current.DofData->b) ; break ; } } else { for (k = 0 ; k < Current.NbrHar ; k += 2) Dof_AssembleInMat(Equ+k, Dof+k, Current.NbrHar, &Val[k], &Current.DofData->A, &Current.DofData->b) ; } } } /* ------------------------------------------------------------------------ */ /* First order Time Derivative */ /* ------------------------------------------------------------------------ */ void Cal_AssembleTerm_DtDof(struct Dof * Equ, struct Dof * Dof, double Val[]) { int k ; double tmp[2] ; if(Current.TypeAssembly == ASSEMBLY_SEPARATE){ if (!Current.DofData->Flag_Init[2]) { Current.DofData->Flag_Init[2] = 1 ; LinAlg_CreateMatrix(&Current.DofData->M2, &Current.DofData->Solver, Current.DofData->NbrDof, Current.DofData->NbrDof) ; LinAlg_CreateVector(&Current.DofData->m2, &Current.DofData->Solver, Current.DofData->NbrDof) ; LinAlg_ZeroMatrix(&Current.DofData->M2); LinAlg_ZeroVector(&Current.DofData->m2); Current.DofData->m2s = List_Create(10, 10, sizeof(gVector)); for(int i = 0; i < List_Nbr(Current.DofData->TimeFunctionIndex); i++){ gVector m; LinAlg_CreateVector(&m, &Current.DofData->Solver, Current.DofData->NbrDof) ; LinAlg_ZeroVector(&m); List_Add(Current.DofData->m2s, &m); } } for (k = 0 ; k < Current.NbrHar ; k += 2) Dof_AssembleInMat(Equ+k, Dof+k, Current.NbrHar, &Val[k], &Current.DofData->M2, &Current.DofData->m2, Current.DofData->m2s) ; } else { if (Current.NbrHar == 1) { switch (Current.TypeTime) { case TIME_STATIC : if(!Warning_DtStatic){ Message::Info(3, "Discarded DtDof term in static analysis"); Warning_DtStatic = 1 ; } break; case TIME_THETA : tmp[0] = Val[0]/Current.DTime ; Dof_AssembleInMat(Equ, Dof, Current.NbrHar, tmp, &Current.DofData->A, &Current.DofData->b) ; Dof_AssembleInVec(Equ, Dof, Current.NbrHar, tmp, Current.DofData->CurrentSolution-1, &(Current.DofData->CurrentSolution-1)->x, &Current.DofData->b) ; break ; case TIME_NEWMARK : tmp[0] = Val[0]*Current.Gamma/Current.DTime ; Dof_AssembleInMat(Equ, Dof, Current.NbrHar, tmp, &Current.DofData->A, &Current.DofData->b) ; tmp[0] = Val[0]*(2.*Current.Gamma-1.)/Current.DTime ; Dof_AssembleInVec(Equ, Dof, Current.NbrHar, tmp, Current.DofData->CurrentSolution-1, &(Current.DofData->CurrentSolution-1)->x, &Current.DofData->b) ; tmp[0] = Val[0]*(1.-Current.Gamma)/Current.DTime ; Dof_AssembleInVec(Equ, Dof, Current.NbrHar, tmp, Current.DofData->CurrentSolution-2, &(Current.DofData->CurrentSolution-2)->x, &Current.DofData->b) ; break ; case TIME_GEAR : tmp[0] = Val[0]/(Current.bCorrCoeff*Current.DTime); Dof_AssembleInMat(Equ, Dof, Current.NbrHar, tmp, &Current.DofData->A, &Current.DofData->b) ; for (int i=0; iCurrentSolution-1, &(Current.DofData->CurrentSolution-1-i)->x, &Current.DofData->b) ; } break ; } } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { tmp[0] = -Val[k+1] * Current.DofData->Val_Pulsation[k/2] ; tmp[1] = Val[k] * Current.DofData->Val_Pulsation[k/2] ; Dof_AssembleInMat(Equ+k, Dof+k, Current.NbrHar, tmp, &Current.DofData->A, &Current.DofData->b) ; } } } } void Cal_AssembleTerm_Dt(struct Dof * Equ, struct Dof * Dof, double Val[]) { if(!Warning_Dt){ Message::Warning("Dt not implemented, using DtDof instead"); Warning_Dt = 1 ; } Cal_AssembleTerm_DtDof(Equ, Dof, Val); } /* En preparation ... */ void Cal_AssembleTerm_DtNL(struct Dof * Equ, struct Dof * Dof, double Val[]) { double tmp[2] ; if(Current.TypeAssembly == ASSEMBLY_SEPARATE){ Message::Error("DtNL not implemented for separate assembly"); } else { if (Current.NbrHar == 1) { switch (Current.TypeTime) { case TIME_STATIC : if(!Warning_DtStatic){ Message::Info(3, "Discarded DtDof term in static analysis"); Warning_DtStatic = 1 ; } break; case TIME_THETA : tmp[0] = Val[0]/Current.DTime ; Dof_AssembleInMat(Equ, Dof, Current.NbrHar, tmp, &Current.DofData->A, &Current.DofData->b) ; Dof_AssembleInVec(Equ, Dof, Current.NbrHar, tmp, Current.DofData->CurrentSolution-1, &(Current.DofData->CurrentSolution-1)->x, &Current.DofData->b) ; break ; case TIME_NEWMARK : Message::Error("DtNL not implemented for separate assembly with Newmark scheme"); return ; case TIME_GEAR : Message::Error("DtNL not implemented for Gear's method"); return ; } } else { Message::Error("DtNL not implemented for separate assembly in harmonic analysis"); /* for (k = 0 ; k < Current.NbrHar ; k += 2) { tmp[0] = -Val[k+1] * Current.DofData->Val_Pulsation[k/2] ; tmp[1] = Val[k] * Current.DofData->Val_Pulsation[k/2] ; Dof_AssembleInMat(Equ+k, Dof+k, Current.NbrHar, tmp, &Current.DofData->A, &Current.DofData->b) ; } */ } } } /* ------------------------------------------------------------------------ */ /* Second order Time Derivative */ /* ------------------------------------------------------------------------ */ void Cal_AssembleTerm_DtDtDof(struct Dof * Equ, struct Dof * Dof, double Val[]) { int k ; double tmp[2] ; if(Current.TypeAssembly == ASSEMBLY_SEPARATE){ if (!Current.DofData->Flag_Init[3]) { Current.DofData->Flag_Init[3] = 1 ; LinAlg_CreateMatrix(&Current.DofData->M3, &Current.DofData->Solver, Current.DofData->NbrDof, Current.DofData->NbrDof) ; LinAlg_CreateVector(&Current.DofData->m3, &Current.DofData->Solver, Current.DofData->NbrDof) ; LinAlg_ZeroMatrix(&Current.DofData->M3); LinAlg_ZeroVector(&Current.DofData->m3); Current.DofData->m3s = List_Create(10, 10, sizeof(gVector)); for(int i = 0; i < List_Nbr(Current.DofData->TimeFunctionIndex); i++){ gVector m; LinAlg_CreateVector(&m, &Current.DofData->Solver, Current.DofData->NbrDof) ; LinAlg_ZeroVector(&m); List_Add(Current.DofData->m3s, &m); } } for (k = 0 ; k < Current.NbrHar ; k += 2) { Dof_AssembleInMat(Equ+k, Dof+k, Current.NbrHar, &Val[k], &Current.DofData->M3, &Current.DofData->m3, Current.DofData->m3s) ; } } else { if (Current.NbrHar == 1) { switch (Current.TypeTime) { case TIME_STATIC : if(!Warning_DtDtStatic){ Message::Info(3, "Discarded DtDtDof term in static analysis"); Warning_DtDtStatic = 1 ; } break; case TIME_THETA : if(!Warning_DtDtFirstOrder){ Message::Info(3, "Discarded DtDtDof term in Theta time scheme"); Warning_DtDtFirstOrder = 1 ; } break; case TIME_GEAR : Message::Error("DtDtDof not implemented for Gear's method"); return ; case TIME_NEWMARK : tmp[0] = Val[0]/SQU(Current.DTime) ; Dof_AssembleInMat(Equ, Dof, Current.NbrHar, tmp, &Current.DofData->A, &Current.DofData->b) ; tmp[0] = 2*Val[0]/SQU(Current.DTime) ; Dof_AssembleInVec(Equ, Dof, Current.NbrHar, tmp, Current.DofData->CurrentSolution-1, &(Current.DofData->CurrentSolution-1)->x, &Current.DofData->b) ; tmp[0] = -Val[0]/SQU(Current.DTime) ; Dof_AssembleInVec(Equ, Dof, Current.NbrHar, tmp, Current.DofData->CurrentSolution-2, &(Current.DofData->CurrentSolution-2)->x, &Current.DofData->b) ; break ; } } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { tmp[0] = - Val[k] * SQU(Current.DofData->Val_Pulsation[k/2]) ; tmp[1] = - Val[k+1] * SQU(Current.DofData->Val_Pulsation[k/2]) ; Dof_AssembleInMat(Equ+k, Dof+k, Current.NbrHar, tmp, &Current.DofData->A, &Current.DofData->b) ; } } } } void Cal_AssembleTerm_DtDt(struct Dof * Equ, struct Dof * Dof, double Val[]) { if(!Warning_DtDt){ Message::Warning("DtDt not implemented, using DtDtDof instead"); Warning_DtDt = 1 ; } Cal_AssembleTerm_DtDtDof(Equ, Dof, Val); } /* ------------------------------------------------------------------------ */ /* Jacobian NonLinear */ /* ------------------------------------------------------------------------ */ void Cal_AssembleTerm_JacNL(struct Dof * Equ, struct Dof * Dof, double Val[]) { int k ; if(Current.TypeAssembly == ASSEMBLY_SEPARATE){ Message::Error("JacNL not implemented for separate assembly"); } else{ if (Current.NbrHar == 1) { switch (Current.TypeTime) { case TIME_STATIC : case TIME_THETA : Dof_AssembleInMat(Equ, Dof, Current.NbrHar, &Val[0], &Current.DofData->Jac, NULL) ; break ; case TIME_GEAR : Dof_AssembleInMat(Equ, Dof, Current.NbrHar, &Val[0], &Current.DofData->Jac, NULL) ; break ; case TIME_NEWMARK : Message::Error("JacNL not implemented for Newmark's method"); return ; } } else { for (k = 0 ; k < Current.NbrHar ; k += 2) Dof_AssembleInMat(Equ+k, Dof+k, Current.NbrHar, &Val[k], &Current.DofData->Jac, NULL) ; } } } void Cal_AssembleTerm_DtDofJacNL(struct Dof * Equ, struct Dof * Dof, double Val[]) { double tmp[2] ; if(Current.TypeAssembly == ASSEMBLY_SEPARATE) Message::Error("DtDofJacNL not implemented for separate assembly"); else { if (Current.NbrHar == 1) { switch (Current.TypeTime) { case TIME_STATIC : if(!Warning_DtStatic){ Message::Info(3, "Discarded DtDof term in static analysis"); Warning_DtStatic = 1 ; } break; case TIME_THETA : if ( fabs(Current.Theta - 1.0) > 1e-3 ){ Message::Error("Theta method not implemented for nonlinear problems when " "Theta != 1.0"); return; } tmp[0] = Val[0]/Current.DTime; Dof_AssembleInMat(Equ, Dof, Current.NbrHar, tmp, &Current.DofData->Jac, NULL); break ; case TIME_NEWMARK : Message::Error("DtDofJacNL not implemented for Newmark scheme"); return ; case TIME_GEAR : tmp[0] = Val[0] / (Current.bCorrCoeff * Current.DTime); Dof_AssembleInMat(Equ, Dof, Current.NbrHar, tmp, &Current.DofData->Jac, NULL); break ; } } else Message::Error("DtDofJacNL not implemented for multi-harmonic analysis"); } } /* ------------------------------------------------------------------------ */ /* Never Time Derivative (provisoire mais tres important ... Patrick) */ /* ------------------------------------------------------------------------ */ void Cal_AssembleTerm_NeverDt(struct Dof * Equ, struct Dof * Dof, double Val[]) { int k ; if(Current.TypeAssembly == ASSEMBLY_SEPARATE){ Message::Error("NeverDt not implemented for separate assembly"); } else{ if (Current.NbrHar == 1) { switch (Current.TypeTime) { case TIME_STATIC : case TIME_THETA : case TIME_NEWMARK : case TIME_GEAR : Dof_AssembleInMat(Equ, Dof, Current.NbrHar, &Val[0], &Current.DofData->A, &Current.DofData->b) ; break ; } } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { Dof_AssembleInMat(Equ+k, Dof+k, Current.NbrHar, &Val[k], &Current.DofData->A, &Current.DofData->b) ; } } } } /* ------------------------------------------------------------------------ */ /* Multi-Harmonic */ /* ------------------------------------------------------------------------ */ void Cal_AssembleTerm_MH_Moving_simple(struct Dof * Equ, struct Dof * Dof, double Val[]) { int k, l ; double tmp ; extern double ** MH_Moving_Matrix ; for (k = 0 ; k < Current.NbrHar ; k++) for (l = 0 ; l < Current.NbrHar ; l++) { tmp = Val[0] * MH_Moving_Matrix[k][l] ; /* if (k==l) */ Dof_AssembleInMat(Equ+k, Dof+l, 1, &tmp, &Current.DofData->A, &Current.DofData->b) ; } } void Cal_AssembleTerm_MH_Moving_separate(struct Dof * Equ, struct Dof * Dof, double Val[]) { int k, l ; double tmp ; extern double ** MH_Moving_Matrix ; for (k = 0 ; k < Current.NbrHar ; k++) for (l = 0 ; l < Current.NbrHar ; l++) { tmp = Val[0] * MH_Moving_Matrix[k][l] ; /* if (k==l) */ Dof_AssembleInMat(Equ+k, Dof+l, 1, &tmp, &Current.DofData->A_MH_moving, &Current.DofData->b_MH_moving) ; } } void Cal_AssembleTerm_MH_Moving_probe(struct Dof * Equ, struct Dof * Dof, double Val[]) { extern Tree_T * DofTree_MH_moving ; if (Dof->Type == DOF_UNKNOWN && !Tree_PQuery(DofTree_MH_moving, Dof)) Tree_Add(DofTree_MH_moving,Dof) ; else if (Dof->Type == DOF_LINK && !Tree_PQuery(DofTree_MH_moving, Dof->Case.Link.Dof)) Tree_Add(DofTree_MH_moving,Dof->Case.Link.Dof) ; if (Equ->Type == DOF_UNKNOWN && !Tree_PQuery(DofTree_MH_moving, Equ)) Tree_Add(DofTree_MH_moving,Equ) ; else if (Equ->Type == DOF_LINK && !Tree_PQuery(DofTree_MH_moving, Equ->Case.Link.Dof)) Tree_Add(DofTree_MH_moving,Equ->Case.Link.Dof) ; } getdp-2.4.2-source/Legacy/Get_FunctionValue.h000644 001750 001750 00000001625 12116424202 022534 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _GET_FUNCTION_VALUE_H_ #define _GET_FUNCTION_VALUE_H_ #include "ProData.h" int Get_ValueFromForm(int Form); struct IntegrationCase * Get_IntegrationCase (struct Element * Element, List_T *IntegrationCase_L, int CriterionIndex); void Get_FunctionValue(int Nbr_Function, void (*xFunctionBF[])(), int Type_Operator, struct QuantityStorage * QuantityStorage_P, int * Type_Form); void Get_InitFunctionValue(int Type_Operator, struct QuantityStorage * QuantityStorage_P, int * Type_Form); double Cal_InterpolationOrder(struct Element * Element, struct QuantityStorage * QuantityStorage); double Cal_MaxEdgeLength(struct Element * Element); #endif getdp-2.4.2-source/Legacy/Get_ConstraintOfElement.h000644 001750 001750 00000002572 12166744450 023716 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _GET_CONSTRAINT_OF_ELEMENT_H_ #define _GET_CONSTRAINT_OF_ELEMENT_H_ #include "ProData.h" void Treatment_ConstraintForElement(struct FunctionSpace * FunctionSpace_P, struct QuantityStorage * QuantityStorage_P, int Num_Entity[], int i_Entity, int i_BFunction, int TypeConstraint) ; void Treatment_ConstraintForRegion(struct GlobalQuantity * GlobalQuantity_P, struct FunctionSpace * FunctionSpace_P, struct QuantityStorage * QuantityStorage_P) ; void Treatment_ConstraintByLocalProjection(struct Element *Element, struct FunctionSpace *FunctionSpace_P, struct QuantityStorage *QuantityStorage_P) ; void Get_ValueForConstraint(struct ConstraintInFS * Constraint_P, double Value[], double Value2[], int * Index_TimeFunction) ; void Get_PreResolutionForConstraint(struct ConstraintInFS * Constraint_P, int * Index_TimeFunction) ; void Get_LinkForConstraint(struct ConstraintInFS * Constraint_P, int Num_Entity, int * CodeEntity_Link, int Orient, double Value[]) ; #endif getdp-2.4.2-source/Legacy/GF_Helmholtz.cpp000644 001750 001750 00000020237 12166744450 022047 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Ruth Sabariego // #include #include "ProData.h" #include "GF.h" #include "Cal_Value.h" #include "GeoData.h" #include "Message.h" #define SQU(a) ((a)*(a)) #define CUB(a) ((a)*(a)*(a)) #define ONE_OVER_FOUR_PI 7.9577471545947668E-02 extern struct CurrentData Current ; /* ------------------------------------------------------------------------ */ /* G F _ H e l m h o l t z */ /* ------------------------------------------------------------------------ */ void GF_Helmholtz(GF_ARG) { double r, kr ; if(Current.NbrHar != 2) Message::Error("Wrong Number of Harmonics in 'GF_Helmholtz'"); V->Type = SCALAR ; switch((int)Fct->Para[0]){ case _2D : r = sqrt(SQU(Current.x-Current.xs)+ SQU(Current.y-Current.ys) ) ; if(!r) Message::Error("1/0 in 'GF_Helmholtz'") ; kr = Fct->Para[1]*r; V->Val[0] = -y0(kr)/4 ; V->Val[MAX_DIM] = -j0(kr)/4 ; break ; case _3D : r = sqrt(SQU(Current.x-Current.xs)+ SQU(Current.y-Current.ys)+ SQU(Current.z-Current.zs)) ; if(!r) Message::Error("1/0 in 'GF_Helmholtz'") ; kr = Fct->Para[1]*r; V->Val[0] = ONE_OVER_FOUR_PI * cos(kr) / r ; V->Val[MAX_DIM] = -ONE_OVER_FOUR_PI * sin(kr) / r ; break ; default : Message::Error("Bad Parameter for 'GF_Helmholtz' (%d)", (int)Fct->Para[0]); break; } } /* ------------------------------------------------------------------------ */ /* G F _ H e l m h o l t z T h i n W i r e */ /* ------------------------------------------------------------------------ */ void GF_HelmholtzThinWire(GF_ARG) { double a , r, kr ; if(Current.NbrHar != 2) Message::Error("Wrong Number of Harmonics in 'GF_HelmholtzThinWire'"); V->Type = SCALAR ; switch((int)Fct->Para[0]){ case _2D : a = Fct->Para[2] ; r = sqrt(SQU(Current.x-Current.xs)+ SQU(Current.y-Current.ys)+SQU(a)) ; if(!r) Message::Error("1/0 in 'GF_HelmholtzThinWire'") ; kr = Fct->Para[1]*r; V->Val[0] = -y0(kr)/4 ; V->Val[MAX_DIM] = -j0(kr)/4 ; break ; case _3D : a = Fct->Para[2] ; r = sqrt(SQU(Current.x-Current.xs)+ SQU(Current.y-Current.ys)+ SQU(Current.z-Current.zs)+SQU(a)) ; if(!r) Message::Error("1/0 in 'GF_HelmholtzThinWire'") ; kr = Fct->Para[1]*r; V->Val[0] = ONE_OVER_FOUR_PI * cos(kr) / r ; V->Val[MAX_DIM] = -ONE_OVER_FOUR_PI * sin(kr) / r ; break ; default : Message::Error("Bad Parameter for 'GF_HelmholtzThinWire' (%d)", (int)Fct->Para[0]); break; } } /* ------------------------------------------------------------------------ */ /* G F _ G r a d H e l m h o l t z */ /* ------------------------------------------------------------------------ */ /* the gradient is taken relative to the destination point (x,y,z) */ void GF_GradHelmholtz(GF_ARG) { double xxs, yys, zzs, r, kr, k0r ; double c1, c2, cr, ci ; if(Current.NbrHar != 2) Message::Error("Wrong Number of Harmonics in 'GF_GradHelmholtz'"); V->Type = VECTOR ; switch((int)Fct->Para[0]){ case _2D : xxs = Current.x-Current.xs ; yys = Current.y-Current.ys ; r = sqrt(SQU(xxs)+SQU(yys)) ; k0r = Fct->Para[1]*r; if (!r) Cal_ZeroValue(V); else { c1 = Fct->Para[1]/4/r ; cr = c1 * y1(k0r); ci = c1 * j1(k0r); V->Val[0] = xxs * cr ; V->Val[MAX_DIM ] = xxs * ci ; V->Val[1] = yys * cr ; V->Val[MAX_DIM+1] = yys * ci ; } break ; case _3D : xxs = Current.x-Current.xs ; yys = Current.y-Current.ys ; zzs = Current.z-Current.zs ; r = sqrt(SQU(xxs)+SQU(yys)+SQU(zzs)) ; kr = Fct->Para[1] * r ; if (!r) Cal_ZeroValue(V); else { c1 = - ONE_OVER_FOUR_PI / CUB(r) ; c2 = ONE_OVER_FOUR_PI * Fct->Para[1] / SQU(r) ; cr = c1 * cos(kr) - c2 * sin(kr) ; ci = -c1 * sin(kr) - c2 * cos(kr) ; V->Val[0] = xxs * cr ; V->Val[MAX_DIM ] = xxs * ci ; V->Val[1] = yys * cr ; V->Val[MAX_DIM+1] = yys * ci ; V->Val[2] = zzs * cr ; V->Val[MAX_DIM+2] = zzs * ci ; } break ; default : Message::Error("Bad Parameter for 'GF_GradHelmholtz' (%d)", (int)Fct->Para[0]); break; } } /* ------------------------------------------------------------------------ */ /* G F _ N P x G r a d H e l m h o l t z */ /* ------------------------------------------------------------------------ */ void GF_NPxGradHelmholtz(GF_ARG) { double N[3] ; struct Value ValGrad ; /* Vectorial product N[] /\ Grad G */ if(Current.NbrHar != 2) Message::Error("Wrong Number of Harmonics in 'GF_NPxGradHelmholtz'"); V->Type = VECTOR ; if (Current.Element->Num == Current.ElementSource->Num) { Cal_ZeroValue(V); return ; } switch((int)Fct->Para[0]){ case _3D : Geo_CreateNormal(Current.Element->Type, Current.Element->x,Current.Element->y,Current.Element->z, N); GF_GradHelmholtz(Fct, &ValGrad, &ValGrad) ; V->Val[0] = N[1]*ValGrad.Val[2] - N[2]*ValGrad.Val[1]; V->Val[1] =-N[0]*ValGrad.Val[2] + N[2]*ValGrad.Val[0]; V->Val[2] = N[0]*ValGrad.Val[1] - N[1]*ValGrad.Val[0]; V->Val[MAX_DIM ] = N[1]*ValGrad.Val[MAX_DIM+2] - N[2]*ValGrad.Val[MAX_DIM+1]; V->Val[MAX_DIM+1] =-N[0]*ValGrad.Val[MAX_DIM+2] + N[2]*ValGrad.Val[MAX_DIM]; V->Val[MAX_DIM+2] = N[0]*ValGrad.Val[MAX_DIM+1] - N[1]*ValGrad.Val[MAX_DIM]; break ; default : Message::Error("Bad Parameter for 'GF_NPxGradHelmholtz' (%d)", (int)Fct->Para[0]); break; } } /* ------------------------------------------------------------------------ */ /* G F _ N S x G r a d H e l m h o l t z */ /* ------------------------------------------------------------------------ */ void GF_NSxGradHelmholtz(GF_ARG) { double x1x0, x2x0, y1y0, y2y0, z1z0, z2z0, xxs, yys, zzs, r ; double nx, ny, nz, n, c1, c2, cr, ci ; if(Current.NbrHar != 2) Message::Error("Wrong Number of Harmonics in 'GF_NSxGradHelmholtz'"); V->Type = SCALAR ; switch((int)Fct->Para[0]){ case _2D : xxs = Current.x-Current.xs ; yys = Current.y-Current.ys ; r = sqrt(SQU(xxs)+SQU(yys)) ; if(Current.Element->Num == NO_ELEMENT) Current.Element = Current.ElementSource ; ny = - Current.Element->x[1] + Current.Element->x[0] ; nx = Current.Element->y[1] - Current.Element->y[0] ; n = sqrt(SQU(nx)+SQU(ny)) ; nx = nx / n ; ny = ny / n ; if (!r) Cal_ZeroValue(V); else { c1 = Fct->Para[1]/4/r ; cr = c1 * y1(Fct->Para[1]*r); ci = c1 * j1(Fct->Para[1]*r); V->Val[0] = nx * xxs * cr + ny * yys * cr ; V->Val[MAX_DIM ] = nx * xxs * ci + ny * yys * ci ; } break ; case _3D : xxs = Current.x-Current.xs ; yys = Current.y-Current.ys ; zzs = Current.z-Current.zs ; r = sqrt(SQU(xxs)+SQU(yys)+SQU(zzs)) ; if (!r) Cal_ZeroValue(V); else { x1x0 = Current.Element->x[1] - Current.Element->x[0] ; y1y0 = Current.Element->y[1] - Current.Element->y[0] ; z1z0 = Current.Element->z[1] - Current.Element->z[0] ; x2x0 = Current.Element->x[2] - Current.Element->x[0] ; y2y0 = Current.Element->y[2] - Current.Element->y[0] ; z2z0 = Current.Element->z[2] - Current.Element->z[0] ; nx = y1y0 * z2z0 - z1z0 * y2y0 ; ny = z1z0 * x2x0 - x1x0 * z2z0 ; nz = x1x0 * y2y0 - y1y0 * x2x0 ; n = sqrt(SQU(nx)+SQU(ny)+SQU(nz)) ; nx = nx/n ; ny = ny/n ; nz = nz/n ; c1 = - ONE_OVER_FOUR_PI / CUB(r) ; c2 = ONE_OVER_FOUR_PI * Fct->Para[1] / SQU(r) ; cr = (c1 * cos(Fct->Para[1]*r) - c2 * sin(Fct->Para[1]*r)) ; ci = (c1 * sin(Fct->Para[1]*r) + c2 * cos(Fct->Para[1]*r)) ; V->Val[0] =nx * xxs * cr + ny * yys * cr + nz * zzs * cr ; V->Val[MAX_DIM ] = nx* xxs * ci + ny * yys * ci + nz * zzs * ci; } break ; default : Message::Error("Bad Parameter for 'GF_NSxGradHelmholtz' (%d)", (int)Fct->Para[0]); break; } } getdp-2.4.2-source/Legacy/MainLegacy.cpp000644 001750 001750 00000040334 12166744450 021536 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include #include #include "GetDPConfig.h" #include "GetDPVersion.h" #include "onelab.h" #include "ProData.h" #include "ProParser.h" #include "SolvingAnalyse.h" #include "LinAlg.h" #include "OS.h" #include "MallocUtils.h" #include "Message.h" #if defined(HAVE_GMSH) #include #include #include #endif int Flag_PRE = 0, Flag_CAL = 0, Flag_POS = 0, Flag_RESTART = 0; int Flag_XDATA = 0, Flag_BIN = 0, Flag_SPLIT = 0, Flag_GMSH_VERSION = 1; int Flag_NETWORK_CACHE = 0; double Flag_ORDER = -1.; char *Name_Generic = 0, *Name_Path = 0; char *Name_Resolution = 0; char *Name_MshFile = 0, *Name_AdaptFile = 0; char *Name_PostOperation[NBR_MAX_POS] = {0}; char *Name_ResFile[NBR_MAX_RES] = {0}; char *Name_GmshReadFile[NBR_MAX_RES] = {0}; static void Info(int level, char *arg0) { switch(level){ case 0 : fprintf(stderr, "GetDP, a General environment for the treatment of Discrete Problems\n" "Copyright (C) 1997-2013 P. Dular, C. Geuzaine\n" "Usage: %s [file] [options]\n" "Processing options:\n" " -pre 'Resolution' pre-processing\n" " -cal processing\n" " -pos 'PostOperation(s)' post-processing\n" " -msh file read mesh (in msh format) from file\n" " -gmshread file(s) read gmsh data (same as GmshRead in resolution)\n" " -restart resume processing from where it stopped\n" " -solve 'Resolution' same as -pre 'Resolution' -cal\n" " -split save processing results in separate files\n" " -res file(s) load processing results from file(s)\n" " -name string use string as generic file name\n" " -adapt file read adaptation constraints from file\n" " -order num restrict maximum interpolation order\n" " -cache cache network computations to disk\n" "Linear solver options:\n" #if defined(HAVE_PETSC) " -solver file specify parameter file (default: .petscrc)\n" " [PETsc options] PETSc options (must be listed after [file])\n" #endif #if defined(HAVE_SPARSKIT) " -solver file specify parameter file (default: solver.par)\n" " -'Parameter' num override value of solver parameter 'Parameter'\n" #endif "Output options:\n" " -bin create binary output files\n" " -v2 create mesh-based Gmsh output files when possible\n" "Other options:\n" " -check interactive check of problem structure\n" " -v num set verbosity level (default: 5)\n" " -p num set progress indicator update (default: 10)\n" " -onelab name [address] communicate with OneLab (file or server address)\n" " -setnumber name value set constant number name=value\n" " -setstring name value set constant string name=value\n" " -version show version number\n" " -info show detailed version information\n" " -help show this message\n", arg0); break; case 1: fprintf(stderr, "%s\n", GETDP_VERSION); break; case 2: fprintf(stderr, "Version : %s\n", GETDP_VERSION); #if defined(HAVE_PETSC) #if defined(PETSC_USE_COMPLEX) fprintf(stderr, "PETSc arithmetic : Complex\n"); #else fprintf(stderr, "PETSc arithmetic : Real\n"); #endif #endif fprintf(stderr, "License : %s\n", GETDP_SHORT_LICENSE); fprintf(stderr, "Build OS : %s\n", GETDP_OS); fprintf(stderr, "Build options :%s\n", GETDP_CONFIG_OPTIONS); fprintf(stderr, "Build date : %s\n", GETDP_DATE); fprintf(stderr, "Build host : %s\n", GETDP_HOST); #if defined(HAVE_GMSH) fprintf(stderr, "Gmsh version : %s%s (%s)\n", GMSH_VERSION, GMSH_EXTRA_VERSION, GMSH_DATE); fprintf(stderr, "Gmsh options :%s\n", GMSH_CONFIG_OPTIONS); #endif fprintf(stderr, "Packager : %s\n", GETDP_PACKAGER); fprintf(stderr, "Web site : http://www.geuz.org/getdp/\n"); fprintf(stderr, "Mailing list : getdp@geuz.org\n"); break; } exit(0); } /* ------------------------------------------------------------------------ */ /* G e t _ O p t i o n s */ /* ------------------------------------------------------------------------ */ static void Get_Options(int argc, char *argv[], int *sargc, char **sargv, char *pro, int *lres, int *lpos, int *check) { strcpy(pro, ""); int i = *sargc = 1, j = 0; while (i < argc) { if (argv[i][0] == '-') { if (!strcmp(argv[i]+1, "cal")) { Flag_CAL = 1; i++; } else if (!strcmp(argv[i]+1, "check")) { *check = 1; i++; } else if (!strcmp(argv[i]+1, "xdata")) { Flag_XDATA = 1; i++; } else if (!strcmp(argv[i]+1, "cache")) { Flag_NETWORK_CACHE = 1; i++; } else if (!strcmp(argv[i]+1, "bin")) { Flag_BIN = 1; i++; } else if (!strcmp(argv[i]+1, "v2")) { Flag_GMSH_VERSION = 2; i++; } else if (!strcmp(argv[i]+1, "ascii")) { Flag_BIN = 0; i++; } else if (!strcmp(argv[i]+1, "split")) { Flag_SPLIT = 1; i++; } else if (!strcmp(argv[i]+1, "socket")) { i++; if (i < argc && argv[i][0] != '-') { Message::InitializeSocket(argv[i]); i++; } else { Message::Error("Missing socket name"); } } else if (!strcmp(argv[i]+1, "onelab")) { i++; if (i + 1 < argc && argv[i][0] != '-' && argv[i + 1][0] != '-') { Message::InitializeOnelab(argv[i], argv[i + 1]); i += 2; } else if (i < argc && argv[i][0] != '-') { Message::InitializeOnelab(argv[i], ""); i += 1; } else { Message::Error("Missing client name and/or address of OneLab server"); } } else if (!strcmp(argv[i]+1, "setnumber")) { i++; if (i + 1 < argc && argv[i][0] != '-' && argv[i + 1][0] != '-') { CommandLineNumbers[argv[i]] = atof(argv[i + 1]); i += 2; } else Message::Error("Missing name and/or value for number definition"); } else if (!strcmp(argv[i]+1, "setstring")) { i++; if (i + 1 < argc && argv[i][0] != '-' && argv[i + 1][0] != '-') { CommandLineStrings[argv[i]] = argv[i + 1]; i += 2; } else Message::Error("Missing name and/or value for string definition"); } else if (!strcmp(argv[i]+1, "restart")){ Flag_CAL = Flag_RESTART = 1; i++; } else if (!strcmp(argv[i]+1, "verbose") || !strcmp(argv[i]+1, "v")) { i++; if (i < argc && argv[i][0] != '-') { Message::SetVerbosity(atoi(argv[i])); i++; } else { Message::Error("Missing number"); } } else if (!strcmp(argv[i]+1, "help") || !strcmp(argv[i]+1, "h") || !strcmp(argv[i]+1, "-help") || !strcmp(argv[i]+1, "-h")) { Info(0, argv[0]); } else if (!strcmp(argv[i]+1, "version") || !strcmp(argv[i]+1, "-version")) { Info(1, argv[0]); } else if (!strcmp(argv[i]+1, "info") || !strcmp(argv[i]+1, "-info")) { Info(2, argv[0]); } else if (!strcmp(argv[i]+1, "progress") || !strcmp(argv[i]+1, "p")) { i++; if (i < argc && argv[i][0] != '-') { Message::SetProgressMeterStep(atoi(argv[i])); i++; } else { Message::Error("Missing number"); } } else if (!strcmp(argv[i]+1, "pre")) { i++; if (i < argc && argv[i][0] == '#') { Flag_PRE = 1; *lres = -atoi(argv[i]+1); i++; } else if (i < argc && argv[i][0] != '-') { Flag_PRE = 1; Name_Resolution = strSave(argv[i]); i++; } else { Flag_PRE = *lres = 1; } } else if (!strcmp(argv[i]+1, "order") || !strcmp(argv[i]+1, "ord")) { i++; if (i < argc && argv[i][0] != '-') { Flag_ORDER = atof(argv[i]); i++; } else { Message::Error("Missing interpolation order"); } } else if (!strcmp(argv[i]+1, "solver")) { // fix when calling getdp from gmsh (since the GUI forces us // to put the -solver option before the .pro file!) sargv[(*sargc)++] = argv[i++]; if (i < argc && argv[i][0] != '-') { sargv[(*sargc)++] = argv[i++]; } else { Message::Error("Missing solver option file name"); } } else if (!strcmp(argv[i]+1, "solve") || !strcmp(argv[i]+1, "sol")) { i++; if (i < argc && argv[i][0] == '#') { Flag_PRE = Flag_CAL = 1; *lres = -atoi(argv[i]+1); i++; } else if (i < argc && argv[i][0] != '-') { Flag_PRE = Flag_CAL = 1; Name_Resolution = strSave(argv[i]); i++; } else { Flag_PRE = Flag_CAL = *lres = 1; } } else if (!strcmp(argv[i]+1, "post") || !strcmp(argv[i]+1, "pos")) { i++; j = 0; if (i < argc && argv[i][0] == '#') { Flag_POS = 1; *lpos = -atoi(argv[i]+1); i++; } /* Only one numbered (#) PostOperation allowed */ else { while (i < argc && argv[i][0] != '-') { Name_PostOperation[j] = strSave(argv[i]); i++; j++; if(j == NBR_MAX_POS){ Message::Error("Too many PostOperations"); break; } } if(!j){ Flag_POS = *lpos = 1; } else{ Flag_POS = 1; Name_PostOperation[j] = NULL; } } } else if (!strcmp(argv[i]+1, "mesh") || !strcmp(argv[i]+1, "msh") || !strcmp(argv[i]+1, "m")) { i++; if (i < argc && argv[i][0] != '-') { Name_MshFile = strSave(argv[i]); i++; } else { Message::Error("Missing file name"); } } else if (!strcmp(argv[i]+1, "adapt") || !strcmp(argv[i]+1, "adap") || !strcmp(argv[i]+1, "ada")) { i++; if (i < argc && argv[i][0] != '-') { Name_AdaptFile = strSave(argv[i]); i++; } else { Message::Error("Missing file name"); } } else if (!strcmp(argv[i]+1, "res")) { i++; j = 0; while (i < argc && argv[i][0] != '-') { Name_ResFile[j] = strSave(argv[i]); i++; j++; if(j == NBR_MAX_RES){ Message::Error("Too many '.res' files"); break; } } if(!j) Message::Error("Missing file name"); else{ Name_ResFile[j] = NULL; } } else if (!strcmp(argv[i]+1, "gmshread")) { i++; j = 0; while (i < argc && argv[i][0] != '-') { Name_GmshReadFile[j] = strSave(argv[i]); i++; j++; if(j == NBR_MAX_RES){ Message::Error("Too many GmshRead files"); break; } } if(!j) Message::Error("Missing file name"); else{ Name_GmshReadFile[j] = NULL; } } else if (!strcmp(argv[i]+1, "name")) { i++; if (i < argc && argv[i][0] != '-') { Name_Generic = (char*)Malloc((strlen(argv[i]) + 1) * sizeof(char)); strcpy(Name_Generic, argv[i]); i++; } else { Message::Error("Missing string"); } } else if (!strcmp(argv[i]+1, "petscinfo") || !strcmp(argv[i]+1, "-petscinfo")) { sargv[(*sargc)++] = (char*)"-info"; i++; } else { sargv[(*sargc)++] = argv[i++]; } } else{ if (!strlen(pro)) { sargv[0] = argv[i]; strcpy(pro, argv[i++]); } else{ sargv[(*sargc)++] = argv[i++]; } } } if(!strlen(pro)){ Message::Error("Missing input file name"); Name_Generic = (char*)Malloc(sizeof(char)); strcpy(Name_Generic, ""); *sargc = 0; } else{ if(!Name_Generic){ Name_Generic = (char*)Malloc((strlen(pro) + 1) * sizeof(char)); strcpy(Name_Generic, pro); if(strcmp(pro+(strlen(pro)-4), ".pro") && strcmp(pro+(strlen(pro)-4), ".PRO")) strcat(pro,".pro"); else Name_Generic[strlen(pro)-4] = '\0'; } else if(strcmp(pro+(strlen(pro)-4), ".pro") && strcmp(pro+(strlen(pro)-4), ".PRO")) strcat(pro,".pro"); Name_Path = (char*)Malloc((strlen(Name_Generic) + 1) * sizeof(char)); strcpy(Name_Path, Name_Generic); i = strlen(Name_Path)-1; while(i >= 0 && Name_Path[i] != '/' && Name_Path[i] != '\\') i--; Name_Path[i+1] = '\0'; } } #if defined(HAVE_GMSH) class GmshMsg : public GmshMessage{ public: void operator()(std::string level, std::string msg) { if(level == "Fatal") Message::Fatal("%s", msg.c_str()); else if(level == "Error") Message::Error("%s", msg.c_str()); else if(level == "Warning") Message::Warning("%s", msg.c_str()); else Message::Info("%s", msg.c_str()); } }; #endif static void Free_GlobalVariables() { Flag_PRE = 0; Flag_CAL = 0; Flag_POS = 0; Flag_RESTART = 0; Flag_XDATA = 0; Flag_BIN = 0; Flag_SPLIT = 0; Flag_GMSH_VERSION = 1; Flag_NETWORK_CACHE = 0; Flag_ORDER = -1.; Free(Name_Generic); Name_Generic = 0; Free(Name_Path); Name_Path = 0; Free(Name_Resolution); Name_Resolution = 0; Free(Name_MshFile); Name_MshFile = 0; Free(Name_AdaptFile); Name_AdaptFile = 0; int i = 0; while(Name_PostOperation[i]){ Free(Name_PostOperation[i]); Name_PostOperation[i] = 0; i++; } i = 0; while(Name_ResFile[i]){ Free(Name_ResFile[i]); Name_ResFile[i] = 0; i++; } i = 0; while(Name_GmshReadFile[i]){ Free(Name_GmshReadFile[i]); Name_GmshReadFile[i] = 0; i++; } Free_ProblemStructure(); Free_ParserVariables(); } int MainLegacy(int argc, char *argv[]) { if(argc < 2) Info(0, argv[0]); std::string cmdline(""); for(int i = 0; i < argc; i++){ if(i) cmdline += " "; cmdline += argv[i]; } Message::Initialize(argc, argv); char pro[256]; char **sargv = (char**)Malloc(256 * sizeof(char*)); int sargc, lres = 0, lpos = 0, check = 0; Get_Options(argc, argv, &sargc, sargv, pro, &lres, &lpos, &check); if(Message::GetErrorCount()){ Message::Finalize(); return Message::GetErrorCount(); } Message::Info("Running '%s' [GetDP %s, %d node%s]", cmdline.c_str(), GETDP_VERSION, Message::GetCommSize(), Message::GetCommSize() > 1 ? "s" : ""); Message::Cpu(3, "Started"); if(sargc > 1){ std::string solveropt(""); for(int i = 1; i < sargc; i++){ if(i > 1) solveropt += " "; solveropt += sargv[i]; } Message::Debug("Passing unused options to solver: '%s'", solveropt.c_str()); } if(!Name_ResFile[0]){ Name_ResFile[0] = (char*)Malloc((strlen(Name_Generic)+5)*sizeof(char)); strcpy(Name_ResFile[0], Name_Generic); strcat(Name_ResFile[0], ".res"); Name_ResFile[1] = 0; } if(!Name_MshFile){ Message::GetOnelabString("Gmsh/MshFileName", &Name_MshFile); if(Name_MshFile) Message::Info("Got mesh name from Onelab: '%s'", Name_MshFile); } if(!Name_MshFile){ Name_MshFile = (char*)Malloc((strlen(Name_Generic)+5)*sizeof(char)); strcpy(Name_MshFile, Name_Generic); strcat(Name_MshFile, ".msh"); } #if defined(HAVE_GMSH) Message::Info("Initializing Gmsh"); GmshInitialize(); if(!GmshGetMessageHandler()){ // do not set msg handler if one is provided (e.g. on Android/iOS) GmshMsg c; GmshSetMessageHandler(&c); } int j = 0; while(Name_GmshReadFile[j]){ GmshMergePostProcessingFile(Name_GmshReadFile[j]); j++; } #endif IncreaseStackSize(); LinAlg_InitializeSolver(&sargc, &sargv); Init_ProblemStructure(); Read_ProblemStructure(pro); Finalize_ProblemStructure(); int choose = 1; if (!Flag_PRE && !Flag_CAL && !Flag_POS && !check){ lres = lpos = 1; choose = 0; } if(check) Print_ProblemStructure(); if(lres) Print_ListResolution(choose, lres, &Name_Resolution); if(lpos) Print_ListPostOperation(choose, lpos, Name_PostOperation); if(Flag_PRE || Flag_CAL || Flag_POS) SolvingAnalyse(); LinAlg_FinalizeSolver(); Message::PrintErrorCounter("Run"); Message::Cpu(3, "Stopped"); #if defined(HAVE_GMSH) GmshFinalize(); #endif Free_GlobalVariables(); Free(sargv); Message::Finalize(); return Message::GetErrorCount(); } int GetDP(std::vector &args, void *ptr) { onelab::server *onelabServer = (onelab::server*) ptr; if(onelabServer != NULL) onelab::server::setInstance(onelabServer); int argc = args.size(); std::vector argv(argc + 1, (char*)0); for(int i = 0; i < argc; i++) argv[i] = (char*)args[i].c_str(); return MainLegacy(argc, &argv[0]); } getdp-2.4.2-source/Legacy/Gauss_Pyramid.h000644 001750 001750 00000002271 12116424202 021720 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . /* 8 integration points from Coulomb et al., IEEE tr.mag. 32(3) May 1996, p.1395 2 plans // a la base quadrangulaire, 4 points par plan suffisant pour integrer exactement nodal degre 2 cf. ../utils/pyram.c */ static double upyr8[8] = {0.2631840555694285,-0.2631840555694285, 0.2631840555694285,-0.2631840555694285, 0.5066163033492386,-0.5066163033492386, 0.5066163033492386,-0.5066163033492386}; static double vpyr8[8] = {0.2631840555694285,0.2631840555694285, -0.2631840555694285,-0.2631840555694285, 0.5066163033492386,0.5066163033492386, -0.5066163033492386,-0.5066163033492386}; static double wpyr8[8] = {0.544151844011225,0.544151844011225, 0.544151844011225,0.544151844011225, 0.122514822655441,0.122514822655441, 0.122514822655441,0.122514822655441}; static double ppyr8[8] = {0.100785882079825,0.100785882079825, 0.100785882079825,0.100785882079825, 0.232547451253508,0.232547451253508, 0.232547451253508,0.232547451253508}; getdp-2.4.2-source/Legacy/BF_GroupOfEntities.cpp000644 001750 001750 00000034522 12116424202 023145 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "ProData.h" #include "BF.h" #include "Get_Geometry.h" #define ARGS \ struct Element * Element, int NumGroup, \ double u, double v, double w, double *s void BF_SubFunction(struct Element * Element, int NumExpression, int Dim, double s[]); /* ------------------------------------------------------------------------ */ /* B F _ G r o u p O f N o d e s */ /* ------------------------------------------------------------------------ */ #define BF(BF_GroupOfNodes_X,BF_Node_X) \ int i ; \ double val ; \ \ *s = 0. ; \ for (i = 0; i < Element->NbrEntitiesInGroups[NumGroup-1]; i++) { \ (BF_Node_X) \ (Element, Element->NumEntitiesInGroups[NumGroup-1][i], u, v, w, &val) ; \ *s += val ; \ } \ \ if (Element->NumSubFunction[0][NumGroup-1] >= 0) \ BF_SubFunction(Element, Element->NumSubFunction[0][NumGroup-1], 1, s) ; void BF_GroupOfNodes(ARGS) { BF("BF_GroupOfNodes",BF_Node) ; } void BF_GroupOfNodes_2E(ARGS) { BF("BF_GroupOfNodes_2E",BF_Node_2E) ; } void BF_GroupOfNodes_2F(ARGS) { BF("BF_GroupOfNodes_2F",BF_Node_2F) ; } void BF_GroupOfNodes_2V(ARGS) { BF("BF_GroupOfNodes_2V",BF_Node_2V) ; } void BF_GroupOfNodes_3E(ARGS) { BF("BF_GroupOfNodes_3E",BF_Node_3E) ; } void BF_GroupOfNodes_3F(ARGS) { BF("BF_GroupOfNodes_3F",BF_Node_3F) ; } void BF_GroupOfNodes_3V(ARGS) { BF("BF_GroupOfNodes_3V",BF_Node_3V) ; } #undef BF /* ------------------------------------------------------------------------ */ /* B F _ G r a d G r o u p O f N o d e s */ /* ------------------------------------------------------------------------ */ #define BF(BF_GradGroupOfNodes_X,BF_GradNode_X) \ int i ; \ double val[3] ; \ \ s[0] = s[1] = s[2] = 0. ; \ for (i = 0; i < Element->NbrEntitiesInGroups[NumGroup-1]; i++) { \ (BF_GradNode_X) \ (Element, Element->NumEntitiesInGroups[NumGroup-1][i], u, v, w, val) ; \ s[0] += val[0] ; s[1] += val[1] ; s[2] += val[2] ; \ } \ \ if (Element->NumSubFunction[0][NumGroup-1] >= 0) \ BF_SubFunction(Element, Element->NumSubFunction[0][NumGroup-1], 3, s) ; void BF_GradGroupOfNodes (ARGS) { BF("BF_GradGroupOfNodes",BF_GradNode) ; } void BF_GradGroupOfNodes_2E(ARGS) { BF("BF_GradGroupOfNodes_2E",BF_GradNode_2E) ; } void BF_GradGroupOfNodes_2F(ARGS) { BF("BF_GradGroupOfNodes_2F",BF_GradNode_2F) ; } void BF_GradGroupOfNodes_2V(ARGS) { BF("BF_GradGroupOfNodes_2V",BF_GradNode_2V) ; } void BF_GradGroupOfNodes_3E(ARGS) { BF("BF_GradGroupOfNodes_3E",BF_GradNode_3E) ; } void BF_GradGroupOfNodes_3F(ARGS) { BF("BF_GradGroupOfNodes_3F",BF_GradNode_3F) ; } void BF_GradGroupOfNodes_3V(ARGS) { BF("BF_GradGroupOfNodes_3V",BF_GradNode_3V) ; } #undef BF /* ------------------------------------------------------------------------ */ /* B F _ G r o u p O f P e r p e n d i c u l a r E d g e s */ /* ------------------------------------------------------------------------ */ #define BF(BF_GroupOfPerpendicularEdges_X,BF_Node_X) \ int i ; \ double val ; \ \ s[0] = s[1] = s[2] = 0. ; \ for (i = 0; i < Element->NbrEntitiesInGroups[NumGroup-1]; i++) { \ (BF_Node_X) \ (Element, Element->NumEntitiesInGroups[NumGroup-1][i], u, v, w, &val) ; \ s[2] += val ; \ } \ \ if (Element->NumSubFunction[0][NumGroup-1] >= 0) \ BF_SubFunction(Element, Element->NumSubFunction[0][NumGroup-1], 3, s) ; void BF_GroupOfPerpendicularEdges (ARGS){ BF("BF_GroupOfPerpendicularEdges",BF_Node) ; } void BF_GroupOfPerpendicularEdges_2E(ARGS){ BF("BF_GroupOfPerpendicularEdges_2E",BF_Node_2E) ; } void BF_GroupOfPerpendicularEdges_2F(ARGS){ BF("BF_GroupOfPerpendicularEdges_2F",BF_Node_2F) ; } void BF_GroupOfPerpendicularEdges_2V(ARGS){ BF("BF_GroupOfPerpendicularEdges_2V",BF_Node_2V) ; } void BF_GroupOfPerpendicularEdges_3E(ARGS){ BF("BF_GroupOfPerpendicularEdges_3E",BF_Node_3E) ; } void BF_GroupOfPerpendicularEdges_3F(ARGS){ BF("BF_GroupOfPerpendicularEdges_3F",BF_Node_3F) ; } void BF_GroupOfPerpendicularEdges_3V(ARGS){ BF("BF_GroupOfPerpendicularEdges_3V",BF_Node_3V) ; } #undef BF /* ------------------------------------------------------------------------ */ /* B F _ C u r l G r o u p O f P e r p e n d i c u l a r E d g e s */ /* ------------------------------------------------------------------------ */ #define BF(BF_CurlGroupOfPerpendicularEdges_X,BF_GradNode_X) \ int i ; \ double val[3] ; \ \ s[0] = s[1] = s[2] = 0. ; \ for (i = 0; i < Element->NbrEntitiesInGroups[NumGroup-1]; i++) { \ (BF_GradNode_X) \ (Element, Element->NumEntitiesInGroups[NumGroup-1][i], u, v, w, val) ; \ s[0] += val[1] ; s[1] += -val[0] ; \ } \ \ if (Element->NumSubFunction[0][NumGroup-1] >= 0) \ BF_SubFunction(Element, Element->NumSubFunction[0][NumGroup-1], 3, s) ; void BF_CurlGroupOfPerpendicularEdges (ARGS){ BF("BF_CurlGroupOfPerpendicularEdges",BF_GradNode) ; } void BF_CurlGroupOfPerpendicularEdges_2E(ARGS){ BF("BF_CurlGroupOfPerpendicularEdges_2E",BF_GradNode_2E) ; } void BF_CurlGroupOfPerpendicularEdges_2F(ARGS){ BF("BF_CurlGroupOfPerpendicularEdges_2F",BF_GradNode_2F) ; } void BF_CurlGroupOfPerpendicularEdges_2V(ARGS){ BF("BF_CurlGroupOfPerpendicularEdges_2V",BF_GradNode_2V) ; } void BF_CurlGroupOfPerpendicularEdges_3E(ARGS){ BF("BF_CurlGroupOfPerpendicularEdges_3E",BF_GradNode_3E) ; } void BF_CurlGroupOfPerpendicularEdges_3F(ARGS){ BF("BF_CurlGroupOfPerpendicularEdges_3F",BF_GradNode_3F) ; } void BF_CurlGroupOfPerpendicularEdges_3V(ARGS){ BF("BF_CurlGroupOfPerpendicularEdges_3V",BF_GradNode_3V) ; } #undef BF /* ------------------------------------------------------------------------ */ /* B F _ G r o u p O f E d g e s */ /* ------------------------------------------------------------------------ */ #define BF(BF_GroupOfEdges_X,BF_Edge_X) \ int i, Num ; \ double val[3] ; \ \ s[0] = s[1] = s[2] = 0. ; \ for (i = 0; i < Element->NbrEntitiesInGroups[NumGroup-1]; i++) { \ (BF_Edge_X) \ (Element, abs(Num = Element->NumEntitiesInGroups[NumGroup-1][i]), \ u, v, w, val) ; \ if (Num > 0) { s[0] += val[0] ; s[1] += val[1] ; s[2] += val[2] ; } \ else { s[0] -= val[0] ; s[1] -= val[1] ; s[2] -= val[2] ; } \ } void BF_GroupOfEdges (ARGS){ BF("BF_GroupOfEdges",BF_Edge) ; } void BF_GroupOfEdges_2E(ARGS){ BF("BF_GroupOfEdges_2E",BF_Edge_2E) ; } void BF_GroupOfEdges_2F(ARGS){ BF("BF_GroupOfEdges_2F",BF_Edge_2F) ; } void BF_GroupOfEdges_2V(ARGS){ BF("BF_GroupOfEdges_2V",BF_Edge_2V) ; } void BF_GroupOfEdges_3E(ARGS){ BF("BF_GroupOfEdges",BF_Edge_3E) ; } void BF_GroupOfEdges_3F_a(ARGS){ BF("BF_GroupOfEdges_3F_a",BF_Edge_3F_a) ; } void BF_GroupOfEdges_3F_b(ARGS){ BF("BF_GroupOfEdges_3F_b", BF_Edge_3F_b) ; } void BF_GroupOfEdges_3F_c(ARGS){ BF("BF_GroupOfEdges_3F_c", BF_Edge_3F_c) ; } void BF_GroupOfEdges_3V(ARGS){ BF("BF_GroupOfEdges_3V",BF_Edge_3V) ; } void BF_GroupOfEdges_4E(ARGS){ BF("BF_GroupOfEdges_4E",BF_Edge_4E) ; } void BF_GroupOfEdges_4F(ARGS){ BF("BF_GroupOfEdges_4F",BF_Edge_4F) ; } void BF_GroupOfEdges_4V(ARGS){ BF("BF_GroupOfEdges_4V",BF_Edge_4V) ; } #undef BF /* ------------------------------------------------------------------------ */ /* B F _ C u r l G r o u p O f E d g e s */ /* ------------------------------------------------------------------------ */ #define BF(BF_CurlGroupOfEdges_X,BF_CurlEdge_X) \ int i, Num ; \ double val[3] ; \ \ s[0] = s[1] = s[2] = 0. ; \ for (i = 0; i < Element->NbrEntitiesInGroups[NumGroup-1]; i++) { \ (BF_CurlEdge_X) \ (Element, abs(Num = Element->NumEntitiesInGroups[NumGroup-1][i]), \ u, v, w, val) ; \ if (Num > 0) { s[0] += val[0] ; s[1] += val[1] ; s[2] += val[2] ; } \ else { s[0] -= val[0] ; s[1] -= val[1] ; s[2] -= val[2] ; } \ } void BF_CurlGroupOfEdges(ARGS){ BF("BF_CurlGroupOfEdges",BF_CurlEdge) ; } void BF_CurlGroupOfEdges_2E(ARGS){ BF("BF_CurlGroupOfEdges_2E",BF_CurlEdge_2E) ; } void BF_CurlGroupOfEdges_2F(ARGS){ BF("BF_CurlGroupOfEdges_2F",BF_CurlEdge_2F) ; } void BF_CurlGroupOfEdges_2V(ARGS){ BF("BF_CurlGroupOfEdges_2V",BF_CurlEdge_2V) ; } void BF_CurlGroupOfEdges_3E(ARGS){ BF("BF_CurlGroupOfEdges_3E",BF_CurlEdge_3E) ; } void BF_CurlGroupOfEdges_3F_a(ARGS){ BF("BF_CurlGroupOfEdges_3F_a",BF_CurlEdge_3F_a) ; } void BF_CurlGroupOfEdges_3F_b(ARGS){ BF("BF_CurlGroupOfEdges_3F_b",BF_CurlEdge_3F_b) ; } void BF_CurlGroupOfEdges_3F_c(ARGS){ BF("BF_CurlGroupOfEdges_3F_c",BF_CurlEdge_3F_c) ; } void BF_CurlGroupOfEdges_3V(ARGS){ BF("BF_CurlGroupOfEdges_3V",BF_CurlEdge_3V) ; } void BF_CurlGroupOfEdges_4E(ARGS){ BF("BF_CurlGroupOfEdges_4E",BF_CurlEdge_4E) ; } void BF_CurlGroupOfEdges_4F(ARGS){ BF("BF_CurlGroupOfEdges_4F",BF_CurlEdge_4F) ; } void BF_CurlGroupOfEdges_4V(ARGS){ BF("BF_CurlGroupOfEdges_4V",BF_CurlEdge_4V) ; } #undef BF /* ------------------------------------------------------------------------ */ /* B F _ G r o u p O f F a c e t s */ /* ------------------------------------------------------------------------ */ #define BF(BF_GroupOfFacets_X,BF_Facet_X) \ int i, Num ; \ double val[3] ; \ \ s[0] = s[1] = s[2] = 0. ; \ for (i = 0; i < Element->NbrEntitiesInGroups[NumGroup-1]; i++) { \ (BF_Facet_X) \ (Element, abs(Num = Element->NumEntitiesInGroups[NumGroup-1][i]), \ u, v, w, val) ; \ if (Num > 0) { s[0] += val[0] ; s[1] += val[1] ; s[2] += val[2] ; } \ else { s[0] -= val[0] ; s[1] -= val[1] ; s[2] -= val[2] ; } \ } void BF_GroupOfFacets (ARGS){ BF("BF_GroupOfFacets",BF_Facet) ; } #undef BF /* ------------------------------------------------------------------------ */ /* B F _ D i v G r o u p O f F a c e t s */ /* ------------------------------------------------------------------------ */ #define BF(BF_DivGroupOfFacets_X,BF_DivFacet_X) \ int i, Num ; \ double val ; \ \ *s = 0. ; \ for (i = 0; i < Element->NbrEntitiesInGroups[NumGroup-1]; i++) { \ (BF_DivFacet_X) \ (Element, abs(Num = Element->NumEntitiesInGroups[NumGroup-1][i]), \ u, v, w, &val) ; \ if (Num > 0) { *s += val ; } \ else { *s -= val ; } \ } void BF_DivGroupOfFacets(ARGS){ BF("BF_DivGroupOfFacets",BF_DivFacet) ; } #undef BF /* ------------------------------------------------------------------------ */ /* B F _ G r o u p O f N o d e s X , Y , Z */ /* ------------------------------------------------------------------------ */ void BF_GroupOfNodesX(struct Element * Element, int NumGroup, double u, double v, double w, double s[]) { s[1] = s[2] = 0. ; BF_GroupOfNodes(Element, NumGroup, u, v, w, &s[0]) ; } void BF_GroupOfNodesY(struct Element * Element, int NumGroup, double u, double v, double w, double s[]) { s[0] = s[2] = 0. ; BF_GroupOfNodes(Element, NumGroup, u, v, w, &s[1]) ; } void BF_GroupOfNodesZ(struct Element * Element, int NumGroup, double u, double v, double w, double s[]) { s[0] = s[1] = 0. ; BF_GroupOfNodes(Element, NumGroup, u, v, w, &s[2]) ; } /* ------------------------------------------------------------------------ */ /* B F _ G r o u p O f N o d e X , Y , Z _ D . . . */ /* ------------------------------------------------------------------------ */ void BF_GroupOfNodesX_D12(struct Element * Element, int NumNode, double u, double v, double w, double s[]) { double su[3] ; BF_GradGroupOfNodes(Element, NumNode, u, v, w, su) ; ChangeOfCoord_Form1(Element, su, s) ; s[2] = s[1] ; s[1] = 0. ; } void BF_GroupOfNodesY_D12(struct Element * Element, int NumNode, double u, double v, double w, double s[]) { double su[3] ; BF_GradGroupOfNodes(Element, NumNode, u, v, w, su) ; ChangeOfCoord_Form1(Element, su, s) ; s[2] = s[0] ; s[0] = 0. ; } void BF_GroupOfNodesZ_D12(struct Element * Element, int NumNode, double u, double v, double w, double s[]) { s[0] = s[1] = s[2] = 0. ; } /* ------------------------------------------------------------------------ */ void BF_GroupOfNodesX_D1(struct Element * Element, int NumNode, double u, double v, double w, double s[]) { double su[3] ; BF_GradGroupOfNodes(Element, NumNode, u, v, w, su) ; ChangeOfCoord_Form1(Element, su, s) ; s[1] = s[2] = 0; } void BF_GroupOfNodesY_D1(struct Element * Element, int NumNode, double u, double v, double w, double s[]) { double su[3] ; BF_GradGroupOfNodes(Element, NumNode, u, v, w, su) ; ChangeOfCoord_Form1(Element, su, s) ; s[0] = s[2] = 0; } void BF_GroupOfNodesZ_D1(struct Element * Element, int NumNode, double u, double v, double w, double s[]) { double su[3] ; BF_GradGroupOfNodes(Element, NumNode, u, v, w, su) ; ChangeOfCoord_Form1(Element, su, s) ; s[0] = s[1] = 0; } /* ------------------------------------------------------------------------ */ void BF_GroupOfNodesX_D2(struct Element * Element, int NumNode, double u, double v, double w, double s[]) { double su[3] ; BF_GradGroupOfNodes(Element, NumNode, u, v, w, su) ; ChangeOfCoord_Form1(Element, su, s) ; s[0] = s[1] ; s[1] = 0 ; } void BF_GroupOfNodesY_D2(struct Element * Element, int NumNode, double u, double v, double w, double s[]) { double su[3] ; BF_GradGroupOfNodes(Element, NumNode, u, v, w, su) ; ChangeOfCoord_Form1(Element, su, s) ; s[1] = s[2] ; s[2] = 0 ; } void BF_GroupOfNodesZ_D2(struct Element * Element, int NumNode, double u, double v, double w, double s[]) { double su[3] ; BF_GradGroupOfNodes(Element, NumNode, u, v, w, su) ; ChangeOfCoord_Form1(Element, su, s) ; s[2] = s[0] ; s[0] = 0 ; } getdp-2.4.2-source/Legacy/Pos_Format.h000644 001750 001750 00000001776 12116424202 021233 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _POS_FORMAT_H_ #define _POS_FORMAT_H_ #include "ProData.h" #include "ListUtils.h" void Format_PostFormat(struct PostSubOperation * PSO_P) ; void Format_PostHeader(struct PostSubOperation * PSO_P, int NbTimeStep, int Order, char *Name1, char *Name2) ; void Format_PostFooter(struct PostSubOperation * PSO_P, int Store) ; void Format_PostElement(struct PostSubOperation * PSO_P, int Contour, int Store, double Time, int TimeStep, int NbTimeStep, int NbrHarmonics, int HarmonicToTime, double *Dummy, struct PostElement *PE); void Format_PostValue(int Format, int Flag_Comma, int Group_FunctionType, double Time, int iRegion, int numRegion, int NbrRegion, int NbrHarmonics, int HarmonicToTime, int Flag_NoNewLine, struct Value * Value) ; #endif getdp-2.4.2-source/Legacy/Cal_Quantity.cpp000644 001750 001750 00000104677 12221300353 022113 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include "ProData.h" #include "GeoData.h" #include "DofData.h" #include "F.h" #include "Cal_Quantity.h" #include "Cal_Value.h" #include "Get_Geometry.h" #include "Pos_FemInterpolation.h" #include "Pos_Search.h" #include "Get_FunctionValue.h" #include "MallocUtils.h" #include "Message.h" extern struct Problem Problem_S ; extern struct CurrentData Current ; extern int TreatmentStatus ; /* ------------------------------------------------------------------------ */ /* G e t _ V a l u e O f E x p r e s s i o n */ /* ------------------------------------------------------------------------ */ void Get_ValueOfExpression(struct Expression * Expression_P, struct QuantityStorage * QuantityStorage_P0, double u, double v, double w, struct Value * Value, int NbrArguments) { int k ; struct ExpressionPerRegion * ExpressionPerRegion_P ; static char *Flag_WarningUndefined = NULL ; switch (Expression_P->Type) { case CONSTANT : if (Current.NbrHar == 1) { Value->Val[0] = Expression_P->Case.Constant ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { Value->Val[MAX_DIM* k ] = Expression_P->Case.Constant ; Value->Val[MAX_DIM*(k+1)] = 0. ; } } Value->Type = SCALAR ; break ; case WHOLEQUANTITY : Cal_WholeQuantity(Current.Element, QuantityStorage_P0, Expression_P->Case.WholeQuantity, u,v,w, -1, 0, Value, NbrArguments, Expression_P->Name) ; break ; case PIECEWISEFUNCTION : if (Current.Region != Expression_P->Case.PieceWiseFunction.NumLastRegion) { if ((ExpressionPerRegion_P = (struct ExpressionPerRegion*) List_PQuery(Expression_P->Case.PieceWiseFunction.ExpressionPerRegion, &Current.Region, fcmp_int))) { Expression_P->Case.PieceWiseFunction.NumLastRegion = Current.Region ; Expression_P->Case.PieceWiseFunction.ExpressionForLastRegion = (struct Expression*)List_Pointer(Problem_S.Expression, ExpressionPerRegion_P->ExpressionIndex) ; } else { if(Current.Region == NO_REGION) Message::Error("Function '%s' undefined in expressions without support", Expression_P->Name); else Message::Error("Function '%s' undefined in Region %d", Expression_P->Name, Current.Region); } } Get_ValueOfExpression (Expression_P->Case.PieceWiseFunction.ExpressionForLastRegion, QuantityStorage_P0, u, v, w, Value, NbrArguments) ; break ; case UNDEFINED_EXP : if(!Flag_WarningUndefined || strcmp(Flag_WarningUndefined, Expression_P->Name)){ Message::Warning("Undefined expression '%s' (assuming zero)", Expression_P->Name) ; Flag_WarningUndefined = Expression_P->Name; } Cal_ZeroValue(Value); Value->Type = SCALAR ; break; default : Message::Error("Unknown type (%d) of Expression (%s)", Expression_P->Type, Expression_P->Name) ; break; } } /* ------------------------------------------------------------------------ */ /* G e t _ V a l u e O f E x p r e s s i o n B y I n d e x */ /* ------------------------------------------------------------------------ */ void Get_ValueOfExpressionByIndex(int Index_Expression, struct QuantityStorage * QuantityStorage_P0, double u, double v, double w, struct Value * Value) { Get_ValueOfExpression ((struct Expression *)List_Pointer(Problem_S.Expression, Index_Expression), QuantityStorage_P0, u, v, w, Value) ; } /* ------------------------------------------------------------------------ */ /* C a l _ S o l i d A n g l e */ /* ------------------------------------------------------------------------ */ void Cal_SolidAngle(int Source, struct Element *Element, struct QuantityStorage *QuantityStorage, int Nbr_Dof, int Index, struct Value **Stack) { struct Element *Elt ; struct Geo_Element *GeoElement ; struct Geo_Node *GeoNode1, *GeoNode2, *GeoNode3 ; double X, Y, Atan ; int In, TypEnt, NumNode, NbrElements, *NumElements ; int i, j ; if(Nbr_Dof != QuantityStorage->NbrElementaryBasisFunction){ Message::Error("Uncompatible Quantity (%s) in SolidAngle computation", QuantityStorage->DefineQuantity->Name); return; } if(Source){ Elt = Element->ElementSource ; In = Current.SourceIntegrationSupportIndex ; } else{ Elt = Element ; In = Current.IntegrationSupportIndex ; } if (Elt->NumLastElementForSolidAngle == Elt->Num) { for(i=0 ; iangle[i] ; } return; } for(i=0 ; iBasisFunction[i]. BasisFunction->EntityIndex))->FunctionType ; if(TypEnt != NODESOF){ if(Elt->Type == LINE){ Stack[i][Index].Val[0] = M_PI ; } else{ Stack[i][Index].Val[0] = 2.*M_PI ; } } else{ NumNode = Elt->GeoElement-> NumNodes[QuantityStorage->BasisFunction[i].NumEntityInElement] ; Geo_CreateNodesXElements(NumNode, In, &NbrElements, &NumElements) ; if(NbrElements != 2){ Message::Error("SolidAngle not done for incidence != 2 (%d)", NbrElements); return; } GeoNode2 = Geo_GetGeoNodeOfNum(NumNode) ; GeoElement = Geo_GetGeoElementOfNum(abs(NumElements[0])) ; if(GeoElement->Type != LINE){ Message::Error("SolidAngle not done for Elements other than LINE"); return; } if(NumElements[0]>0){ GeoNode1 = Geo_GetGeoNodeOfNum(GeoElement->NumNodes[0]) ; GeoElement = Geo_GetGeoElementOfNum(abs(NumElements[1])) ; GeoNode3 = Geo_GetGeoNodeOfNum(GeoElement->NumNodes[1]) ; } else{ GeoNode3 = Geo_GetGeoNodeOfNum(GeoElement->NumNodes[1]) ; GeoElement = Geo_GetGeoElementOfNum(NumElements[1]) ; GeoNode1 = Geo_GetGeoNodeOfNum(GeoElement->NumNodes[0]) ; } Y = (GeoNode1->y - GeoNode2->y) * (GeoNode3->x - GeoNode2->x) - (GeoNode1->x - GeoNode2->x) * (GeoNode3->y - GeoNode2->y) ; X = (GeoNode1->x - GeoNode2->x) * (GeoNode3->x - GeoNode2->x) + (GeoNode1->y - GeoNode2->y) * (GeoNode3->y - GeoNode2->y) ; Atan = atan2(Y,X) ; Stack[i][Index].Val[0] = (Atan >= 0) ? Atan : (Atan+2.*M_PI) ; if(Message::GetVerbosity() > 5){ printf("Solid angle=%g node=%d, region=%s, elms=", Stack[i][Index].Val[0] * 180/M_PI, NumNode, ((struct Group*)List_Pointer(Problem_S.Group, In))->Name); for(j=0 ; jNumLastElementForSolidAngle != Elt->Num) { Elt->NumLastElementForSolidAngle = Elt->Num ; for(i=0 ; iangle[i] = Stack[i][Index].Val[0] ; } } /* ------------------------------------------------------------------------ */ /* C a l _ W h o l e Q u a n t i t y */ /* ------------------------------------------------------------------------ */ #define MAX_REGISTER_SIZE 100 #define CAST3V void(*)(struct Value*, struct Value*, struct Value*) #define CAST1V void(*)(struct Value*) #define CASTF2V void(*)(struct Function*, struct Value*, struct Value*) /* There can be at max one "Dof{op qty}" per WholeQuantity, but as many {op qty} as you want. Note that Stack[8][MAX_STACK_SIZE] should actually be Stack[NBR_MAX_BASISFUNCTION][MAX_STACK_SIZE]. But this tends to overflow the stack when we don't use USE_GLOBAL_STACK. Also, 8 is OK since the 'multi' feature is only used for SolidAngle computations at the moment. A better solution would be to build a single stack (instead of 8 stacks), where a Value could be multiple. But this requires to change the way we deal with function arguments. */ static struct Value ValueSaved[MAX_REGISTER_SIZE] ; void Cal_WholeQuantity(struct Element * Element, struct QuantityStorage * QuantityStorage_P0, List_T * WholeQuantity_L, double u, double v, double w, int DofIndexInWholeQuantity, int Nbr_Dof, struct Value DofValue[], int NbrArguments, char *ExpressionName) { static int Flag_WarningMissSolForDt = 0 ; static int Flag_WarningMissSolForTime_ntime = 0 ; static int Flag_InfoForTime_ntime = 0 ; int i_WQ, j, k, Flag_True, Index, DofIndex, Multi[MAX_STACK_SIZE] ; int Save_NbrHar, Save_Region, Type_Dimension, ntime ; double Save_Time, Save_TimeImag, Save_TimeStep, X, Y, Z, Order ; double Save_x, Save_y, Save_z ; struct WholeQuantity *WholeQuantity_P0, *WholeQuantity_P ; struct DofData *Save_DofData ; struct Solution *Solution_P0, *Solution_PN ; struct Element* Save_CurrentElement ; //#define USE_GLOBAL_STACK #if defined(USE_GLOBAL_STACK) /* Use a single global (static) stack for all quantity evaluations. Stack size = MAX_RECURSION * MAX_STACK_SIZE * 8 * sizeof(struct Value) = 50 * 40 * 8 * (MAX_DIM * NBR_MAX_HARMONIC * sizeof(double)) = 50 * 40 * 8 * (9 * 2 * 8) ~= 2 Mb Beware that for NBR_MAX_HARMONIC=40, the size would grow to 40Mb... So let's define MAX_RECURSION as follows : */ #if NBR_MAX_HARMONIC <= 10 #define MAX_RECURSION 50 #else #define MAX_RECURSION 10 #endif /* We need MAX_RECURSION sufficiently large for expressions like (a?b:(c?d:(e?...))) with all n= MAX_RECURSION){ Message::Error("Recursion problem in Cal_WholeQuantity (%d outside [0,%d])", RecursionIndex, MAX_RECURSION); return; } Stack = StaticStack[RecursionIndex]; #endif WholeQuantity_P0 = (struct WholeQuantity*)List_Pointer(WholeQuantity_L, 0) ; Index = 0 ; DofIndex = -1 ; for (i_WQ = 0 ; i_WQ < List_Nbr(WholeQuantity_L) ; i_WQ++) { if(Index >= MAX_STACK_SIZE){ Message::Error("Stack size exceeded (%d)", MAX_STACK_SIZE); return; } WholeQuantity_P = WholeQuantity_P0 + i_WQ ; switch (WholeQuantity_P->Type) { case WQ_OPERATORANDQUANTITY : /* {op qty} Dof{op qty} BF{op qty} */ Save_Region = Current.Region ; Save_CurrentElement = Current.Element ; if (i_WQ != DofIndexInWholeQuantity){ /* Attention!!! || TreatmentStatus == _POS){ */ Pos_FemInterpolation (Element, QuantityStorage_P0, QuantityStorage_P0 + WholeQuantity_P->Case.OperatorAndQuantity.Index, WholeQuantity_P->Case.OperatorAndQuantity.TypeQuantity, WholeQuantity_P->Case.OperatorAndQuantity.TypeOperator, -1, 0, u, v, w, 0, 0, 0, Stack[0][Index].Val, &Stack[0][Index].Type, 1) ; Multi[Index] = 0 ; } else { DofIndex = Index ; } Index++ ; Current.Element = Save_CurrentElement ; Current.Region = Save_Region ; break ; case WQ_ORDER : /* Order[{qty}] */ Order = Cal_InterpolationOrder (Element, QuantityStorage_P0 + WholeQuantity_P->Case.OperatorAndQuantity.Index) ; for (k = 0 ; k < Current.NbrHar ; k += 2) { Stack[0][Index].Val[MAX_DIM* k ] = Order ; Stack[0][Index].Val[MAX_DIM*(k+1)] = 0. ; } Stack[0][Index].Type = SCALAR ; Multi[Index] = 0 ; Index++ ; break ; case WQ_OPERATORANDQUANTITYEVAL : Save_Region = Current.Region ; Save_CurrentElement = Current.Element ; /* {op qty}[x,y,z], {op qty}[x,y,z,dimension] or {op qty}[Vector[x,y,x],dimension] or {op qty}[ntime] */ if (i_WQ != DofIndexInWholeQuantity || TreatmentStatus == _POS){ j = WholeQuantity_P->Case.OperatorAndQuantity.NbrArguments; if (j == 2 || j == 3 || j == 4) { if (j == 3 || j == 4) { Index -= j ; X = Stack[0][Index ].Val[0] ; Y = Stack[0][Index+1].Val[0] ; Z = Stack[0][Index+2].Val[0] ; if(j == 4) Type_Dimension = (int)Stack[0][Index+3].Val[0] ; else Type_Dimension = -1 ; } else { /* j==2 */ Index -= j ; X = Stack[0][Index ].Val[0] ; Y = Stack[0][Index ].Val[1] ; Z = Stack[0][Index ].Val[2] ; Type_Dimension = (int)Stack[0][Index+1].Val[0] ; } Pos_FemInterpolation (Element, QuantityStorage_P0, QuantityStorage_P0 + WholeQuantity_P->Case.OperatorAndQuantity.Index, WholeQuantity_P->Case.OperatorAndQuantity.TypeQuantity, WholeQuantity_P->Case.OperatorAndQuantity.TypeOperator, Type_Dimension, 1, u, v, w, X, Y, Z, Stack[0][Index].Val, &Stack[0][Index].Type, 1) ; Multi[Index] = 0 ; Index++ ; } else if (j == 1) { Index -= j ; ntime = (int)Stack[0][Index].Val[0] ; for (k = 0 ; k < Current.NbrSystem ; k++){ Solution_P0 = (struct Solution*)List_Pointer((Current.DofData_P0+k)->Solutions, 0); if(((Current.DofData_P0+k)->CurrentSolution - Solution_P0) >= ntime){ ((Current.DofData_P0+k)->CurrentSolution) -= ntime ; if (Flag_InfoForTime_ntime != List_Nbr((Current.DofData_P0+k)->Solutions)) { Message::Debug("Accessing solution from %d time steps ago", ntime); Message::Debug(" -> System %d/%d: TimeStep = %d, Time = %g + i * %g", k+1, Current.NbrSystem, (Current.DofData_P0+k)->CurrentSolution->TimeStep, (Current.DofData_P0+k)->CurrentSolution->Time, (Current.DofData_P0+k)->CurrentSolution->TimeImag); Flag_InfoForTime_ntime = List_Nbr((Current.DofData_P0+k)->Solutions); } } else { if (!Flag_WarningMissSolForTime_ntime) { Message::Warning("Missing solution for time step -%d computation (System #%d/%d)", ntime, k+1, Current.NbrSystem); Flag_WarningMissSolForTime_ntime = 1 ; } } } Pos_FemInterpolation (Element, QuantityStorage_P0, QuantityStorage_P0 + WholeQuantity_P->Case.OperatorAndQuantity.Index, WholeQuantity_P->Case.OperatorAndQuantity.TypeQuantity, WholeQuantity_P->Case.OperatorAndQuantity.TypeOperator, -1, 0, u, v, w, 0, 0, 0, Stack[0][Index].Val, &Stack[0][Index].Type, 1) ; Multi[Index] = 0 ; Index++ ; for (k = 0 ; k < Current.NbrSystem ; k++){ Solution_PN = (struct Solution*) List_Pointer((Current.DofData_P0+k)->Solutions, List_Nbr((Current.DofData_P0+k)->Solutions)-1); if((Solution_PN - (Current.DofData_P0+k)->CurrentSolution) >= ntime) ((Current.DofData_P0+k)->CurrentSolution) += ntime ; } } else Message::Error("Explicit (x,y,z,time) evaluation not implemented"); } else{ Message::Error("Explicit Dof{} evaluation out of context"); } Current.Element = Save_CurrentElement ; Current.Region = Save_Region ; break ; case WQ_TRACE : /* Trace[WholeQuantity, Group] */ Save_Region = Current.Region ; if(!Element->ElementTrace){ Message::Error("Trace must act on discrete quantity (and not in post-processing)"); break; } Current.Region = Element->ElementTrace->Region ; if(WholeQuantity_P->Case.Trace.DofIndexInWholeQuantity >= 0){ Cal_WholeQuantity(Element->ElementTrace, QuantityStorage_P0, WholeQuantity_P->Case.Trace.WholeQuantity, Current.ut, Current.vt, Current.wt, WholeQuantity_P->Case.Trace.DofIndexInWholeQuantity, Nbr_Dof, DofValue, NbrArguments, ExpressionName) ; DofIndexInWholeQuantity = DofIndex = Index ; } else{ Current.x = Current.y = Current.z = 0. ; for (j = 0 ; j < Element->GeoElement->NbrNodes ; j++) { Current.x += Element->x[j] * Element->n[j] ; Current.y += Element->y[j] * Element->n[j] ; Current.z += Element->z[j] * Element->n[j] ; } xyz2uvwInAnElement(Element->ElementTrace, Current.x, Current.y, Current.z, &Current.ut, &Current.vt, &Current.wt) ; for (j=0; jElementTrace, QuantityStorage_P0, WholeQuantity_P->Case.Trace.WholeQuantity, Current.ut, Current.vt, Current.wt, -1, 0, &Stack[0][Index], NbrArguments, ExpressionName) ; } Current.Region = Save_Region ; Multi[Index] = 0 ; Index++ ; break ; case WQ_SOLIDANGLE : /* SolidAngle[{qty}] */ Cal_SolidAngle(0, Element, QuantityStorage_P0 + WholeQuantity_P->Case.OperatorAndQuantity.Index, Nbr_Dof, Index, (struct Value **)Stack); Multi[Index] = 1 ; Index++ ; break ; case WQ_BINARYOPERATOR : /* + - * x / % ^ < > <= >= == != && || */ if (Index-2 != DofIndex && Index-1 != DofIndex){ if(!Multi[Index-1] && !Multi[Index-2]) ((CAST3V)WholeQuantity_P->Case.Operator.Function) (&Stack[0][Index-2], &Stack[0][Index-1], &Stack[0][Index-2]) ; else if(Multi[Index-1] && Multi[Index-2]) for(j=0 ; jCase.Operator.Function) (&Stack[j][Index-2], &Stack[j][Index-1], &Stack[j][Index-2]) ; else if(Multi[Index-2]) for(j=0 ; jCase.Operator.Function) (&Stack[j][Index-2], &Stack[0][Index-1], &Stack[j][Index-2]) ; else { for(j=0 ; jCase.Operator.Function) (&Stack[0][Index-2], &Stack[j][Index-1], &Stack[j][Index-2]) ; Multi[Index-2] = 1 ; } } else if (Index-1 == DofIndex) { if(Multi[Index-2]) for (j = 0 ; j < Nbr_Dof ; j++) ((CAST3V)WholeQuantity_P->Case.Operator.Function) (&Stack[j][Index-2], &DofValue[j], &DofValue[j]) ; else for (j = 0 ; j < Nbr_Dof ; j++) ((CAST3V)WholeQuantity_P->Case.Operator.Function) (&Stack[0][Index-2], &DofValue[j], &DofValue[j]) ; DofIndex-- ; } else { /* Index-2 == DofIndex */ if(Multi[Index-1]) for (j = 0 ; j < Nbr_Dof ; j++) ((CAST3V)WholeQuantity_P->Case.Operator.Function) (&DofValue[j], &Stack[j][Index-1], &DofValue[j]) ; else for (j = 0 ; j < Nbr_Dof ; j++) ((CAST3V)WholeQuantity_P->Case.Operator.Function) (&DofValue[j], &Stack[0][Index-1], &DofValue[j]) ; } Index-- ; break ; case WQ_UNARYOPERATOR : /* + - ! */ if (Index-1 == DofIndex) for (j = 0 ; j < Nbr_Dof ; j++) ((CAST1V)WholeQuantity_P->Case.Operator.Function)(&DofValue[j]) ; else if(Multi[Index-1]) for(j=0 ; jCase.Operator.Function)(&Stack[j][Index-1]) ; else ((CAST1V)WholeQuantity_P->Case.Operator.Function)(&Stack[0][Index-1]) ; break ; /* WARNING: all the rest assumes 0 multi status */ case WQ_TEST : Flag_True = (Stack[0][Index-1].Val[0] != 0.) ; for (j=0; jCase.Test.WholeQuantity_True : WholeQuantity_P->Case.Test.WholeQuantity_False, u, v, w, -1, 0, &Stack[0][Index-1], NbrArguments, ExpressionName) ; break ; case WQ_EXPRESSION : Index -= WholeQuantity_P->Case.Expression.NbrArguments ; Get_ValueOfExpression ((struct Expression*)List_Pointer (Problem_S.Expression, WholeQuantity_P->Case.Expression.Index), QuantityStorage_P0, u, v, w, &Stack[0][Index], WholeQuantity_P->Case.Expression.NbrArguments) ; Multi[Index] = 0 ; Index++ ; break ; case WQ_BUILTINFUNCTION : Index -= WholeQuantity_P->Case.Function.NbrArguments ; if (Index != DofIndex) ((CASTF2V)WholeQuantity_P->Case.Function.Fct) (&WholeQuantity_P->Case.Function, &Stack[0][Index], &Stack[0][Index]) ; else /* Dof must be the only argument, only valid with linear functions */ for (j = 0 ; j < Nbr_Dof ; j++) { Current.NumEntity = Current.NumEntities[j]; /* temp */ ((CASTF2V)WholeQuantity_P->Case.Function.Fct) (&WholeQuantity_P->Case.Function, &DofValue[j], &DofValue[j]) ; } Multi[Index] = 0 ; Index++ ; break ; case WQ_EXTERNBUILTINFUNCTION : ((CASTF2V)WholeQuantity_P->Case.Function.Fct) (&WholeQuantity_P->Case.Function, DofValue, &Stack[0][Index]) ; Multi[Index] = 0 ; Index++ ; break ; case WQ_CONSTANT : if (Current.NbrHar == 1) { Stack[0][Index].Val[0] = WholeQuantity_P->Case.Constant ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { Stack[0][Index].Val[MAX_DIM* k ] = WholeQuantity_P->Case.Constant ; Stack[0][Index].Val[MAX_DIM*(k+1)] = 0. ; } } Stack[0][Index].Type = SCALAR ; Multi[Index] = 0 ; Index++ ; break ; case WQ_CURRENTVALUE : if (Current.NbrHar == 1) { Stack[0][Index].Val[0] = *(WholeQuantity_P->Case.CurrentValue.Value) ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { Stack[0][Index].Val[MAX_DIM* k ] = *(WholeQuantity_P->Case.CurrentValue.Value) ; Stack[0][Index].Val[MAX_DIM*(k+1)] = 0. ; } } Stack[0][Index].Type = SCALAR ; Multi[Index] = 0 ; Index++ ; break ; case WQ_ARGUMENT : if (WholeQuantity_P->Case.Argument.Index > NbrArguments){ Message::Error("Function %s called with too few arguments", ExpressionName); } Cal_CopyValue(DofValue + WholeQuantity_P->Case.Argument.Index - 1, &Stack[0][Index]) ; Multi[Index] = 0 ; Index++ ; break ; case WQ_TIMEDERIVATIVE : if (Current.TypeTime == TIME_GEAR) { for (j=0; jCase.TimeDerivative.WholeQuantity, u, v, w, -1, 0, &Stack[0][Index], NbrArguments, ExpressionName); for (k = 0 ; k < Current.NbrSystem ; k++) (Current.DofData_P0+k)->Save_CurrentSolution = (Current.DofData_P0+k)->CurrentSolution; Save_TimeStep = Current.TimeStep ; Save_Time = Current.Time ; Save_TimeImag = Current.TimeImag ; for (int n = 0; n < Current.CorrOrder; n++) { for (k = 0 ; k < Current.NbrSystem ; k++){ Solution_P0 = (struct Solution*)List_Pointer((Current.DofData_P0+k)->Solutions, 0); if(((Current.DofData_P0+k)->CurrentSolution - Solution_P0) > 0) ((Current.DofData_P0+k)->CurrentSolution) -= 1 ; else{ Message::Error("Too few solutions for Dt with Gear's method"); break; } } Current.TimeStep = Current.DofData->CurrentSolution->TimeStep ; Current.Time = Current.DofData->CurrentSolution->Time ; Current.TimeImag = Current.DofData->CurrentSolution->TimeImag ; for (j=0; jCase.TimeDerivative.WholeQuantity, u, v, w, -1, 0, &Stack[0][Index+1], NbrArguments, ExpressionName); Cal_AddMultValue(&Stack[0][Index], &Stack[0][Index+1], -Current.aCorrCoeff[n], &Stack[0][Index]); } Cal_MultValue(&Stack[0][Index], 1./(Current.bCorrCoeff*Current.DTime), &Stack[0][Index]); for (k = 0 ; k < Current.NbrSystem ; k++) (Current.DofData_P0+k)->CurrentSolution = (Current.DofData_P0+k)->Save_CurrentSolution; Current.TimeStep = Save_TimeStep ; Current.Time = Save_Time ; Current.TimeImag = Save_TimeImag ; } else if (Current.NbrHar == 1) { for (j=0; jCase.TimeDerivative.WholeQuantity, u, v, w, -1, 0, &Stack[0][Index], NbrArguments, ExpressionName) ; for (k = 0 ; k < Current.NbrSystem ; k++){ (Current.DofData_P0+k)->Save_CurrentSolution = (Current.DofData_P0+k)->CurrentSolution; if(List_Nbr((Current.DofData_P0+k)->Solutions) > 1){ Solution_P0 = (struct Solution*)List_Pointer((Current.DofData_P0+k)->Solutions, 0); if ((Current.DofData_P0+k)->CurrentSolution != Solution_P0) ((Current.DofData_P0+k)->CurrentSolution) -- ; } else { if (!Flag_WarningMissSolForDt) { Message::Warning("Missing solution for time derivative computation (Sys#%d/%d)", k, Current.NbrSystem); Flag_WarningMissSolForDt = 1 ; } } } Save_Time = Current.Time ; Current.Time = Current.DofData->CurrentSolution->Time ; for (j=0; jCase.TimeDerivative.WholeQuantity, u, v, w, -1, 0, &Stack[0][Index+1], NbrArguments, ExpressionName) ; Cal_SubstractValue(&Stack[0][Index], &Stack[0][Index+1], &Stack[0][Index]) ; Stack[0][Index+1].Val[0] = Save_Time - Current.Time ; Stack[0][Index+1].Type = SCALAR ; if(Stack[0][Index+1].Val[0]) Cal_DivideValue(&Stack[0][Index], &Stack[0][Index+1], &Stack[0][Index]) ; else Cal_ZeroValue(&Stack[0][Index]); for (k = 0 ; k < Current.NbrSystem ; k++) (Current.DofData_P0+k)->CurrentSolution = (Current.DofData_P0+k)->Save_CurrentSolution; Current.Time = Save_Time ; } else { for (j=0; jCase.TimeDerivative.WholeQuantity, u, v, w, -1, 0, &Stack[0][Index], NbrArguments, ExpressionName) ; for (k = 0 ; k < Current.NbrHar ; k += 2) { Stack[0][Index+1].Val[MAX_DIM* k ] = 0. ; Stack[0][Index+1].Val[MAX_DIM*(k+1)] = Current.DofData->Val_Pulsation[k/2] ; } Stack[0][Index+1].Type = SCALAR ; Cal_ProductValue(&Stack[0][Index], &Stack[0][Index+1], &Stack[0][Index]) ; } Multi[Index] = 0 ; Index++ ; break ; case WQ_ATANTERIORTIMESTEP : ntime = WholeQuantity_P->Case.AtAnteriorTimeStep.TimeStep ; for (k = 0 ; k < Current.NbrSystem ; k++){ Solution_P0 = (struct Solution*)List_Pointer((Current.DofData_P0+k)->Solutions, 0); if(((Current.DofData_P0+k)->CurrentSolution - Solution_P0) >= ntime){ ((Current.DofData_P0+k)->CurrentSolution) -= ntime ; if (Flag_InfoForTime_ntime != List_Nbr((Current.DofData_P0+k)->Solutions)) { Message::Info("Accessing solution from %d time steps ago", ntime); Message::Info(" -> System %d/%d: TimeStep = %d, Time = %g + i * %g", k+1, Current.NbrSystem, (Current.DofData_P0+k)->CurrentSolution->TimeStep, (Current.DofData_P0+k)->CurrentSolution->Time, (Current.DofData_P0+k)->CurrentSolution->TimeImag); Flag_InfoForTime_ntime = List_Nbr((Current.DofData_P0+k)->Solutions); } } else { if (!Flag_WarningMissSolForTime_ntime) { Message::Warning("Missing solution for time step -%d computation (System #%d/%d)", ntime, k+1, Current.NbrSystem); Flag_WarningMissSolForTime_ntime = 1 ; } } } Save_TimeStep = Current.TimeStep ; Save_Time = Current.Time ; Save_TimeImag = Current.TimeImag ; Current.TimeStep = Current.DofData->CurrentSolution->TimeStep ; Current.Time = Current.DofData->CurrentSolution->Time ; Current.TimeImag = Current.DofData->CurrentSolution->TimeImag ; for (j=0; jCase.AtAnteriorTimeStep.WholeQuantity, u, v, w, -1, 0, &Stack[0][Index], NbrArguments, ExpressionName) ; Current.TimeStep = Save_TimeStep ; Current.Time = Save_Time ; Current.TimeImag = Save_TimeImag ; for (k = 0 ; k < Current.NbrSystem ; k++){ Solution_PN = (struct Solution*) List_Pointer((Current.DofData_P0+k)->Solutions, List_Nbr((Current.DofData_P0+k)->Solutions)-1); if((Solution_PN - (Current.DofData_P0+k)->CurrentSolution) >= ntime) ((Current.DofData_P0+k)->CurrentSolution) += ntime ; } Multi[Index] = 0 ; Index++ ; break ; case WQ_MHTRANSFORM : if(Current.NbrHar == 1){ Message::Error("MHTransform can only be used in complex (multi-harmonic) calculations") ; break; } for (j=0; jCase.MHTransform.WholeQuantity, u, v, w, -1, 0, &Stack[0][Index], NbrArguments, ExpressionName) ; MHTransform(Element, QuantityStorage_P0, u, v, w, &Stack[0][Index], (struct Expression *)List_Pointer(Problem_S.Expression, WholeQuantity_P->Case.MHTransform.Index), WholeQuantity_P->Case.MHTransform.NbrPoints) ; Multi[Index] = 0 ; Index++ ; break ; case WQ_CAST : /* This should be changed... */ Save_NbrHar = Current.NbrHar ; Save_DofData = Current.DofData ; if (!WholeQuantity_P->Case.Cast.NbrHar){ Current.DofData = ((struct FunctionSpace *) List_Pointer(Problem_S.FunctionSpace, WholeQuantity_P->Case.Cast.FunctionSpaceIndexForType)) ->DofData ; Current.NbrHar = Current.DofData->NbrHar ; } else{ Current.NbrHar = WholeQuantity_P->Case.Cast.NbrHar ; } for (j=0; jCase.Cast.WholeQuantity, u, v, w, -1, 0, &Stack[0][Index], NbrArguments, ExpressionName) ; if (Current.NbrHar < Save_NbrHar) /* ne plus a completer ...?? */ Cal_SetZeroHarmonicValue(&Stack[0][Index], Save_NbrHar) ; Current.NbrHar = Save_NbrHar ; Current.DofData = Save_DofData ; Multi[Index] = 0 ; Index++ ; break ; case WQ_CHANGECURRENTPOSITION : Save_x = Current.x ; Save_y = Current.y ; Save_z = Current.z ; Current.x = Stack[0][Index-1].Val[0] ; Current.y = Stack[0][Index-1].Val[1] ; Current.z = Stack[0][Index-1].Val[2] ; for (j=0; jCase.ChangeCurrentPosition.WholeQuantity, u, v, w, -1, 0, &Stack[0][Index-1], NbrArguments, ExpressionName) ; Current.x = Save_x ; Current.y = Save_y ; Current.z = Save_z ; break ; case WQ_SAVEVALUE : if(WholeQuantity_P->Case.SaveValue.Index > MAX_REGISTER_SIZE-1){ Message::Error("Register Size Exceeded (%d)", MAX_REGISTER_SIZE); break; } /* if (WholeQuantity_P->Case.SaveValue.Index >= 0) */ Cal_CopyValue(&Stack[0][Index-1], ValueSaved + WholeQuantity_P->Case.SaveValue.Index) ; break ; case WQ_VALUESAVED : if(WholeQuantity_P->Case.ValueSaved.Index > MAX_REGISTER_SIZE-1){ Message::Error("Register size exceeded (%d)", MAX_REGISTER_SIZE); break; } Cal_CopyValue(ValueSaved + WholeQuantity_P->Case.ValueSaved.Index, &Stack[0][Index]) ; Multi[Index] = 0 ; Index++ ; break ; case WQ_SHOWVALUE : if (Index-1 == DofIndex) { for(j=0 ; jCase.ShowValue.Index, j+1); Show_Value(&DofValue[j]); } } else { fprintf(stderr, "##%d ", WholeQuantity_P->Case.ShowValue.Index); Show_Value(&Stack[0][Index-1]); } break ; default : Message::Error("Unknown type of WholeQuantity (%d)", WholeQuantity_P->Type); break; } } if (DofIndexInWholeQuantity < 0) Cal_CopyValue(&Stack[0][0], &DofValue[0]) ; #if defined(USE_GLOBAL_STACK) RecursionIndex--; #endif } /* ------------------------------------------------------------------------ */ /* P u r i f y _ W h o l e Q u a n t i t y */ /* ------------------------------------------------------------------------ */ List_T * Purify_WholeQuantity(List_T * WQ_L) { /* It would be nice to pre-compute all trivial sequences in a list of WholeQuantities. For example, when all the quantties are constants, it is pretty stupid to recompute everything everytime using the stack... */ return NULL ; } /* ------------------------------------------------------------------------ */ /* C a l _ S t o r e I n R e g i s t e r */ /* ------------------------------------------------------------------------ */ void Cal_StoreInRegister(struct Value *Value, int RegisterIndex) { Cal_CopyValue(Value, ValueSaved + RegisterIndex) ; } getdp-2.4.2-source/Legacy/Cal_GalerkinTermOfFemEquation.h000644 001750 001750 00000001677 12116424202 024750 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _CAL_GALERKIN_TERM_OF_FEM_EQUATION_H_ #define _CAL_GALERKIN_TERM_OF_FEM_EQUATION_H_ #include "ProData.h" void Cal_InitGalerkinTermOfFemEquation(struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0, struct QuantityStorage * QuantityStorageNoDof, struct Dof * DofForNoDof_P); void Cal_GalerkinTermOfFemEquation(struct Element * Element, struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0); /* In F_MultiHar */ void Cal_InitGalerkinTermOfFemEquation_MHJacNL(struct EquationTerm *); void Cal_GalerkinTermOfFemEquation_MHJacNL(struct Element *, struct EquationTerm *, struct QuantityStorage *); #endif getdp-2.4.2-source/Legacy/Gauss_Tetrahedron.cpp000644 001750 001750 00000006327 12116424202 023133 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "Gauss.h" #include "Gauss_Tetrahedron.h" #include "Message.h" #include "MallocUtils.h" /* Gauss integration over a tetrahedron */ void Gauss_Tetrahedron(int Nbr_Points, int Num, double *u, double *v, double *w, double *wght) { switch (Nbr_Points) { case 1 : *u = xtet1 [Num] ; *v = ytet1 [Num] ; *w = ztet1 [Num] ; *wght = ptet1 [Num] ; break ; case 4 : *u = xtet4 [Num] ; *v = ytet4 [Num] ; *w = ztet4 [Num] ; *wght = ptet4 [Num] ; break ; case 5 : *u = xtet5 [Num] ; *v = ytet5 [Num] ; *w = ztet5 [Num] ; *wght = ptet5 [Num] ; break ; case 15 : *u = xtet15[Num] ; *v = ytet15[Num] ; *w = ztet15[Num] ; *wght = ptet15[Num] ; break ; case 16 : *u = xtet16[Num] ; *v = ytet16[Num] ; *w = ztet16[Num] ; *wght = ptet16[Num] ; break ; case 17 : *u = xtet17[Num] ; *v = ytet17[Num] ; *w = ztet17[Num] ; *wght = ptet17[Num] ; break ; case 29 : *u = xtet29[Num] ; *v = ytet29[Num] ; *w = ztet29[Num] ; *wght = ptet29[Num] ; break ; default : Message::Error("Wrong number of Gauss Points for Tetrahedron: " "valid choices: 1, 4, 5, 15, 16, 17, 29"); break; } } /* Degenerate n1Xn2Xn3 Gauss-Legendre scheme to integrate over a tet */ static int gltet[MAX_LINE_POINTS] = {-1}; static double *glxtet[MAX_LINE_POINTS], *glytet[MAX_LINE_POINTS] ; static double *glztet[MAX_LINE_POINTS], *glptet[MAX_LINE_POINTS]; void hexToTet(double xi,double eta, double zeta, double *r, double *s, double *t, double *J) { double r1,rs1; *r = 0.5e0*(1.0e0+xi); r1 = 1.0e0-(*r); *s = 0.5e0*(1.0e0+eta)*r1; rs1 = 1.0e0-(*r)-(*s); *t = 0.5e0*(1.0e0+zeta)*rs1; *J = 0.125e0*r1*rs1; } void GaussLegendre_Tetrahedron(int Nbr_Points, int Num, double *u, double *v, double *w, double *wght) { int i,j,k,index=0,nb; double pt1,pt2,pt3,wt1,wt2,wt3,dJ,dum; nb = (int)pow((double)Nbr_Points, 1./3.); if(nb*nb*nb != Nbr_Points || nb > MAX_LINE_POINTS){ Message::Error("Number of points should be n^3 with n in [1,%d]", MAX_LINE_POINTS) ; return; } if(gltet[0] < 0) for(i=0 ; i < MAX_LINE_POINTS ; i++) gltet[i] = 0 ; if(!gltet[nb-1]){ Message::Info("Computing degenerate GaussLegendre %dX%dX%d for Tetrahedron", nb, nb, nb); glxtet[nb-1] = (double*)Malloc(Nbr_Points*sizeof(double)); glytet[nb-1] = (double*)Malloc(Nbr_Points*sizeof(double)); glztet[nb-1] = (double*)Malloc(Nbr_Points*sizeof(double)); glptet[nb-1] = (double*)Malloc(Nbr_Points*sizeof(double)); for(i=0; i < nb; i++) { Gauss_Line(nb, i, &pt1, &dum, &dum, &wt1); for(j=0; j < nb; j++) { Gauss_Line(nb, j, &pt2, &dum, &dum, &wt2); for(k=0; k < nb; k++) { Gauss_Line(nb, k, &pt3, &dum, &dum, &wt3); hexToTet(pt1, pt2, pt3, &glxtet[nb-1][index], &glytet[nb-1][index], &glztet[nb-1][index], &dJ); glptet[nb-1][index++] = dJ*wt1*wt2*wt3; } } } gltet[nb-1] = 1; } *u = glxtet[nb-1][Num] ; *v = glytet[nb-1][Num] ; *w = glztet[nb-1][Num] ; *wght = glptet[nb-1][Num] ; } getdp-2.4.2-source/Legacy/Cal_PostQuantity.cpp000644 001750 001750 00000042427 12116424202 022756 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "ProData.h" #include "ProDefine.h" #include "GeoData.h" #include "Get_DofOfElement.h" #include "Cal_Quantity.h" #include "Cal_Value.h" #include "Get_Geometry.h" #include "Get_FunctionValue.h" #include "ExtendedGroup.h" #include "Pos_Formulation.h" #include "MallocUtils.h" #include "Message.h" extern struct Problem Problem_S ; extern struct CurrentData Current ; /* ------------------------------------------------------------------------ */ /* P o s _ L o c a l O r I n t e g r a l Q u a n t i t y */ /* ------------------------------------------------------------------------ */ static int Warning_NoJacobian = 0 ; void Pos_LocalOrIntegralQuantity(struct PostQuantity *PostQuantity_P, struct DefineQuantity *DefineQuantity_P0, struct QuantityStorage *QuantityStorage_P0, struct PostQuantityTerm *PostQuantityTerm_P, struct Element *Element, int Type_Quantity, double u, double v, double w, struct Value *Value) { struct FunctionSpace *FunctionSpace_P ; struct DefineQuantity *DefineQuantity_P ; struct QuantityStorage *QuantityStorage_P ; struct Value TermValue, tmpValue; struct JacobianCase *JacobianCase_P0 ; struct IntegrationCase *IntegrationCase_P ; struct Quadrature *Quadrature_P ; List_T *IntegrationCase_L, *JacobianCase_L ; double ui, vi, wi, weight, Factor ; int Index_DefineQuantity ; int i, j, Type_Dimension ; int CriterionIndex, Nbr_IntPoints, i_IntPoint ; double (*Get_Jacobian) (struct Element * Element, MATRIX3x3 * Jac) = 0; void (*Get_IntPoint) (int Nbr_Points, int Num, double * u, double * v, double * w, double * wght) ; /* Get the functionspaces Get the DoF for local quantities */ for (i = 0 ; i < PostQuantityTerm_P->NbrQuantityIndex ; i++) { Index_DefineQuantity = PostQuantityTerm_P->QuantityIndexTable[i] ; DefineQuantity_P = DefineQuantity_P0 + Index_DefineQuantity ; QuantityStorage_P = QuantityStorage_P0 + Index_DefineQuantity ; if (QuantityStorage_P->NumLastElementForFunctionSpace != Element->Num) { QuantityStorage_P->NumLastElementForFunctionSpace = Element->Num ; if (Type_Quantity != INTEGRALQUANTITY){ QuantityStorage_P->FunctionSpace = FunctionSpace_P = (struct FunctionSpace*) List_Pointer(Problem_S.FunctionSpace, DefineQuantity_P->FunctionSpaceIndex) ; if (DefineQuantity_P->Type == LOCALQUANTITY) Get_DofOfElement(Element, FunctionSpace_P, QuantityStorage_P, DefineQuantity_P->IndexInFunctionSpace) ; } else{ /* INTEGRALQUANTITY */ if(DefineQuantity_P->IntegralQuantity.DefineQuantityIndexDof >= 0) QuantityStorage_P->FunctionSpace = (struct FunctionSpace*) List_Pointer(Problem_S.FunctionSpace, DefineQuantity_P->FunctionSpaceIndex) ; /* Get the function space for the associated local quantities */ for (j = 0 ; j < DefineQuantity_P->IntegralQuantity.NbrQuantityIndex ; j++) { Index_DefineQuantity = DefineQuantity_P->IntegralQuantity.QuantityIndexTable[j]; DefineQuantity_P = DefineQuantity_P0 + Index_DefineQuantity ; QuantityStorage_P = QuantityStorage_P0 + Index_DefineQuantity ; QuantityStorage_P->FunctionSpace = (struct FunctionSpace*) List_Pointer(Problem_S.FunctionSpace, DefineQuantity_P->FunctionSpaceIndex) ; } } } } /* get the jacobian */ if (Element->Num != NO_ELEMENT) { if (PostQuantityTerm_P->JacobianMethodIndex >= 0) { JacobianCase_L = ((struct JacobianMethod *) List_Pointer(Problem_S.JacobianMethod, PostQuantityTerm_P->JacobianMethodIndex)) ->JacobianCase ; JacobianCase_P0 = (struct JacobianCase*)List_Pointer(JacobianCase_L, 0); i = 0 ; while ((i < List_Nbr(JacobianCase_L)) && ((j = (JacobianCase_P0 + i)->RegionIndex) >= 0) && !List_Search (((struct Group *)List_Pointer(Problem_S.Group, j)) ->InitialList, &Element->Region, fcmp_int) ) i++ ; if (i == List_Nbr(JacobianCase_L)){ Message::Error("Undefined Jacobian in Region %d", Element->Region) ; return; } Element->JacobianCase = JacobianCase_P0 + i ; Get_Jacobian = (double (*)(struct Element*, MATRIX3x3*)) Get_JacobianFunction(Element->JacobianCase->TypeJacobian, Element->Type, &Type_Dimension) ; } else { if(!Warning_NoJacobian){ Message::Warning("No Jacobian method specification in PostProcessing quantity: " "using default Jacobian (Vol)"); Warning_NoJacobian = 1 ; } Get_Jacobian = (double (*)(struct Element*, MATRIX3x3*)) Get_JacobianFunction(JACOBIAN_VOL, Element->Type, &Type_Dimension) ; } Get_NodesCoordinatesOfElement(Element) ; } /* local evaluation at one point */ if(PostQuantityTerm_P->EvaluationType == LOCAL){ if (Element->Num != NO_ELEMENT) { Get_BFGeoElement(Element, u, v, w) ; Element->DetJac = Get_Jacobian(Element, &Element->Jac) ; if (Element->DetJac != 0.) Get_InverseMatrix(Type_Dimension, Element->Type, Element->DetJac, &Element->Jac, &Element->InvJac) ; } Cal_WholeQuantity (Current.Element = Element, QuantityStorage_P0, PostQuantityTerm_P->WholeQuantity, Current.u = u, Current.v = v, Current.w = w, -1, -1, &TermValue) ; } /* integral evaluation over the element */ else if(PostQuantityTerm_P->EvaluationType == INTEGRAL){ if(Element->Num == NO_ELEMENT){ Message::Error("No element in which to integrate"); return; } if(PostQuantityTerm_P->IntegrationMethodIndex < 0){ Message::Error("Missing Integration method in PostProcesssing Quantity '%s'", PostQuantity_P->Name); return; } IntegrationCase_L = ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, PostQuantityTerm_P->IntegrationMethodIndex))->IntegrationCase ; CriterionIndex = ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, PostQuantityTerm_P->IntegrationMethodIndex)) ->CriterionIndex ; IntegrationCase_P = Get_IntegrationCase(Element, IntegrationCase_L, CriterionIndex) ; if(IntegrationCase_P->Type != GAUSS){ Message::Error("Only numerical integration is available " "in Integral PostQuantities"); return; } Quadrature_P = (struct Quadrature*) List_PQuery(IntegrationCase_P->Case, &Element->Type, fcmp_int); if(!Quadrature_P){ Message::Error("Unknown type of Element (%s) for Integration method (%s) " " in PostProcessing Quantity (%s)", Get_StringForDefine(Element_Type, Element->Type), ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, PostQuantityTerm_P->IntegrationMethodIndex))->Name, PostQuantity_P->Name); return; } Cal_ZeroValue(&TermValue); Nbr_IntPoints = Quadrature_P->NumberOfPoints ; Get_IntPoint = (void (*) (int,int,double*,double*,double*,double*)) Quadrature_P->Function ; for (i_IntPoint = 0 ; i_IntPoint < Nbr_IntPoints ; i_IntPoint++) { Get_IntPoint(Nbr_IntPoints, i_IntPoint, &ui, &vi, &wi, &weight) ; Get_BFGeoElement (Element, ui, vi, wi) ; Element->DetJac = Get_Jacobian(Element, &Element->Jac) ; if (Element->DetJac != 0.){ Get_InverseMatrix(Type_Dimension, Element->Type, Element->DetJac, &Element->Jac, &Element->InvJac) ; } else{ Message::Warning("Zero determinant in 'Cal_PostQuantity'"); } Current.x = Current.y = Current.z = 0. ; if (Type_Quantity == INTEGRALQUANTITY){ for (i = 0 ; i < Element->GeoElement->NbrNodes ; i++) { Current.x += Element->x[i] * Element->n[i] ; Current.y += Element->y[i] * Element->n[i] ; Current.z += Element->z[i] * Element->n[i] ; } } Cal_WholeQuantity (Current.Element = Element, QuantityStorage_P0, PostQuantityTerm_P->WholeQuantity, Current.u = ui, Current.v = vi, Current.w = wi, -1, -1, &tmpValue) ; Factor = weight * fabs(Element->DetJac) ; TermValue.Type = tmpValue.Type ; Cal_AddMultValue(&TermValue,&tmpValue,Factor,&TermValue); } } Value->Type = TermValue.Type; Cal_AddValue(Value,&TermValue,Value); } /* ------------------------------------------------------------------------ */ /* P o s _ G l o b a l Q u a n t i t y */ /* ------------------------------------------------------------------------ */ void Pos_GlobalQuantity(struct PostQuantity *PostQuantity_P, struct DefineQuantity *DefineQuantity_P0, struct QuantityStorage *QuantityStorage_P0, struct PostQuantityTerm *PostQuantityTerm_P, struct Element *ElementEmpty, List_T *InRegion_L, List_T *Support_L, struct Value *Value, int Type_InRegion) { struct DefineQuantity *DefineQuantity_P ; struct QuantityStorage *QuantityStorage_P ; struct FunctionSpace *FunctionSpace_P ; struct GlobalQuantity *GlobalQuantity_P ; struct Value TermValue ; int k, Index_DefineQuantity ; int Nbr_Element, i_Element ; struct Element Element ; int Type_Quantity ; if (PostQuantityTerm_P->EvaluationType == LOCAL && List_Search(InRegion_L, &Current.Region, fcmp_int)) { for (k = 0 ; k < PostQuantityTerm_P->NbrQuantityIndex ; k++) { Index_DefineQuantity = PostQuantityTerm_P->QuantityIndexTable[k] ; DefineQuantity_P = DefineQuantity_P0 + Index_DefineQuantity ; QuantityStorage_P = QuantityStorage_P0 + Index_DefineQuantity ; if (QuantityStorage_P->NumLastElementForFunctionSpace != Current.Region) { QuantityStorage_P->NumLastElementForFunctionSpace = Current.Region ; QuantityStorage_P->FunctionSpace = FunctionSpace_P = (struct FunctionSpace*) List_Pointer(Problem_S.FunctionSpace, DefineQuantity_P->FunctionSpaceIndex) ; GlobalQuantity_P = (struct GlobalQuantity*) List_Pointer (QuantityStorage_P->FunctionSpace->GlobalQuantity, *(int *)List_Pointer(DefineQuantity_P->IndexInFunctionSpace, 0)) ; if (DefineQuantity_P->Type == GLOBALQUANTITY) Get_DofOfRegion(Current.Region, GlobalQuantity_P, FunctionSpace_P, QuantityStorage_P) ; } } Cal_WholeQuantity (Current.Element = ElementEmpty, QuantityStorage_P0, PostQuantityTerm_P->WholeQuantity, Current.u = 0., Current.v = 0., Current.w = 0., -1, -1, &TermValue) ; Value->Type = TermValue.Type; Cal_AddValue(Value,&TermValue,Value); } /* if LOCAL && ... */ else if (PostQuantityTerm_P->EvaluationType == INTEGRAL) { Nbr_Element = Geo_GetNbrGeoElements() ; Get_InitDofOfElement(&Element) ; Type_Quantity = LOCALQUANTITY ; /* Attention... il faut se comprendre: */ /* il s'agit de grandeurs locales qui seront integrees */ for (i_Element = 0 ; i_Element < Nbr_Element; i_Element++) { Element.GeoElement = Geo_GetGeoElement(i_Element) ; Element.Num = Element.GeoElement->Num ; Element.Type = Element.GeoElement->Type ; Current.Region = Element.Region = Element.GeoElement->Region ; /* Filter: only elements in both InRegion_L and Support_L are considered */ if ((!InRegion_L || (List_Search(InRegion_L, (Type_InRegion==ELEMENTSOF ? &Element.Num : &Element.Region), fcmp_int))) && (!Support_L || List_Search(Support_L, &Element.Region, fcmp_int))) { Get_NodesCoordinatesOfElement(&Element) ; Current.x = Element.x[0]; Current.y = Element.y[0]; Current.z = Element.z[0]; Pos_LocalOrIntegralQuantity(PostQuantity_P, DefineQuantity_P0, QuantityStorage_P0, PostQuantityTerm_P, &Element, Type_Quantity, 0., 0., 0., Value) ; } } /* for i_Element ... */ } /* if INTEGRAL ... */ } /* ------------------------------------------------------------------------ */ /* C a l _ P o s t Q u a n t i t y */ /* ------------------------------------------------------------------------ */ void Cal_PostQuantity(struct PostQuantity *PostQuantity_P, struct DefineQuantity *DefineQuantity_P0, struct QuantityStorage *QuantityStorage_P0, List_T *Support_L, struct Element *Element, double u, double v, double w, struct Value *Value) { struct PostQuantityTerm PostQuantityTerm ; List_T *InRegion_L ; int i_PQT, Type_Quantity, Type_InRegion ; struct Group * Group_P ;/* For generating extended group */ /* mettre tout a zero: on ne connait pas a priori le type de retour */ /* (default type and value returned if Type_Quantity == -1) */ Cal_ZeroValue(Value); Value->Type = SCALAR; /* Loop on PostQuantity Terms */ /* ... with sum of results if common supports (In ...) */ for (i_PQT = 0 ; i_PQT < List_Nbr(PostQuantity_P->PostQuantityTerm) ; i_PQT++) { List_Read(PostQuantity_P->PostQuantityTerm, i_PQT, &PostQuantityTerm) ; /* InRegion_L = (PostQuantityTerm.InIndex < 0)? NULL : ((struct Group *)List_Pointer(Problem_S.Group, PostQuantityTerm.InIndex))->InitialList ; */ Group_P = (PostQuantityTerm.InIndex < 0)? NULL : (struct Group *)List_Pointer(Problem_S.Group, PostQuantityTerm.InIndex); InRegion_L = Group_P ? Group_P->InitialList : NULL ; Type_InRegion = Group_P ? Group_P->FunctionType : REGION; /* Generating Extended Group if necessary */ if (Group_P && Group_P->FunctionType == ELEMENTSOF){ if (!Group_P->ExtendedList) Generate_ExtendedGroup(Group_P) ; InRegion_L = Group_P->ExtendedList ; } if (!Support_L) Type_Quantity = PostQuantityTerm.Type ; else Type_Quantity = GLOBALQUANTITY ; /* Always if Support */ if (InRegion_L) { if (Element->Num != NO_ELEMENT) { /* not correct for ElementsOf (i.e. ELEMENTLIST) if (!List_Search(InRegion_L, &Element->Region, fcmp_int)) { Type_Quantity = -1 ; } */ if (!((Group_P->Type != ELEMENTLIST && List_Search(Group_P->InitialList, &Element->Region, fcmp_int)) || (Group_P->Type == ELEMENTLIST && Check_IsEntityInExtendedGroup(Group_P, Element->Num, 0)) )) { Type_Quantity = -1 ; } } else { if (Type_Quantity == GLOBALQUANTITY) { /* Plus de test ici... vu que le OnRegion de la PostOperation n'a rien a voir avec le support d'une integration ... if (!List_Search(InRegion_L, &Current.Region, fcmp_int)) { Type_Quantity = -1 ; } */ /* Il faut plutot voir si il existe au moins une region de InRegion_L qui soit dans Support_L ... cela est fait apres, pour chaque element */ } else if (Type_Quantity != INTEGRALQUANTITY) { Type_Quantity = -1 ; } } } /* else if !InRegion_L -> No filter, i.e. globally defined quantity */ /* ---------------------------- */ /* Local or Integral quantities */ /* ---------------------------- */ if (Type_Quantity == LOCALQUANTITY || Type_Quantity == INTEGRALQUANTITY) { Pos_LocalOrIntegralQuantity(PostQuantity_P, DefineQuantity_P0, QuantityStorage_P0, &PostQuantityTerm, Element, Type_Quantity, u, v, w, Value) ; } /* ----------------- */ /* Global quantities */ /* ----------------- */ else if (Type_Quantity == GLOBALQUANTITY) { Pos_GlobalQuantity(PostQuantity_P, DefineQuantity_P0, QuantityStorage_P0, &PostQuantityTerm, Element, InRegion_L, Support_L, Value, Type_InRegion) ; } } /* for i_PQT ... */ } /* ------------------------------------------------------------------------ */ /* C a l _ P o s t C u m u l a t i v e Q u a n t i t y */ /* ------------------------------------------------------------------------ */ void Cal_PostCumulativeQuantity(List_T *Region_L, int SupportIndex, List_T *TimeStep_L, struct PostQuantity *PostQuantity_P, struct DefineQuantity *DefineQuantity_P0, struct QuantityStorage *QuantityStorage_P0, struct Value **Values) { struct Element Element ; List_T *Support_L ; int i, NbrTimeStep ; Support_L = ((struct Group *) List_Pointer(Problem_S.Group, SupportIndex))->InitialList ; NbrTimeStep = List_Nbr(TimeStep_L) ; *Values = (struct Value *)Malloc(NbrTimeStep*sizeof(struct Value)) ; Element.Num = NO_ELEMENT ; for(i = 0 ; i < NbrTimeStep ; i++) { Pos_InitAllSolutions(TimeStep_L, i) ; Cal_PostQuantity(PostQuantity_P, DefineQuantity_P0, QuantityStorage_P0, Support_L, &Element, 0, 0, 0, &(*Values)[i]) ; } } /* ------------------------------------------------------------------------ */ /* C o m b i n e _ P o s t Q u a n t i t y */ /* ------------------------------------------------------------------------ */ void Combine_PostQuantity(int Type, int Order, struct Value *V1, struct Value *V2) { switch(Type){ case MULTIPLICATION : Cal_ProductValue(V1, V2, V1) ; break ; case ADDITION : Cal_AddValue(V1, V2, V1) ; break ; case DIVISION : Cal_DivideValue(Order?V1:V2, Order?V2:V1, V1) ; break; case SOUSTRACTION : Cal_SubstractValue(Order?V1:V2, Order?V2:V1, V1) ; break; } } getdp-2.4.2-source/Legacy/MovingBand2D.h000644 001750 001750 00000000573 12116424202 021366 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _MOVING_BAND_2D_H_ #define _MOVING_BAND_2D_H_ #include "ProData.h" void Init_MovingBand2D(struct Group * Group_P); void Mesh_MovingBand2D(struct Group * Group_P); #endif getdp-2.4.2-source/Legacy/Cal_PostQuantity.h000644 001750 001750 00000001764 12116424202 022422 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _CAL_POST_QUANTITY_H_ #define _CAL_POST_QUANTITY_H_ #include "ProData.h" void Cal_PostQuantity(struct PostQuantity *PostQuantity_P, struct DefineQuantity *DefineQuantity_P0, struct QuantityStorage *QuantityStorage_P0, List_T *Support_L, struct Element *Element, double u, double v, double w, struct Value *Value) ; void Cal_PostCumulativeQuantity(List_T *Region_L, int SupportIndex, List_T *TimeStep_L, struct PostQuantity *PostQuantity_P, struct DefineQuantity *DefineQuantity_P0, struct QuantityStorage *QuantityStorage_P0, struct Value **Value) ; void Combine_PostQuantity(int Type, int Order, struct Value *V1, struct Value *V2) ; #endif getdp-2.4.2-source/Legacy/Treatment_ConstraintByLocalProjection.cpp000644 001750 001750 00000007114 12166744450 027176 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "GetDPConfig.h" #include "ProData.h" #include "GeoData.h" #include "DofData.h" #include "Get_Geometry.h" #include "Get_DofOfElement.h" #include "Message.h" #include "Gauss.h" #if defined(HAVE_GMSH) #include #endif extern struct CurrentData Current ; void Treatment_ConstraintByLocalProjection(struct Element *Element, struct FunctionSpace *FunctionSpace_P, struct QuantityStorage *QuantityStorage_P) { int Nbr_Equ = QuantityStorage_P->NbrElementaryBasisFunction ; int i_Constraint = -1; for(int i = 0; i < Nbr_Equ; i++){ if((QuantityStorage_P->BasisFunction[i].Constraint == ASSIGN_LOCALPROJ || QuantityStorage_P->BasisFunction[i].Constraint == INIT_LOCALPROJ) && QuantityStorage_P->BasisFunction[i].Constraint_Index >=0){ if(i_Constraint >= 0 && i_Constraint != QuantityStorage_P->BasisFunction[i].Constraint_Index){ Message::Error("More than one constraint per element for local projection"); return; } i_Constraint = QuantityStorage_P->BasisFunction[i].Constraint_Index; } } if(i_Constraint < 0) return; #if defined(HAVE_GMSH) struct ConstraintInFS *Constraint_P = (struct ConstraintInFS*)List_Pointer(FunctionSpace_P->Constraint, i_Constraint) ; struct ConstraintPerRegion *ConstraintPerRegion_P = Constraint_P->ConstraintPerRegion ; void (*Mapping)(struct Element * Element, double vBFu[], double vBFx[]) = (void (*)(struct Element * Element, double vBFu[], double vBFx[])) Get_ChangeOfCoordinates(1, QuantityStorage_P->TypeQuantity) ; double (*Jacobian)(struct Element*, MATRIX3x3*) = (double (*)(struct Element*, MATRIX3x3*)) Get_JacobianFunctionAuto(Element->Type, Current.GeoData->Dimension); int Nbr_IntPoints = 0; void (*Integration)(int,int,double*,double*,double*,double*) = (void (*)(int,int,double*,double*,double*,double*)) Get_IntegrationFunctionAuto(Element->Type, 1, &Nbr_IntPoints); Current.Element = Element; double vBFu[NBR_MAX_BASISFUNCTIONS][MAX_DIM] ; double vBFx[NBR_MAX_BASISFUNCTIONS][MAX_DIM] ; fullMatrix E; fullVector rhs; for (int i_IntPoint = 0 ; i_IntPoint < Nbr_IntPoints ; i_IntPoint++) { double weight; Integration(Nbr_IntPoints, i_IntPoint, &Current.u, &Current.v, &Current.w, &weight) ; Get_BFGeoElement(Element, Current.u, Current.v, Current.w) ; Element->DetJac = Jacobian(Element, &Element->Jac) ; Get_InverseMatrix(Current.GeoData->Dimension, Element->Type, Element->DetJac, &Element->Jac, &Element->InvJac) ; double Factor = weight * fabs(Element->DetJac) ; for(int i = 0; i < Nbr_Equ; i++){ ((void (*)(struct Element * Element, int NumEntity, double u, double v, double w, double Value[])) QuantityStorage_P->BasisFunction[i].BasisFunction->Function) (Element, QuantityStorage_P->BasisFunction[i].NumEntityInElement + 1, Current.u, Current.v, Current.w, vBFu[i]) ; ((void (*)(struct Element*, double*, double*)) Mapping) (Element, vBFu[i], vBFx[i]) ; } for (int i = 0 ; i < Nbr_Equ ; i++) for (int j = 0 ; j < Nbr_Equ ; j++) E(i, j) += Factor * Cal_Product123(vBFx[i], vBFx[j]) ; } #else Message::Error("Local projection constraints require Gmsh"); #endif } getdp-2.4.2-source/Legacy/LinAlg_PETSC.cpp000644 001750 001750 00000115334 12171526422 021625 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // David Colignon // Ruth Sabariego // Jose Geraldo A. Brito Neto // #include #include #include #include #include #include #include "GetDPConfig.h" #include "LinAlg.h" #include "MallocUtils.h" #include "Message.h" #include "OS.h" #if defined(HAVE_SLEPC) #include #endif // Johan, we curse you for a thousand generations! #include "ProData.h" #include "DofData.h" extern struct CurrentData Current ; #if defined(HAVE_PETSC) // Options for PETSc can be provided on the command line, or in the file // ~/.petscrc. // // By default we try to use the MUMPS or UMFPACK direct solver (if // available, with PETSc 3). Otherwise we use a GMRES iterative solver // preconditionned with an ILU(6). // // All these options can be changed at runtime. For example you could // use // // -pc_type ilu // -pc_factor_levels 0 // -ksp_rtol 1.e-6 // -ksp_gmres_restart 500 // -ksp_monitor // // for GMRES with ILU(0), with a restart of 500 and a stopping // criterion of 1e-6. Or you could set // // -pc_type lu // -pc_factor_mat_solver_package mumps // -ksp_type gmres // // to use the MUMPS direct solver as a preconditioner to GMRES (useful // e.g if the matrix changed a bit, but you want to keep the same // factorization using "SolveAgain"). static MPI_Comm MyComm = MPI_COMM_SELF; static PetscViewer MyPetscViewer; static void _try(int ierr) { CHKERRCONTINUE(ierr); if(PetscUnlikely(ierr)){ // Do not produce an error in case of a PETSc-crash // when we are in TimeLoopAdaptive loop if (Message::GetOperatingInTimeLoopAdaptive()) Message::Warning("PETSc error %d", ierr); else Message::Error("PETSc error %d", ierr); Message::SetLastPETScError(ierr); } } static int SolverInitialized = 0; #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) #define PetscTruth PetscBool #define PetscOptionsGetTruth PetscOptionsGetBool #endif void LinAlg_InitializeSolver(int* argc, char*** argv) { // This function detects if MPI is initialized PetscInitialize(argc, argv, PETSC_NULL, PETSC_NULL); MyPetscViewer = PETSC_VIEWER_STDOUT_SELF; MyComm = PETSC_COMM_WORLD; #if defined(HAVE_SLEPC) SlepcInitialize(argc, argv, PETSC_NULL, PETSC_NULL); #endif SolverInitialized = 1; // get additional petsc options from specified file (useful e.g. on // Windows where we don't know where to search for ~/.petscrc) for(int i = 0; i < *argc - 1; i++){ if (!strcmp((*argv)[i], "-solver")){ #if (PETSC_VERSION_MAJOR == 2) PetscOptionsInsertFile((*argv)[i+1]); #else PetscOptionsInsertFile(MyComm, (*argv)[i+1], PETSC_FALSE); #endif } } } void LinAlg_FinalizeSolver() { if(SolverInitialized){ #if defined(HAVE_SLEPC) SlepcFinalize(); #endif PetscFinalize(); SolverInitialized = 0; } } void LinAlg_SetCommSelf() { MyComm = PETSC_COMM_SELF; Message::SetIsCommWorld(0); Message::Info("Set communicator to SELF"); } void LinAlg_SetCommWorld() { Message::Info("Set communicator to WORLD"); MyComm = PETSC_COMM_WORLD; Message::SetIsCommWorld(1); } void LinAlg_CreateSolver(gSolver *Solver, const char *SolverDataFileName) { for(int i = 0; i < 10; i++){ Solver->ksp[i] = NULL; Solver->snes[i] = NULL; } } void LinAlg_CreateVector(gVector *V, gSolver *Solver, int n) { _try(VecCreate(MyComm, &V->V)); _try(VecSetSizes(V->V, PETSC_DECIDE, n)); // override the default options with the ones from the option // database (if any) _try(VecSetFromOptions(V->V)); // create sequential vector that will contain all the values on all // the procs if(Message::GetCommSize() > 1) _try(VecCreateSeq(PETSC_COMM_SELF, n, &V->Vseq)); } void _fillseq(Vec &V, Vec &Vseq) { // collect all the values from the parallel petsc vector into a sequential // vector on each processor VecScatter ctx; VecScatterCreateToAll(V, &ctx, &Vseq); #if (PETSC_VERSION_MAJOR == 2) && (PETSC_VERSION_MINOR == 3) && (PETSC_VERSION_SUBMINOR < 3) VecScatterBegin(V, Vseq, INSERT_VALUES, SCATTER_FORWARD, ctx); VecScatterEnd(V, Vseq, INSERT_VALUES, SCATTER_FORWARD, ctx); #else VecScatterBegin(ctx, V, Vseq, INSERT_VALUES, SCATTER_FORWARD); VecScatterEnd(ctx, V, Vseq, INSERT_VALUES, SCATTER_FORWARD); #endif #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2)) ) VecScatterDestroy(&ctx); #else VecScatterDestroy(ctx); #endif } static void _fillseq(gVector *V) { if(Message::GetCommSize() == 1) return; _fillseq(V->V, V->Vseq); } void LinAlg_CreateMatrix(gMatrix *M, gSolver *Solver, int n, int m) { PetscInt prealloc = 100; PetscInt prealloc_full = n; int nonloc = Current.DofData->NonLocalEquations.size(); // heuristic for preallocation of global rows: don't prelloc more than 100 Mb int onegig = (int)(100 * 1024 * 1024 / (gSCALAR_SIZE * sizeof(double))); if(nonloc * n > onegig){ prealloc_full = (int)(onegig / nonloc); Message::Debug("Heuristic -petsc_prealloc_full changed to %d", prealloc_full); } PetscTruth set; PetscOptionsGetInt(PETSC_NULL, "-petsc_prealloc", &prealloc, &set); PetscOptionsGetInt(PETSC_NULL, "-petsc_prealloc_full", &prealloc_full, &set); // prealloc cannot be bigger than the number of rows! prealloc = (n < prealloc) ? n : prealloc; prealloc_full = (n < prealloc_full) ? n : prealloc_full; std::vector nnz(n, prealloc); // preallocate non local equations as full lines (this is not // optimal, but preallocating too few elements leads to horrible // assembly performance: petsc really sucks at dynamic reallocation // in the AIJ matrix format) for(int i = 0; i < nonloc; i++) nnz[Current.DofData->NonLocalEquations[i] - 1] = prealloc_full; if(Message::GetCommSize() > 1) // FIXME: alloc full lines... #if ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 3)) _try(MatCreateAIJ(MyComm, PETSC_DECIDE, PETSC_DECIDE, n, m, prealloc, PETSC_NULL, prealloc, PETSC_NULL, &M->M)); #else _try(MatCreateMPIAIJ(MyComm, PETSC_DECIDE, PETSC_DECIDE, n, m, prealloc, PETSC_NULL, prealloc, PETSC_NULL, &M->M)); #endif else _try(MatCreateSeqAIJ(PETSC_COMM_SELF, n, m, 0, &nnz[0], &M->M)); #if ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 3)) // Preallocation routines automatically set now MAT_NEW_NONZERO_ALLOCATION_ERR, // what causes a problem when the mask of the matrix changes (e.g. moving band) // We must disable the error generation and allow new allocation (if needed) _try(MatSetOption(M->M,MAT_NEW_NONZERO_ALLOCATION_ERR,PETSC_FALSE)); #endif // override the default options with the ones from the option // database (if any) _try(MatSetFromOptions(M->M)); } void LinAlg_DestroySolver(gSolver *Solver) { for(int i = 0; i < 10; i++){ #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) if(Solver->ksp[i]) _try(KSPDestroy(&Solver->ksp[i])); if(Solver->snes[i]) _try(SNESDestroy(&Solver->snes[i])); #else if(Solver->ksp[i]) _try(KSPDestroy(Solver->ksp[i])); if(Solver->snes[i]) _try(SNESDestroy(Solver->snes[i])); #endif } } void LinAlg_DestroyVector(gVector *V) { #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) _try(VecDestroy(&V->V)); if(Message::GetCommSize() > 1) _try(VecDestroy(&V->Vseq)); #else _try(VecDestroy(V->V)); if(Message::GetCommSize() > 1) _try(VecDestroy(V->Vseq)); #endif } void LinAlg_DestroyMatrix(gMatrix *M) { #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2)) ) _try(MatDestroy(&M->M)); #else _try(MatDestroy(M->M)); #endif } void LinAlg_CopyScalar(gScalar *S1, gScalar *S2) { S1->s = S2->s; } void LinAlg_CopyVector(gVector *V1, gVector *V2) { _try(VecCopy(V1->V, V2->V)); if(Message::GetCommSize() > 1) _try(VecCopy(V1->Vseq, V2->Vseq)); } void LinAlg_CopyMatrix(gMatrix *M1, gMatrix *M2) { _try(MatCopy(M1->M, M2->M, DIFFERENT_NONZERO_PATTERN)); } void LinAlg_ZeroScalar(gScalar *S) { S->s = 0.; } void LinAlg_ZeroVector(gVector *V) { PetscScalar zero = 0.0; _try(VecSet(V->V, zero)); if(Message::GetCommSize() > 1) _try(VecSet(V->Vseq, zero)); } void LinAlg_ZeroMatrix(gMatrix *M) { _try(MatZeroEntries(M->M)); } void LinAlg_ScanScalar(FILE *file, gScalar *S) { #if defined(PETSC_USE_COMPLEX) double a, b; fscanf(file, "%lf %lf", &a, &b); S->s = a + PETSC_i * b; #else fscanf(file, "%lf", &S->s); #endif } void LinAlg_ScanVector(FILE *file, gVector *V) { PetscInt n; _try(VecGetSize(V->V, &n)); for(PetscInt i = 0; i < n; i++){ PetscScalar tmp; #if defined(PETSC_USE_COMPLEX) double a, b; fscanf(file, "%lf %lf", &a, &b); tmp = a + PETSC_i * b; #else double a; fscanf(file, "%lf", &a); tmp = a; #endif _try(VecSetValues(V->V, 1, &i, &tmp, INSERT_VALUES)); } LinAlg_AssembleVector(V); } void LinAlg_ScanMatrix(FILE *file, gMatrix *M) { Message::Error("ScanMatrix not yet implemented"); } void LinAlg_ReadScalar(FILE *file, gScalar *S) { Message::Error("ReadScalar not yet implemented"); } void LinAlg_ReadVector(FILE *file, gVector *V) { PetscInt n; _try(VecGetSize(V->V, &n)); PetscScalar *tmp = (PetscScalar*)Malloc(n*sizeof(PetscScalar)); fread(tmp, sizeof(PetscScalar), n, file); for(PetscInt i = 0; i < n; i++) _try(VecSetValues(V->V, 1, &i, &tmp[i], INSERT_VALUES)); LinAlg_AssembleVector(V); Free(tmp); } void LinAlg_ReadMatrix(FILE *file, gMatrix *M) { Message::Error("ReadMatrix not yet implemented"); } void LinAlg_PrintScalar(FILE *file, gScalar *S) { #if defined(PETSC_USE_COMPLEX) fprintf(file, "%.16g %.16g", real(S->s), imag(S->s)); #else fprintf(file, "%.16g", S->s); #endif } void LinAlg_PrintVector(FILE *file, gVector *V, bool matlab, const char* fileName, const char* varName) { if(!matlab){ PetscInt n; _try(VecGetSize(V->V, &n)); Vec VV = Message::GetCommSize() > 1 ? V->Vseq : V->V; PetscScalar *tmp; _try(VecGetArray(VV, &tmp)); for (int i = 0; i < n; i++){ #if defined(PETSC_USE_COMPLEX) fprintf(file, "%.16g %.16g\n", real(tmp[i]), imag(tmp[i])); #else fprintf(file, "%.16g\n", tmp[i]); #endif } fflush(file); _try(VecRestoreArray(VV, &tmp)); } else{ PetscViewer fd; _try(PetscViewerASCIIOpen(MyComm, fileName, &fd)); _try(PetscViewerSetFormat(fd, PETSC_VIEWER_ASCII_MATLAB)); _try(PetscObjectSetName((PetscObject)V->V, varName)); _try(VecView(V->V, fd)); #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) _try(PetscViewerDestroy(&fd)); #else _try(PetscViewerDestroy(fd)); #endif } } void LinAlg_PrintMatrix(FILE *file, gMatrix *M, bool matlab, const char* fileName, const char* varName) { if(!matlab){ PetscInt n, m; _try(MatGetSize(M->M, &n, &m)); for(int i = 0; i < n; i++){ PetscInt ncols; const PetscInt *cols; const PetscScalar *vals; _try(MatGetRow(M->M, i, &ncols, &cols, &vals)); for(int j = 0; j < m; j++){ #if defined(PETSC_USE_COMPLEX) fprintf(file, "[%d, %d] %.16g %.16g\n", i, j, real(vals[j]), imag(vals[j]) ); #else fprintf(file, "[%d, %d] %.16g\n", i, j, vals[j]); #endif } _try(MatRestoreRow(M->M, i, &ncols, &cols, &vals)); } } else{ // ASCII PetscViewer fd; _try(PetscViewerASCIIOpen(MyComm, fileName, &fd)); _try(PetscViewerSetFormat(fd, PETSC_VIEWER_ASCII_MATLAB)); _try(PetscObjectSetName((PetscObject)M->M, varName)); _try(MatView(M->M, fd)); // Binary PetscViewer fd2; std::string tmp(fileName); _try(PetscViewerBinaryOpen(MyComm, (tmp + ".bin").c_str(), FILE_MODE_WRITE, &fd2)); _try(PetscViewerSetFormat(fd2, PETSC_VIEWER_DEFAULT)); _try(MatView(M->M, fd2)); #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) _try(PetscViewerDestroy(&fd)); _try(PetscViewerDestroy(&fd2)); #else _try(PetscViewerDestroy(fd)); _try(PetscViewerDestroy(fd2)); #endif } } void LinAlg_WriteScalar(FILE *file, gScalar *S) { Message::Error("WriteScalar not yet implemented"); } void LinAlg_WriteVector(FILE *file, gVector *V) { PetscInt n; _try(VecGetSize(V->V, &n)); Vec VV = Message::GetCommSize() > 1 ? V->Vseq : V->V; PetscScalar *tmp; _try(VecGetArray(VV, &tmp)); fwrite(tmp, sizeof(PetscScalar), n, file); fprintf(file, "\n"); _try(VecRestoreArray(VV, &tmp)); } void LinAlg_WriteMatrix(FILE *file, gMatrix *M) { Message::Error("WriteMatrix not yet implemented"); } void LinAlg_GetVectorSize(gVector *V, int *i) { PetscInt t; _try(VecGetSize(V->V, &t)); if(t > INT_MAX) Message::Error("Problem too big"); *i = t; } void LinAlg_GetLocalVectorRange(gVector *V, int *low, int *high) { PetscInt tlow, thigh; _try(VecGetOwnershipRange(V->V, &tlow, &thigh)); if(tlow > INT_MAX || thigh > INT_MAX) Message::Error("Problem too big"); *low = tlow; *high = thigh; } static bool _isInLocalRange(gVector *V, int i) { if(Message::GetCommSize() == 1) return true; int imin, imax; LinAlg_GetLocalVectorRange(V, &imin, &imax); return (i >= imin && i < imax); } void LinAlg_GetMatrixSize(gMatrix *M, int *i, int *j) { PetscInt ti, tj; _try(MatGetSize(M->M, &ti, &tj)); if(ti > INT_MAX || tj > INT_MAX) Message::Error("Problem too big"); *i = ti; *j = tj; } void LinAlg_GetLocalMatrixRange(gMatrix *M, int *low, int *high) { PetscInt tlow, thigh; _try(MatGetOwnershipRange(M->M, &tlow, &thigh)); if(tlow > INT_MAX || thigh > INT_MAX) Message::Error("Problem too big"); *low = tlow; *high = thigh; } static bool _isInLocalRange(gMatrix *M, int i) { if(Message::GetCommSize() == 1) return true; int imin, imax; LinAlg_GetLocalMatrixRange(M, &imin, &imax); return (i >= imin && i < imax); } void LinAlg_GetDoubleInScalar(double *d, gScalar *S) { #if defined(PETSC_USE_COMPLEX) *d = real(S->s); #else *d = S->s; #endif } void LinAlg_GetComplexInScalar(double *d1, double *d2, gScalar *S) { #if defined(PETSC_USE_COMPLEX) *d1 = real(S->s); *d2 = imag(S->s); #else Message::Error("'LinAlg_GetComplexInScalar' not available with this Solver"); #endif } void LinAlg_GetScalarInVector(gScalar *S, gVector *V, int i) { Vec VV = Message::GetCommSize() > 1 ? V->Vseq : V->V; PetscScalar *tmp; _try(VecGetArray(VV, &tmp)); S->s = tmp[i]; _try(VecRestoreArray(VV, &tmp)); } void LinAlg_GetDoubleInVector(double *d, gVector *V, int i) { Vec VV = Message::GetCommSize() > 1 ? V->Vseq : V->V; PetscScalar *tmp; _try(VecGetArray(VV, &tmp)); #if defined(PETSC_USE_COMPLEX) *d = real(tmp[i]); #else *d = tmp[i]; #endif _try(VecRestoreArray(VV, &tmp)); } void LinAlg_GetAbsDoubleInVector(double *d, gVector *V, int i) { Vec VV = Message::GetCommSize() > 1 ? V->Vseq : V->V; PetscScalar *tmp; _try(VecGetArray(VV, &tmp)); #if defined(PETSC_USE_COMPLEX) *d = fabs(real(tmp[i])); #else *d = fabs(tmp[i]); #endif _try(VecRestoreArray(VV, &tmp)); } void LinAlg_GetComplexInVector(double *d1, double *d2, gVector *V, int i, int j) { Vec VV = Message::GetCommSize() > 1 ? V->Vseq : V->V; PetscScalar *tmp; _try(VecGetArray(VV, &tmp)); #if defined(PETSC_USE_COMPLEX) *d1 = real(tmp[i]); *d2 = imag(tmp[i]); #else *d1 = (double)tmp[i]; *d2 = (double)tmp[j]; #endif _try(VecRestoreArray(VV, &tmp)); } void LinAlg_GetScalarInMatrix(gScalar *S, gMatrix *M, int i, int j) { if(!_isInLocalRange(M, i)) return; PetscInt ti = i, tj = j; _try(MatGetValues(M->M, 1, &ti, 1, &tj, &S->s)); } void LinAlg_GetDoubleInMatrix(double *d, gMatrix *M, int i, int j) { if(!_isInLocalRange(M, i)) return; PetscInt ti = i, tj = j; _try(MatGetValues(M->M, 1, &ti, 1, &tj, (PetscScalar*)d)); } void LinAlg_GetComplexInMatrix(double *d1, double *d2, gMatrix *M, int i, int j, int k, int l) { #if defined(PETSC_USE_COMPLEX) PetscScalar tmp; PetscInt ti = i, tj = j; if(_isInLocalRange(M, i)){ _try(MatGetValues(M->M, 1, &ti, 1, &tj, &tmp)); *d1 = real(tmp) ; *d2 = imag(tmp) ; } #else PetscInt ti = i, tj = j, tk = k, tl = l; if(_isInLocalRange(M, i)) _try(MatGetValues(M->M, 1, &ti, 1, &tj, (PetscScalar*)d1)); if(_isInLocalRange(M, k)) _try(MatGetValues(M->M, 1, &tk, 1, &tl, (PetscScalar*)d2)); #endif } void LinAlg_GetColumnInMatrix(gMatrix *M, int col, gVector *V1) { Message::Error("GetColumnInMatrix not yet implemented"); } void LinAlg_SetScalar(gScalar *S, double *d) { #if defined(PETSC_USE_COMPLEX) S->s = d[0] + (PETSC_i * d[1]); #else S->s = d[0]; #endif } void LinAlg_SetVector(gVector *V, double *v) { PetscScalar tmp = *v; _try(VecSet(V->V, tmp)); if(Message::GetCommSize() > 1) _try(VecSet(V->Vseq, tmp)); } void LinAlg_SetScalarInVector(gScalar *S, gVector *V, int i) { if(!_isInLocalRange(V, i)) return; PetscInt ti = i; _try(VecSetValues(V->V, 1, &ti, &S->s, INSERT_VALUES)); } void LinAlg_SetDoubleInVector(double d, gVector *V, int i) { if(!_isInLocalRange(V, i)) return; PetscScalar tmp = d; PetscInt ti = i; _try(VecSetValues(V->V, 1, &ti, &tmp, INSERT_VALUES)); } void LinAlg_SetComplexInVector(double d1, double d2, gVector *V, int i, int j) { PetscScalar tmp; #if defined(PETSC_USE_COMPLEX) if(_isInLocalRange(V, i)){ PetscInt ti = i; tmp = d1 + PETSC_i * d2; _try(VecSetValues(V->V, 1, &ti, &tmp, INSERT_VALUES)); } #else PetscInt ti = i, tj = j; if(_isInLocalRange(V, i)){ tmp = d1; _try(VecSetValues(V->V, 1, &ti, &tmp, INSERT_VALUES)); } if(_isInLocalRange(V, j)){ tmp = d2; _try(VecSetValues(V->V, 1, &tj, &tmp, INSERT_VALUES)); } #endif } void LinAlg_SetScalarInMatrix(gScalar *S, gMatrix *M, int i, int j) { if(!_isInLocalRange(M, i)) return; PetscInt ti = i, tj = j; _try(MatSetValues(M->M, 1, &ti, 1, &tj, &S->s, INSERT_VALUES)); } void LinAlg_SetDoubleInMatrix(double d, gMatrix *M, int i, int j) { if(!_isInLocalRange(M, i)) return; PetscInt ti = i, tj = j; _try(MatSetValues(M->M, 1, &ti, 1, &tj, (PetscScalar*)&d, INSERT_VALUES)); } void LinAlg_SetComplexInMatrix(double d1, double d2, gMatrix *M, int i, int j, int k, int l) { PetscScalar tmp; #if defined(PETSC_USE_COMPLEX) PetscInt ti = i, tj = j; if(_isInLocalRange(M, i)){ tmp = d1 + PETSC_i * d2; _try(MatSetValues(M->M, 1, &ti, 1, &tj, &tmp, INSERT_VALUES)); } #else PetscInt ti = i, tj = j, tk = k, tl = l; if(d1){ tmp = d1; if(_isInLocalRange(M, i)) _try(MatSetValues(M->M, 1, &ti, 1, &tj, &tmp, INSERT_VALUES)); if(_isInLocalRange(M, k)) _try(MatSetValues(M->M, 1, &tk, 1, &tl, &tmp, INSERT_VALUES)); } if(d2){ if(_isInLocalRange(M, i)){ tmp = -d2; _try(MatSetValues(M->M, 1, &ti, 1, &tl, &tmp, INSERT_VALUES)); } if(_isInLocalRange(M, k)){ tmp = d2; _try(MatSetValues(M->M, 1, &tk, 1, &tj, &tmp, INSERT_VALUES)); } } #endif } void LinAlg_AddScalarScalar(gScalar *S1, gScalar *S2, gScalar *S3) { S3->s = S1->s + S2->s; } void LinAlg_DummyVector(gVector *V) { if(Current.DofData->DummyDof) Message::Error("DummyVector not yet implemented"); return; } void LinAlg_AddScalarInVector(gScalar *S, gVector *V, int i) { if(!_isInLocalRange(V, i)) return; PetscInt ti = i; _try(VecSetValues(V->V, 1, &ti, &S->s, ADD_VALUES)); } void LinAlg_AddDoubleInVector(double d, gVector *V, int i) { if(!_isInLocalRange(V, i)) return; PetscScalar tmp = d; PetscInt ti = i; _try(VecSetValues(V->V, 1, &ti, &tmp, ADD_VALUES)); } void LinAlg_AddComplexInVector(double d1, double d2, gVector *V, int i, int j) { PetscScalar tmp; #if defined(PETSC_USE_COMPLEX) if(_isInLocalRange(V, i)){ PetscInt ti = i; tmp = d1 + PETSC_i * d2; _try(VecSetValues(V->V, 1, &ti, &tmp, ADD_VALUES)); } #else PetscInt ti = i, tj = j; if(_isInLocalRange(V, i)){ tmp = d1; _try(VecSetValues(V->V, 1, &ti, &tmp, ADD_VALUES)); } if(_isInLocalRange(V, j)){ tmp = d2; _try(VecSetValues(V->V, 1, &tj, &tmp, ADD_VALUES)); } #endif } void LinAlg_AddScalarInMatrix(gScalar *S, gMatrix *M, int i, int j) { if(!_isInLocalRange(M, i)) return; PetscInt ti = i, tj = j; _try(MatSetValues(M->M, 1, &ti, 1, &tj, &S->s, ADD_VALUES)); } void LinAlg_AddDoubleInMatrix(double d, gMatrix *M, int i, int j) { if(!_isInLocalRange(M, i)) return; PetscScalar tmp = d; PetscInt ti = i, tj = j; _try(MatSetValues(M->M, 1, &ti, 1, &tj, &tmp, ADD_VALUES)); } void LinAlg_AddComplexInMatrix(double d1, double d2, gMatrix *M, int i, int j, int k, int l) { PetscScalar tmp; #if defined(PETSC_USE_COMPLEX) PetscInt ti = i, tj = j; if(_isInLocalRange(M, i)){ tmp = d1 + PETSC_i * d2; _try(MatSetValues(M->M, 1, &ti, 1, &tj, &tmp, ADD_VALUES)); } #else PetscInt ti = i, tj = j, tk = k, tl = l; if(d1){ tmp = d1; if(_isInLocalRange(M, i)) _try(MatSetValues(M->M, 1, &ti, 1, &tj, &tmp, ADD_VALUES)); if(_isInLocalRange(M, k)) _try(MatSetValues(M->M, 1, &tk, 1, &tl, &tmp, ADD_VALUES)); } if(d2){ if(_isInLocalRange(M, i)){ tmp = -d2; _try(MatSetValues(M->M, 1, &ti, 1, &tl, &tmp, ADD_VALUES)); } if(_isInLocalRange(M, k)){ tmp = d2; _try(MatSetValues(M->M, 1, &tk, 1, &tj, &tmp, ADD_VALUES)); } } #endif } void LinAlg_AddVectorVector(gVector *V1, gVector *V2, gVector *V3) { PetscScalar tmp = 1.0; if(V3 == V1){ _try(VecAXPY(V1->V, tmp, V2->V)); _fillseq(V1); } else if(V3 == V2){ _try(VecAXPY(V2->V, tmp, V1->V)); _fillseq(V2); } else Message::Error("Wrong arguments in 'LinAlg_AddVectorVector'"); } void LinAlg_AddVectorProdVectorDouble(gVector *V1, gVector *V2, double d, gVector *V3) { PetscScalar tmp = d; if(V3 == V1){ _try(VecAXPY(V1->V, tmp, V2->V)); _fillseq(V1); } else if(V3 == V2){ _try(VecAYPX(V2->V, tmp, V1->V)); _fillseq(V2); } else Message::Error("Wrong arguments in 'LinAlg_AddVectorProdVectorDouble'"); } void LinAlg_AddMatrixMatrix(gMatrix *M1, gMatrix *M2, gMatrix *M3) { PetscScalar tmp = 1.0; if(M3 == M1) _try(MatAXPY(M1->M, tmp, M2->M, DIFFERENT_NONZERO_PATTERN)); else if(M3 == M2) _try(MatAXPY(M2->M, tmp, M1->M, DIFFERENT_NONZERO_PATTERN)); else Message::Error("Wrong arguments in 'LinAlg_AddMatrixMatrix'"); } void LinAlg_AddMatrixProdMatrixDouble(gMatrix *M1, gMatrix *M2, double d, gMatrix *M3) { PetscScalar tmp = d; if(M3 == M1) _try(MatAXPY(M1->M, tmp, M2->M, DIFFERENT_NONZERO_PATTERN)); else if(M3 == M2) #if (PETSC_VERSION_MAJOR == 2) && (PETSC_VERSION_MINOR == 3) && (PETSC_VERSION_SUBMINOR < 2) _try(MatAYPX(M2->M, tmp, M1->M)); #else _try(MatAYPX(M2->M, tmp, M1->M, DIFFERENT_NONZERO_PATTERN)); #endif else Message::Error("Wrong arguments in 'LinAlg_AddMatrixProdMatrixDouble'"); } void LinAlg_SubScalarScalar(gScalar *S1, gScalar *S2, gScalar *S3) { S3->s = S1->s - S2->s; } void LinAlg_SubVectorVector(gVector *V1, gVector *V2, gVector *V3) { PetscScalar tmp = -1.0; if(V3 == V1){ _try(VecAXPY(V1->V, tmp, V2->V)); // V1->V = V1->V - V2->V _fillseq(V1); } else if(V3 == V2){ _try(VecAYPX(V2->V, tmp, V1->V)); // V2->V = V1->V - V2->V _fillseq(V2); } else Message::Error("Wrong arguments in 'LinAlg_SubVectorVector'"); } void LinAlg_SubMatrixMatrix(gMatrix *M1, gMatrix *M2, gMatrix *M3) { PetscScalar tmp = -1.0; if(M3 == M1) // M1->M = M1->M - M2->M _try(MatAXPY(M1->M, tmp, M2->M, DIFFERENT_NONZERO_PATTERN)); else if(M3 == M2) // M2->M = M1->M - M2->M _try(MatAYPX(M2->M, tmp, M1->M, DIFFERENT_NONZERO_PATTERN)); else Message::Error("Wrong arguments in 'LinAlg_SubMatrixMatrix'"); } void LinAlg_ProdScalarScalar(gScalar *S1, gScalar *S2, gScalar *S3) { S3->s = S1->s * S2->s; } void LinAlg_ProdScalarDouble(gScalar *S1, double d, gScalar *S2) { S2->s = S1->s * d; } void LinAlg_ProdScalarComplex(gScalar *S, double d1, double d2, double *d3, double *d4) { #if defined(PETSC_USE_COMPLEX) PetscScalar tmp; #endif #if defined(PETSC_USE_COMPLEX) tmp = S->s * (d1 + PETSC_i * d2); *d3 = real(tmp); *d4 = imag(tmp); #else *d3 = S->s * d1; *d4 = S->s * d2; #endif } void LinAlg_ProdVectorScalar(gVector *V1, gScalar *S, gVector *V2) { if(V2 == V1){ _try(VecScale(V1->V, S->s)); _fillseq(V1); } else Message::Error("Wrong arguments in 'LinAlg_ProdVectorScalar'"); } void LinAlg_ProdVectorDouble(gVector *V1, double d, gVector *V2) { PetscScalar tmp = d; if(V2 == V1){ _try(VecScale(V1->V, tmp)); _fillseq(V1); } else Message::Error("Wrong arguments in 'LinAlg_ProdVectorDouble'"); } void LinAlg_ProdVectorComplex(gVector *V1, double d1, double d2, gVector *V2) { Message::Error("ProdVectorComplex not yet implemented"); } void LinAlg_ProdVectorVector(gVector *V1, gVector *V2, double *d) { PetscScalar tmp; _try(VecDot(V1->V, V2->V, &tmp)); #if defined(PETSC_USE_COMPLEX) *d = real(tmp); #else *d = tmp; #endif } void LinAlg_ProdMatrixVector(gMatrix *M, gVector *V1, gVector *V2) { if(V2 == V1) Message::Error("Wrong arguments in 'LinAlg_ProdMatrixVector'"); else{ _try(MatMult(M->M, V1->V, V2->V)); _fillseq(V2); } } void LinAlg_ProdMatrixScalar(gMatrix *M1, gScalar *S, gMatrix *M2) { if(M2 == M1) _try(MatScale(M1->M, S->s)); else Message::Error("Wrong arguments in 'LinAlg_ProdMatrixScalar'"); } void LinAlg_ProdMatrixDouble(gMatrix *M1, double d, gMatrix *M2) { PetscScalar tmp = d; if(M2 == M1) _try(MatScale(M1->M, tmp)); else Message::Error("Wrong arguments in 'LinAlg_ProdMatrixDouble'"); } void LinAlg_ProdMatrixComplex(gMatrix *M1, double d1, double d2, gMatrix *M2) { #if defined(PETSC_USE_COMPLEX) if(M2 == M1){ PetscScalar tmp = d1 + (PETSC_i * d2); _try(MatScale(M1->M, tmp)); } else Message::Error("Wrong arguments in 'LinAlg_ProdMatrixDouble'"); #else Message::Error("ProdMatrixComplex not yet implemented"); #endif } void LinAlg_DivScalarScalar(gScalar *S1, gScalar *S2, gScalar *S3) { S3->s = S1->s / S2->s; } void LinAlg_DivScalarDouble(gScalar *S1, double d, gScalar *S2) { S2->s = S1->s / d; } void LinAlg_VectorNorm2(gVector *V1, double *norm) { PetscReal tmp; _try(VecNorm(V1->V, NORM_2, &tmp)); *norm = tmp; } void LinAlg_VectorNormInf(gVector *V1, double *norm) { PetscReal tmp; _try(VecNorm(V1->V, NORM_INFINITY, &tmp)); *norm = tmp; } void LinAlg_AssembleMatrix(gMatrix *M) { Message::Barrier(); _try(MatAssemblyBegin(M->M, MAT_FINAL_ASSEMBLY)); _try(MatAssemblyEnd(M->M, MAT_FINAL_ASSEMBLY)); } void LinAlg_AssembleVector(gVector *V) { Message::Barrier(); _try(VecAssemblyBegin(V->V)); _try(VecAssemblyEnd(V->V)); _fillseq(V); } #if defined(HAVE_ZITSOL) extern "C" { int getdp_zitsol(int n, int nnz, int *row, int *col, double *valr, double *vali, double *rhsr, double *rhsi, double *solr, double *soli, int precond, int lfil, double tol0, double tol, int im, int maxits); } static void _zitsol(gMatrix *A, gVector *B, gVector *X) { int precond = 1, lfil = 30, im = 100, maxits = 200; double tol0 = 0.01, tol = 1e-10; PetscTruth set; PetscOptionsGetInt(PETSC_NULL, "-zitsol_precond", &precond, &set); PetscOptionsGetInt(PETSC_NULL, "-zitsol_lfil", &lfil, &set); PetscOptionsGetInt(PETSC_NULL, "-zitsol_im", &im, &set); PetscOptionsGetInt(PETSC_NULL, "-zitsol_maxits", &maxits, &set); PetscOptionsGetReal(PETSC_NULL, "-zitsol_tol0", &tol0, &set); PetscOptionsGetReal(PETSC_NULL, "-zitsol_tol", &tol, &set); MatInfo info; _try(MatGetInfo(A->M, MAT_LOCAL, &info)); int nnz = info.nz_used; //int n = info.rows_local; PetscInt n; _try(VecGetLocalSize(B->V, &n)); int *row = (int*)Malloc(nnz * sizeof(int)); int *col = (int*)Malloc(nnz * sizeof(int)); double *valr = (double*)Malloc(nnz * sizeof(double)); double *vali = (double*)Malloc(nnz * sizeof(double)); double *rhsr = (double*)Malloc(n * sizeof(double)); double *rhsi = (double*)Malloc(n * sizeof(double)); double *solr = (double*)Malloc(n * sizeof(double)); double *soli = (double*)Malloc(n * sizeof(double)); int k = 0; for(int i = 0; i < n; i++){ PetscInt ncols; const PetscInt *cols; const PetscScalar *vals; _try(MatGetRow(A->M, i, &ncols, &cols, &vals)); for(int j = 0; j < ncols; j++){ if(k >= nnz){ Message::Error("Something wrong in nnz: %d >= %d", k, nnz); return; } row[k] = i; col[k] = cols[j]; Message::Debug("A[%d][%d] = ", row[k], col[k]); #if defined(PETSC_USE_COMPLEX) valr[k] = real(vals[j]); vali[k] = imag(vals[j]); Message::Debug("%g+i*%g", valr[k], vali[k]); #else valr[k] = vals[j]; vali[k] = 0.; Message::Debug("%g", valr[k]); #endif k++; } _try(MatRestoreRow(A->M, i, &ncols, &cols, &vals)); } Message::Info("n = %d, nnz = %d (check k = %d)", n, nnz, k); PetscScalar *b, *x; _try(VecGetArray(B->V, &b)); _try(VecGetArray(X->V, &x)); for(int i = 0; i < n; i++){ #if defined(PETSC_USE_COMPLEX) rhsr[i] = real(b[i]); rhsi[i] = imag(b[i]); solr[i] = real(x[i]); soli[i] = imag(x[i]); #else rhsr[i] = b[i]; rhsi[i] = 0.; solr[i] = x[i]; soli[i] = 0.; #endif } _try(VecRestoreArray(B->V, &b)); _try(VecRestoreArray(X->V, &x)); int its = getdp_zitsol(n, nnz, row, col, valr, vali, rhsr, rhsi, solr, soli, precond, lfil, tol0, tol, im, maxits); if(its >= maxits) Message::Error("Did not converge in %d iterations", maxits); else Message::Info("Converged in %d iterations", its); for(PetscInt i = 0; i < n; i++){ PetscScalar d; #if defined(PETSC_USE_COMPLEX) d = solr[i] + PETSC_i * soli[i]; #else d = solr[i]; #endif _try(VecSetValues(X->V, 1, &i, &d, INSERT_VALUES)); } Free(row); Free(col); Free(valr); Free(vali); Free(rhsr); Free(rhsi); Free(solr); Free(soli); } #endif static PetscErrorCode _myKspMonitor(KSP ksp, PetscInt it, PetscReal rnorm, void *mctx) { Message::Info("%3ld KSP Residual norm %14.12e", (long)it, rnorm); return 0; } static void _solve(gMatrix *A, gVector *B, gSolver *Solver, gVector *X, int precond, int kspIndex) { #if defined(HAVE_ZITSOL) // testing Yousef's new preconditioners and solvers PetscTruth set, zitsol = PETSC_FALSE; PetscOptionsGetTruth(PETSC_NULL, "-zitsol", &zitsol, &set); if(zitsol){ _zitsol(A, B, X); return; } #endif //printf("INDEX SOLVER : %d\n", kspIndex); if(kspIndex < 0 || kspIndex > 9){ Message::Error("Linear Solver index out of range (%d)", kspIndex); return; } PetscInt i, j; _try(MatGetSize(A->M, &i, &j)); if(!i){ Message::Warning("Zero-size system: skipping solve!"); return; } int view = !Solver->ksp[kspIndex]; if(kspIndex != 0) Message::Info("Using solver index %d", kspIndex); //printf("kspIndex = %d\n",kspIndex); if(!Solver->ksp[kspIndex]) { _try(KSPCreate(MyComm, &Solver->ksp[kspIndex])); _try(KSPSetOperators(Solver->ksp[kspIndex], A->M, A->M, DIFFERENT_NONZERO_PATTERN)); _try(KSPMonitorSet(Solver->ksp[kspIndex], _myKspMonitor, PETSC_NULL, PETSC_NULL)); PC pc; _try(KSPGetPC(Solver->ksp[kspIndex], &pc)); // set some default options _try(KSPSetTolerances(Solver->ksp[kspIndex], 1.e-12, PETSC_DEFAULT, PETSC_DEFAULT, PETSC_DEFAULT)); #if (PETSC_VERSION_MAJOR > 2) && defined(PETSC_HAVE_MUMPS) // use MUMPS by default if available _try(PCSetType(pc, PCLU)); _try(PCFactorSetMatSolverPackage(pc, "mumps")); _try(KSPSetType(Solver->ksp[kspIndex], "preonly")); #elif (PETSC_VERSION_MAJOR > 2) && defined(PETSC_HAVE_UMFPACK) // otherwise use UMFPACK if available _try(PCSetType(pc, PCLU)); _try(PCFactorSetMatSolverPackage(pc, "umfpack")); _try(KSPSetType(Solver->ksp[kspIndex], "preonly")); #else // otherwise use ILU(6) + GMRES _try(PCSetType(pc, PCILU)); #if (PETSC_VERSION_MAJOR == 2) && (PETSC_VERSION_MINOR == 3) && (PETSC_VERSION_SUBMINOR == 0) _try(PCILUSetMatOrdering(pc, MATORDERING_RCM)); _try(PCILUSetLevels(pc, 6)); #elif (PETSC_VERSION_MAJOR == 2) && (PETSC_VERSION_MINOR == 3) && (PETSC_VERSION_SUBMINOR < 3) _try(PCFactorSetMatOrdering(pc, MATORDERING_RCM)); _try(PCFactorSetLevels(pc, 6)); #else _try(PCFactorSetMatOrderingType(pc, MATORDERINGRCM)); _try(PCFactorSetLevels(pc, 6)); #endif #endif // override the default options with the ones from the option database (if // any) _try(KSPSetFromOptions(Solver->ksp[kspIndex])); if(view && (!Message::GetCommRank() || !Message::GetIsCommWorld())){ // either we are on parallel (!GetIsCommWorld) or in sequential with rank // = 0 (GetIsCommWorld) #if (PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR == 4) const char *ksptype = ""; _try(KSPGetType(Solver->ksp[kspIndex], &ksptype)); const char *pctype = ""; _try(PCGetType(pc, &pctype)); #else const KSPType ksptype; _try(KSPGetType(Solver->ksp[kspIndex], &ksptype)); const PCType pctype; _try(PCGetType(pc, &pctype)); #endif #if (PETSC_VERSION_MAJOR > 2) const MatSolverPackage stype; _try(PCFactorGetMatSolverPackage(pc, &stype)); #else const char *stype = ""; #endif Message::Info("N: %ld - %s %s %s", (long)i, ksptype, pctype, stype); } } else if(precond){ _try(KSPSetOperators(Solver->ksp[kspIndex], A->M, A->M, DIFFERENT_NONZERO_PATTERN)); } _try(KSPSolve(Solver->ksp[kspIndex], B->V, X->V)); // copy result on all procs _fillseq(X); if(view && Message::GetVerbosity() > 5) _try(KSPView(Solver->ksp[kspIndex], MyPetscViewer)); if(!Message::GetCommRank() || !Message::GetIsCommWorld()){ PetscInt its; _try(KSPGetIterationNumber(Solver->ksp[kspIndex], &its)); if(its > 1) Message::Info("%d iterations", its); } } void LinAlg_Solve(gMatrix *A, gVector *B, gSolver *Solver, gVector *X, int solverIndex) { // printf("solverIndex = %d\n", solverIndex); _solve(A, B, Solver, X, 1, solverIndex); } void LinAlg_SolveAgain(gMatrix *A, gVector *B, gSolver *Solver, gVector *X, int solverIndex) { _solve(A, B, Solver, X, 0, solverIndex); } extern void Generate_Residual (gVector *x, gVector *f) ; extern void Generate_FullJacobian (gVector *x, gMatrix *Jac) ; static PetscErrorCode _NLFormFunction(SNES snes, Vec x, Vec f, void *mctx) { /* snes - the SNES context x - input vector (solution at each NL iteration) f - vector to store function value (residual) mctx - [optional] user-defined Jacobian context */ gVector gx, gf ; gx.V = x ; gf.V = f ; Generate_Residual(&gx, &gf) ; PetscScalar *ff ; _try(VecGetArray(gf.V, &ff)) ; PetscInt n; _try(VecGetSize(f, &n)) ; for(PetscInt i = 0; i < n; i++) _try(VecSetValues(f, 1, &i, &ff[i], INSERT_VALUES)); _try(VecGetArray(f, &ff)); return 0; } static PetscErrorCode _NLFormJacobian(SNES snes, Vec x, Mat *J, Mat *PC, MatStructure *flag, void *mctx) { /* snes - the SNES context x - input vector J - Jacobian matrix PC - preconditioner matrix, usually the same as Jac flag - flag indicating information about the preconditioner matrix structure (same as flag in KSPSetOperators()), one of SAME_NONZERO_PATTERN,DIFFERENT_NONZERO_PATTERN,SAME_PRECONDITIONER mctx - [optional] user-defined Jacobian context */ gVector gx ; gx.V = x ; gMatrix gJ ; gJ.M = *J ; Generate_FullJacobian(&gx, &gJ); *J = gJ.M ; *flag = DIFFERENT_NONZERO_PATTERN ; Message::Barrier(); _try(MatAssemblyBegin(*J, MAT_FINAL_ASSEMBLY)); _try(MatAssemblyEnd(*J, MAT_FINAL_ASSEMBLY)); if (*PC != *J){ _try(MatAssemblyBegin(*PC, MAT_FINAL_ASSEMBLY)); _try(MatAssemblyEnd(*PC, MAT_FINAL_ASSEMBLY)); } return 0; } static PetscErrorCode _mySnesMonitor(SNES snes, PetscInt it, PetscReal rnorm, void *mctx) { Message::Info("%3ld SNES Residual norm %14.12e", (long)it, rnorm); return 0; } // SNES - PETSC nonlinear solvers static void _solveNL(gMatrix *A, gVector *B, gMatrix *J, gVector *R, gSolver *Solver, gVector *X, int precond, int solverIndex) { if(solverIndex < 0 || solverIndex > 9){ Message::Error("NonLinear Solver index out of range (%d)", solverIndex); return; } PetscInt n, m; _try(MatGetSize(J->M, &n, &m)); if(!n){ Message::Warning("Zero-size jacobian: skipping solve!"); return; } bool view = !Solver->snes[solverIndex]; // either we are on sequential (!GetIsCommWorld) or in parallel with rank = 0 // (GetIsCommWorld) if(view && (!Message::GetCommRank() || !Message::GetIsCommWorld())) Message::Info("N: %ld", (long)n); if(solverIndex != 0) Message::Info("Using nonlinear solver index %d", solverIndex); PetscTruth fd_jacobian = PETSC_FALSE, snes_fd = PETSC_FALSE ; // Setting nonlinear solver defaults if(!Solver->snes[solverIndex]) { _try(SNESCreate(MyComm, &Solver->snes[solverIndex])); if(Message::UseSocket()) _try(SNESMonitorSet(Solver->snes[solverIndex], _mySnesMonitor, PETSC_NULL, PETSC_NULL)); _try(SNESSetTolerances(Solver->snes[solverIndex], 1.e-12, PETSC_DEFAULT, PETSC_DEFAULT, PETSC_DEFAULT, PETSC_DEFAULT)); // override default options with those from database (if any) _try(SNESSetFromOptions(Solver->snes[solverIndex])); PetscOptionsGetTruth(PETSC_NULL,"-fd_jacobian",&fd_jacobian,0); PetscOptionsGetTruth(PETSC_NULL,"-snes_fd",&snes_fd,0); if (fd_jacobian || snes_fd) { Message::Error("Finite Difference Jacobian not yet implemented"); #if (PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR == 4) _try(SNESSetJacobian(Solver->snes[solverIndex], J->M, J->M, SNESComputeJacobianDefault, PETSC_NULL)); #else _try(SNESSetJacobian(Solver->snes[solverIndex], J->M, J->M, SNESDefaultComputeJacobian, PETSC_NULL)); #endif } else { Message::Info("Jacobian computed by GetDP"); _try(SNESSetJacobian(Solver->snes[solverIndex], J->M, J->M, _NLFormJacobian, PETSC_NULL)); } _try(SNESSetFunction(Solver->snes[solverIndex], R->V, _NLFormFunction, PETSC_NULL)); // R(x) = A(x)*x-b } _try(SNESSolve(Solver->snes[solverIndex], PETSC_NULL, X->V)); // copy result on all procs _fillseq(X); if(view && Message::GetVerbosity() > 5) _try(SNESView(Solver->snes[solverIndex], MyPetscViewer)); if(!Message::GetCommRank() || !Message::GetIsCommWorld()){ PetscInt its; _try(SNESGetIterationNumber(Solver->snes[solverIndex], &its)); Message::Info("Number of Newton iterations %d", its); } } void LinAlg_SolveNL(gMatrix *A, gVector *B, gMatrix *J, gVector *R, gSolver *Solver, gVector *X, int solverIndex) { _solveNL(A, B, J, R, Solver, X, 1, solverIndex); } #endif getdp-2.4.2-source/Legacy/Pos_Element.cpp000644 001750 001750 00000126530 12116424202 021723 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Christophe Trophime // #include #include "Pos_Element.h" #include "GeoData.h" #include "Get_Geometry.h" #include "Get_DofOfElement.h" #include "Cal_Value.h" #include "MallocUtils.h" #include "Message.h" extern struct CurrentData Current ; /* ------------------------------------------------------------------------ */ /* Create/Destroy/Compare */ /* ------------------------------------------------------------------------ */ void Alloc_PostElement(struct PostElement * PostElement) { PostElement->NumNodes = (int *) Malloc(PostElement->NbrNodes * sizeof(int)) ; /* allocate as much as possible in one step */ PostElement->u = (double *) Malloc(6 * PostElement->NbrNodes * sizeof(double)) ; PostElement->v = &PostElement->u[PostElement->NbrNodes] ; PostElement->w = &PostElement->u[2*PostElement->NbrNodes] ; PostElement->x = &PostElement->u[3*PostElement->NbrNodes] ; PostElement->y = &PostElement->u[4*PostElement->NbrNodes] ; PostElement->z = &PostElement->u[5*PostElement->NbrNodes] ; PostElement->Value = (struct Value *) Malloc(PostElement->NbrNodes * sizeof(struct Value)) ; } struct PostElement * Create_PostElement(int Index, int Type, int NbrNodes, int Depth) { struct PostElement * PostElement ; PostElement = (struct PostElement *) Malloc(sizeof(struct PostElement)) ; PostElement->Index = Index ; PostElement->Type = Type ; PostElement->Depth = Depth ; PostElement->NbrNodes = NbrNodes ; if(NbrNodes > 0) Alloc_PostElement(PostElement); return PostElement ; } void Destroy_PostElement(struct PostElement * PostElement) { if(PostElement->NbrNodes > 0){ Free(PostElement->NumNodes) ; if(PostElement->u) Free(PostElement->u); /* normal case */ else if(PostElement->x) Free(PostElement->x); /* partial copy */ Free(PostElement->Value) ; } Free(PostElement) ; } struct PostElement * NodeCopy_PostElement(struct PostElement *PostElement) { struct PostElement * Copy ; int i ; Copy = (struct PostElement *) Malloc(sizeof(struct PostElement)) ; Copy->Index = PostElement->Index ; Copy->Type = PostElement->Type ; Copy->Depth = PostElement->Depth ; Copy->NbrNodes = PostElement->NbrNodes ; if(Copy->NbrNodes > 0){ Alloc_PostElement(Copy); for(i = 0 ; i < Copy->NbrNodes ; i++){ Copy->NumNodes[i] = PostElement->NumNodes[i]; Copy->u[i] = PostElement->u[i] ; Copy->v[i] = PostElement->v[i] ; Copy->w[i] = PostElement->w[i] ; Copy->x[i] = PostElement->x[i] ; Copy->y[i] = PostElement->y[i] ; Copy->z[i] = PostElement->z[i] ; } } return Copy ; } struct PostElement * PartialCopy_PostElement(struct PostElement *PostElement) { struct PostElement * Copy ; int i ; Copy = (struct PostElement *) Malloc(sizeof(struct PostElement)) ; Copy->Index = PostElement->Index ; Copy->Type = PostElement->Type ; Copy->Depth = PostElement->Depth ; Copy->NbrNodes = PostElement->NbrNodes ; if(Copy->NbrNodes > 0){ Copy->NumNodes = NULL ; Copy->u = Copy->v = Copy->w = NULL ; /* allocate as much as possible in one step */ Copy->x = (double *) Malloc(3* Copy->NbrNodes * sizeof(double)) ; Copy->y = &Copy->x[Copy->NbrNodes]; Copy->z = &Copy->x[2 * Copy->NbrNodes]; Copy->Value = (struct Value *) Malloc(Copy->NbrNodes * sizeof(struct Value)) ; for(i = 0 ; i < Copy->NbrNodes ; i++){ Copy->x[i] = PostElement->x[i] ; Copy->y[i] = PostElement->y[i] ; Copy->z[i] = PostElement->z[i] ; Cal_CopyValue(&PostElement->Value[i], &Copy->Value[i]); } } return Copy ; } /* 2 PostElements never have the same barycenter unless they are identical */ int fcmp_PostElement(const void *a, const void *b) { struct PostElement *PE1, *PE2 ; double s1, s2, TOL=Current.GeoData->CharacteristicLength * 1.e-12 ; int i; PE1 = *(struct PostElement**)a; PE2 = *(struct PostElement**)b; if(PE1->NbrNodes != PE2->NbrNodes) return PE1->NbrNodes - PE2->NbrNodes; s1 = s2 = 0.0 ; for(i=0;iNbrNodes;i++){ s1 += PE1->x[i]; s2 += PE2->x[i]; } if(s1-s2 > TOL) return 1; else if(s1-s2 < -TOL) return -1; s1 = s2 = 0.0 ; for(i=0;iNbrNodes;i++){ s1 += PE1->y[i]; s2 += PE2->y[i]; } if(s1-s2 > TOL) return 1; else if(s1-s2 < -TOL) return -1; s1 = s2 = 0.0 ; for(i=0;iNbrNodes;i++){ s1 += PE1->z[i]; s2 += PE2->z[i]; } if(s1-s2 > TOL) return 1; else if(s1-s2 < -TOL) return -1; return 0; } int fcmp_PostElement_v0(const void *a, const void *b) { return (int)( (*(struct PostElement**)a)->v[0] - (*(struct PostElement**)b)->v[0] ) ; } int fcmp_PostElement_absu0(const void *a, const void *b) { return (int)( fabs((*(struct PostElement**)b)->u[0]) - fabs((*(struct PostElement**)a)->u[0]) ) ; } /* ------------------------------------------------------------------------ */ /* C u t _ P o s t E l e m e n t */ /* ------------------------------------------------------------------------ */ void Cut_PostElement(struct PostElement * PE, struct Geo_Element * GE, List_T * PE_L, int Index, int Depth, int Skin, int DecomposeInSimplex) { struct Element E ; struct PostElement * C[8] ; double u01, u02, u03, u12, u13, u23 ; double v01, v02, v03, v12, v13, v23 ; double w01, w02, w03, w12, w13, w23 ; int i, j, NbCut = 0 ; /* Recursive division */ if(PE->Depth < Depth){ switch(PE->Type){ case POINT : Message::Error("Impossible to divide a Point recursively"); break; case LINE : case LINE_2 : u01 = .5 * (PE->u[0] + PE->u[1]); v01 = .5 * (PE->v[0] + PE->v[1]); w01 = .5 * (PE->w[0] + PE->w[1]); C[0] = Create_PostElement(Index, LINE, 2, PE->Depth) ; C[0]->u[0] = PE->u[0] ; C[0]->v[0] = PE->v[0] ; C[0]->w[0] = PE->w[0] ; C[0]->u[1] = u01 ; C[0]->v[1] = v01 ; C[0]->w[1] = w01 ; C[1] = PE ; C[1]->u[0] = u01 ; C[1]->v[0] = v01 ; C[1]->w[0] = w01 ; NbCut = 2 ; break; case TRIANGLE : case TRIANGLE_2 : u01 = .5 * (PE->u[0] + PE->u[1]); u02 = .5 * (PE->u[0] + PE->u[2]); v01 = .5 * (PE->v[0] + PE->v[1]); v02 = .5 * (PE->v[0] + PE->v[2]); w01 = .5 * (PE->w[0] + PE->w[1]); w02 = .5 * (PE->w[0] + PE->w[2]); u12 = .5 * (PE->u[1] + PE->u[2]); v12 = .5 * (PE->v[1] + PE->v[2]); w12 = .5 * (PE->w[1] + PE->w[2]); C[0] = Create_PostElement(Index, TRIANGLE, 3, PE->Depth) ; C[0]->u[0] = PE->u[0] ; C[0]->v[0] = PE->v[0] ; C[0]->w[0] = PE->w[0] ; C[0]->u[1] = u01 ; C[0]->v[1] = v01 ; C[0]->w[1] = w01 ; C[0]->u[2] = u02 ; C[0]->v[2] = v02 ; C[0]->w[2] = w02 ; C[1] = Create_PostElement(Index, TRIANGLE, 3, PE->Depth) ; C[1]->u[0] = u01 ; C[1]->v[0] = v01 ; C[1]->w[0] = w01 ; C[1]->u[1] = PE->u[1] ; C[1]->v[1] = PE->v[1] ; C[1]->w[1] = PE->w[1] ; C[1]->u[2] = u12 ; C[1]->v[2] = v12 ; C[1]->w[2] = w12 ; C[2] = Create_PostElement(Index, TRIANGLE, 3, PE->Depth) ; C[2]->u[0] = u02 ; C[2]->v[0] = v02 ; C[2]->w[0] = w02 ; C[2]->u[1] = u12 ; C[2]->v[1] = v12 ; C[2]->w[1] = w12 ; C[2]->u[2] = PE->u[2] ; C[2]->v[2] = PE->v[2] ; C[2]->w[2] = PE->w[2] ; C[3] = PE ; C[3]->u[0] = u01 ; C[3]->v[0] = v01 ; C[3]->w[0] = w01 ; C[3]->u[1] = u12 ; C[3]->v[1] = v12 ; C[3]->w[1] = w12 ; C[3]->u[2] = u02 ; C[3]->v[2] = v02 ; C[3]->w[2] = w02 ; NbCut = 4 ; break; case TETRAHEDRON : u01 = .5 * (PE->u[0] + PE->u[1]); u02 = .5 * (PE->u[0] + PE->u[2]); v01 = .5 * (PE->v[0] + PE->v[1]); v02 = .5 * (PE->v[0] + PE->v[2]); w01 = .5 * (PE->w[0] + PE->w[1]); w02 = .5 * (PE->w[0] + PE->w[2]); u03 = .5 * (PE->u[0] + PE->u[3]); u12 = .5 * (PE->u[1] + PE->u[2]); v03 = .5 * (PE->v[0] + PE->v[3]); v12 = .5 * (PE->v[1] + PE->v[2]); w03 = .5 * (PE->w[0] + PE->w[3]); w12 = .5 * (PE->w[1] + PE->w[2]); u13 = .5 * (PE->u[1] + PE->u[3]); u23 = .5 * (PE->u[2] + PE->u[3]); v13 = .5 * (PE->v[1] + PE->v[3]); v23 = .5 * (PE->v[2] + PE->v[3]); w13 = .5 * (PE->w[1] + PE->w[3]); w23 = .5 * (PE->w[2] + PE->w[3]); C[0] = Create_PostElement(Index, TETRAHEDRON, 4, PE->Depth) ; C[0]->u[0] = PE->u[0] ; C[0]->v[0] = PE->v[0] ; C[0]->w[0] = PE->w[0] ; C[0]->u[1] = u01 ; C[0]->v[1] = v01 ; C[0]->w[1] = w01 ; C[0]->u[2] = u02 ; C[0]->v[2] = v02 ; C[0]->w[2] = w02 ; C[0]->u[3] = u03 ; C[0]->v[3] = v03 ; C[0]->w[3] = w03 ; C[1] = Create_PostElement(Index, TETRAHEDRON, 4, PE->Depth) ; C[1]->u[0] = PE->u[1] ; C[1]->v[0] = PE->v[1] ; C[1]->w[0] = PE->w[1] ; C[1]->u[1] = u01 ; C[1]->v[1] = v01 ; C[1]->w[1] = w01 ; C[1]->u[2] = u12 ; C[1]->v[2] = v12 ; C[1]->w[2] = w12 ; C[1]->u[3] = u13 ; C[1]->v[3] = v13 ; C[1]->w[3] = w13 ; C[2] = Create_PostElement(Index, TETRAHEDRON, 4, PE->Depth) ; C[2]->u[0] = PE->u[2] ; C[2]->v[0] = PE->v[2] ; C[2]->w[0] = PE->w[2] ; C[2]->u[1] = u02 ; C[2]->v[1] = v02 ; C[2]->w[1] = w02 ; C[2]->u[2] = u12 ; C[2]->v[2] = v12 ; C[2]->w[2] = w12 ; C[2]->u[3] = u23 ; C[2]->v[3] = v23 ; C[2]->w[3] = w23 ; C[3] = Create_PostElement(Index, TETRAHEDRON, 4, PE->Depth) ; C[3]->u[0] = PE->u[3] ; C[3]->v[0] = PE->v[3] ; C[3]->w[0] = PE->w[3] ; C[3]->u[1] = u03 ; C[3]->v[1] = v03 ; C[3]->w[1] = w03 ; C[3]->u[2] = u13 ; C[3]->v[2] = v13 ; C[3]->w[2] = w13 ; C[3]->u[3] = u23 ; C[3]->v[3] = v23 ; C[3]->w[3] = w23 ; C[4] = Create_PostElement(Index, TETRAHEDRON, 4, PE->Depth) ; C[4]->u[0] = u01 ; C[4]->v[0] = v01 ; C[4]->w[0] = w01 ; C[4]->u[1] = u02 ; C[4]->v[1] = v02 ; C[4]->w[1] = w02 ; C[4]->u[2] = u03 ; C[4]->v[2] = v03 ; C[4]->w[2] = w03 ; C[4]->u[3] = u23 ; C[4]->v[3] = v23 ; C[4]->w[3] = w23 ; C[5] = Create_PostElement(Index, TETRAHEDRON, 4, PE->Depth) ; C[5]->u[0] = u01 ; C[5]->v[0] = v01 ; C[5]->w[0] = w01 ; C[5]->u[1] = u02 ; C[5]->v[1] = v02 ; C[5]->w[1] = w02 ; C[5]->u[2] = u12 ; C[5]->v[2] = v12 ; C[5]->w[2] = w12 ; C[5]->u[3] = u23 ; C[5]->v[3] = v23 ; C[5]->w[3] = w23 ; C[6] = Create_PostElement(Index, TETRAHEDRON, 4, PE->Depth) ; C[6]->u[0] = u01 ; C[6]->v[0] = v01 ; C[6]->w[0] = w01 ; C[6]->u[1] = u12 ; C[6]->v[1] = v12 ; C[6]->w[1] = w12 ; C[6]->u[2] = u13 ; C[6]->v[2] = v13 ; C[6]->w[2] = w13 ; C[6]->u[3] = u23 ; C[6]->v[3] = v23 ; C[6]->w[3] = w23 ; C[7] = PE ; C[7]->u[0] = u01 ; C[7]->v[0] = v01 ; C[7]->w[0] = w01 ; C[7]->u[1] = u03 ; C[7]->v[1] = v03 ; C[7]->w[1] = w03 ; C[7]->u[2] = u13 ; C[7]->v[2] = v13 ; C[7]->w[2] = w13 ; C[7]->u[3] = u23 ; C[7]->v[3] = v23 ; C[7]->w[3] = w23 ; NbCut = 8 ; break ; default : Message::Error("Recursive division not implemented for Quadrangles, Hexahedra, " "Prisms and Pyramids") ; break; } for(i = 0 ; i < NbCut ; i++){ C[i]->Depth ++ ; for(j = 0 ; j < C[i]->NbrNodes ; j++) C[i]->NumNodes[j] = -1 ; Cut_PostElement(C[i], GE, PE_L, Index, Depth, Skin, DecomposeInSimplex); } } else{ Get_InitDofOfElement(&E) ; E.GeoElement = GE ; E.Num = E.GeoElement->Num ; E.Type = E.GeoElement->Type ; E.Region = E.GeoElement->Region ; Get_NodesCoordinatesOfElement(&E) ; for(i = 0 ; i < PE->NbrNodes ; i++){ if( Skin == 0 && PE->Depth == 1 && ( DecomposeInSimplex == 0 || E.GeoElement->Type == LINE || E.GeoElement->Type == TRIANGLE || E.GeoElement->Type == TETRAHEDRON ) ){ PE->x[i] = E.x[i] ; PE->y[i] = E.y[i] ; PE->z[i] = E.z[i] ; } else{ Get_BFGeoElement(&E, PE->u[i], PE->v[i], PE->w[i]) ; PE->x[i] = PE->y[i] = PE->z[i] = 0. ; for (j = 0 ; j < E.GeoElement->NbrNodes ; j++) { PE->x[i] += E.x[j] * E.n[j] ; PE->y[i] += E.y[j] * E.n[j] ; PE->z[i] += E.z[j] * E.n[j] ; } } } List_Add(PE_L, &PE); } } /* ------------------------------------------------------------------------ */ /* F i l l _ P o s t E l e m e n t */ /* ------------------------------------------------------------------------ */ #define POS_CUT_FILL Cut_PostElement(PE, GE, PE_L, Index, Depth, 0, DecomposeInSimplex) #define POS_CUT_SKIN Cut_PostElement(PE, GE, PE_L, Index, Depth, 1, DecomposeInSimplex) void Fill_PostElement(struct Geo_Element * GE, List_T * PE_L, int Index, int Depth, int Skin, List_T * EvaluationPoints_L, int DecomposeInSimplex) { struct PostElement * PE ; int Nbr_EP, i_EP; if(!Depth){ PE = Create_PostElement(Index, POINT, 1, 0) ; switch(GE->Type){ case POINT : PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] = 0. ; break ; case LINE : case LINE_2 : PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] = 0. ; break ; case TRIANGLE : case TRIANGLE_2 : PE->u[0] = 1./3.; PE->v[0] = 1./3.; PE->w[0] = 0. ; break ; case QUADRANGLE : case QUADRANGLE_2: case QUADRANGLE_2_8N: PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] = 0. ; break ; case TETRAHEDRON : PE->u[0] = 0.25 ; PE->v[0] = 0.25 ; PE->w[0] = 0.25 ; break ; case HEXAHEDRON : PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] = 0. ; break ; case PRISM : PE->u[0] = 1./3.; PE->v[0] = 1./3.; PE->w[0] = 0. ; break ; case PYRAMID : PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] = 1./3.; break ; } POS_CUT_FILL ; } else{ if(!Skin){ switch(GE->Type){ case POINT : PE = Create_PostElement(Index, POINT, 1, 1) ; /* node 1 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] = 0. ; POS_CUT_FILL ; break ; case LINE : case LINE_2 : PE = Create_PostElement(Index, LINE, 2, 1) ; /* nodes 1 2 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->u[0] =-1. ; PE->v[0] = 0. ; PE->w[0] = 0. ; PE->u[1] = 1. ; PE->v[1] = 0. ; PE->w[1] = 0. ; POS_CUT_FILL ; break ; case TRIANGLE : case TRIANGLE_2 : PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 1 2 3 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->NumNodes[2] = GE->NumNodes[2] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] = 0. ; PE->u[1] = 1. ; PE->v[1] = 0. ; PE->w[1] = 0. ; PE->u[2] = 0. ; PE->v[2] = 1. ; PE->w[2] = 0. ; POS_CUT_FILL ; break ; case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N: if(DecomposeInSimplex){ PE = Create_PostElement(Index, TRIANGLE, 3, 1); /* nodes 1 2 4 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->NumNodes[2] = GE->NumNodes[3] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] = 0. ; PE->u[1] = 1. ; PE->v[1] =-1. ; PE->w[1] = 0. ; PE->u[2] =-1. ; PE->v[2] = 1. ; PE->w[2] = 0. ; POS_CUT_FILL; PE = Create_PostElement(Index, TRIANGLE, 3, 1); /* nodes 2 3 4 */ PE->NumNodes[0] = GE->NumNodes[1] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->NumNodes[2] = GE->NumNodes[3] ; PE->u[0] = 1. ; PE->v[0] =-1. ; PE->w[0] = 0. ; PE->u[1] = 1. ; PE->v[1] = 1. ; PE->w[1] = 0. ; PE->u[2] =-1. ; PE->v[2] = 1. ; PE->w[2] = 0. ; POS_CUT_FILL; } else{ if (!EvaluationPoints_L) { PE = Create_PostElement(Index, QUADRANGLE, 4, 1) ; /* nodes 1 2 3 4 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->NumNodes[2] = GE->NumNodes[2] ; PE->NumNodes[3] = GE->NumNodes[3] ; PE->u[0] = -1. ; PE->v[0] = -1. ; PE->w[0] = 0. ; PE->u[1] = 1. ; PE->v[1] = -1. ; PE->w[1] = 0. ; PE->u[2] = 1. ; PE->v[2] = 1. ; PE->w[2] = 0. ; PE->u[3] = -1. ; PE->v[3] = 1. ; PE->w[3] = 0. ; } else { /* Only for Quadrangles now, to be extended... */ Nbr_EP = List_Nbr(EvaluationPoints_L)/3; PE = Create_PostElement(Index, QUADRANGLE, Nbr_EP, 1) ; for (i_EP=0 ; i_EPu[i_EP]); List_Read(EvaluationPoints_L, i_EP*3+1, &PE->v[i_EP]); List_Read(EvaluationPoints_L, i_EP*3+2, &PE->w[i_EP]); } } POS_CUT_FILL ; } break ; case TETRAHEDRON : PE = Create_PostElement(Index, TETRAHEDRON, 4, 1) ; /* nodes 1 2 3 4 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->NumNodes[2] = GE->NumNodes[2] ; PE->NumNodes[3] = GE->NumNodes[3] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] = 0. ; PE->u[1] = 1. ; PE->v[1] = 0. ; PE->w[1] = 0. ; PE->u[2] = 0. ; PE->v[2] = 1. ; PE->w[2] = 0. ; PE->u[3] = 0. ; PE->v[3] = 0. ; PE->w[3] = 1. ; POS_CUT_FILL; break ; case HEXAHEDRON : if(DecomposeInSimplex){ PE = Create_PostElement(Index, TETRAHEDRON, 4, 1); /* nodes 1 2 3 6 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->NumNodes[2] = GE->NumNodes[2] ; PE->NumNodes[3] = GE->NumNodes[5] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] =-1. ; PE->u[1] = 1. ; PE->v[1] =-1. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] = 1. ; PE->w[2] =-1. ; PE->u[3] = 1. ; PE->v[3] =-1. ; PE->w[3] = 1. ; POS_CUT_FILL; PE = Create_PostElement(Index, TETRAHEDRON, 4, 1); /* nodes 1 3 6 7 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->NumNodes[2] = GE->NumNodes[5] ; PE->NumNodes[3] = GE->NumNodes[6] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] =-1. ; PE->u[1] = 1. ; PE->v[1] = 1. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] =-1. ; PE->w[2] = 1. ; PE->u[3] = 1. ; PE->v[3] = 1. ; PE->w[3] = 1. ; POS_CUT_FILL; PE = Create_PostElement(Index, TETRAHEDRON, 4, 1); /* nodes 1 5 6 7 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[4] ; PE->NumNodes[2] = GE->NumNodes[5] ; PE->NumNodes[3] = GE->NumNodes[6] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] =-1. ; PE->u[1] =-1. ; PE->v[1] =-1. ; PE->w[1] = 1. ; PE->u[2] = 1. ; PE->v[2] =-1. ; PE->w[2] = 1. ; PE->u[3] = 1. ; PE->v[3] = 1. ; PE->w[3] = 1. ; POS_CUT_FILL; PE = Create_PostElement(Index, TETRAHEDRON, 4, 1); /* nodes 1 3 4 7 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->NumNodes[2] = GE->NumNodes[3] ; PE->NumNodes[3] = GE->NumNodes[6] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] =-1. ; PE->u[1] = 1. ; PE->v[1] = 1. ; PE->w[1] =-1. ; PE->u[2] =-1. ; PE->v[2] = 1. ; PE->w[2] =-1. ; PE->u[3] = 1. ; PE->v[3] = 1. ; PE->w[3] = 1. ; POS_CUT_FILL; PE = Create_PostElement(Index, TETRAHEDRON, 4, 1); /* nodes 1 5 7 8 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[4] ; PE->NumNodes[2] = GE->NumNodes[6] ; PE->NumNodes[3] = GE->NumNodes[7] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] =-1. ; PE->u[1] =-1. ; PE->v[1] =-1. ; PE->w[1] = 1. ; PE->u[2] = 1. ; PE->v[2] = 1. ; PE->w[2] = 1. ; PE->u[3] =-1. ; PE->v[3] = 1. ; PE->w[3] = 1. ; POS_CUT_FILL; PE = Create_PostElement(Index, TETRAHEDRON, 4, 1); /* nodes 1 4 7 8 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[3] ; PE->NumNodes[2] = GE->NumNodes[6] ; PE->NumNodes[3] = GE->NumNodes[7] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] =-1. ; PE->u[1] =-1. ; PE->v[1] = 1. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] = 1. ; PE->w[2] = 1. ; PE->u[3] =-1. ; PE->v[3] = 1. ; PE->w[3] = 1. ; POS_CUT_FILL; } else{ PE = Create_PostElement(Index, HEXAHEDRON, 8, 1) ; /* nodes 1 2 3 4 5 6 7 8 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->NumNodes[2] = GE->NumNodes[2] ; PE->NumNodes[3] = GE->NumNodes[3] ; PE->NumNodes[4] = GE->NumNodes[4] ; PE->NumNodes[5] = GE->NumNodes[5] ; PE->NumNodes[6] = GE->NumNodes[6] ; PE->NumNodes[7] = GE->NumNodes[7] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] =-1. ; PE->u[1] = 1. ; PE->v[1] =-1. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] = 1. ; PE->w[2] =-1. ; PE->u[3] =-1. ; PE->v[3] = 1. ; PE->w[3] =-1. ; PE->u[4] =-1. ; PE->v[4] =-1. ; PE->w[4] = 1. ; PE->u[5] = 1. ; PE->v[5] =-1. ; PE->w[5] = 1. ; PE->u[6] = 1. ; PE->v[6] = 1. ; PE->w[6] = 1. ; PE->u[7] =-1. ; PE->v[7] = 1. ; PE->w[7] = 1. ; POS_CUT_FILL; } break ; case PRISM : if(DecomposeInSimplex){ PE = Create_PostElement(Index, TETRAHEDRON, 4, 1); /* nodes 1 2 3 5 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->NumNodes[2] = GE->NumNodes[2] ; PE->NumNodes[3] = GE->NumNodes[4] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] =-1. ; PE->u[1] = 1. ; PE->v[1] = 0. ; PE->w[1] =-1. ; PE->u[2] = 0. ; PE->v[2] = 1. ; PE->w[2] =-1. ; PE->u[3] = 1. ; PE->v[3] = 0. ; PE->w[3] = 1. ; POS_CUT_FILL; PE = Create_PostElement(Index, TETRAHEDRON, 4, 1); /* nodes 1 3 5 6 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->NumNodes[2] = GE->NumNodes[4] ; PE->NumNodes[3] = GE->NumNodes[5] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] =-1. ; PE->u[1] = 0. ; PE->v[1] = 1. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] = 0. ; PE->w[2] = 1. ; PE->u[3] = 0. ; PE->v[3] = 1. ; PE->w[3] = 1. ; POS_CUT_FILL; PE = Create_PostElement(Index, TETRAHEDRON, 4, 1); /* nodes 1 4 5 6 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[3] ; PE->NumNodes[2] = GE->NumNodes[4] ; PE->NumNodes[3] = GE->NumNodes[5] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] =-1. ; PE->u[1] = 0. ; PE->v[1] = 0. ; PE->w[1] = 1. ; PE->u[2] = 1. ; PE->v[2] = 0. ; PE->w[2] = 1. ; PE->u[3] = 0. ; PE->v[3] = 1. ; PE->w[3] = 1. ; POS_CUT_FILL; } else{ PE = Create_PostElement(Index, PRISM, 6, 1) ; /* nodes 1 2 3 4 5 6 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->NumNodes[2] = GE->NumNodes[2] ; PE->NumNodes[3] = GE->NumNodes[3] ; PE->NumNodes[4] = GE->NumNodes[4] ; PE->NumNodes[5] = GE->NumNodes[5] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] =-1. ; PE->u[1] = 1. ; PE->v[1] = 0. ; PE->w[1] =-1. ; PE->u[2] = 0. ; PE->v[2] = 1. ; PE->w[2] =-1. ; PE->u[3] = 0. ; PE->v[3] = 0. ; PE->w[3] = 1. ; PE->u[4] = 1. ; PE->v[4] = 0. ; PE->w[4] = 1. ; PE->u[5] = 0. ; PE->v[5] = 1. ; PE->w[5] = 1. ; POS_CUT_FILL; } break ; case PYRAMID : if(DecomposeInSimplex){ PE = Create_PostElement(Index, TETRAHEDRON, 4, 1); /* nodes 1 2 4 5 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->NumNodes[2] = GE->NumNodes[3] ; PE->NumNodes[3] = GE->NumNodes[4] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] = 0. ; PE->u[1] = 1. ; PE->v[1] =-1. ; PE->w[1] = 0. ; PE->u[2] =-1. ; PE->v[2] = 1. ; PE->w[2] = 0. ; PE->u[3] = 0. ; PE->v[3] = 0. ; PE->w[3] = 1. ; POS_CUT_FILL; PE = Create_PostElement(Index, TETRAHEDRON, 4, 1); /* nodes 2 3 4 5 */ PE->NumNodes[0] = GE->NumNodes[1] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->NumNodes[2] = GE->NumNodes[3] ; PE->NumNodes[3] = GE->NumNodes[4] ; PE->u[0] = 1. ; PE->v[0] =-1. ; PE->w[0] = 0. ; PE->u[1] = 1. ; PE->v[1] = 1. ; PE->w[1] = 0. ; PE->u[2] =-1. ; PE->v[2] = 1. ; PE->w[2] = 0. ; PE->u[3] = 0. ; PE->v[3] = 0. ; PE->w[3] = 1. ; POS_CUT_FILL; } else{ PE = Create_PostElement(Index, PYRAMID, 5, 1) ; /* nodes 1 2 3 4 5 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->NumNodes[2] = GE->NumNodes[2] ; PE->NumNodes[3] = GE->NumNodes[3] ; PE->NumNodes[4] = GE->NumNodes[4] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] = 0. ; PE->u[1] = 1. ; PE->v[1] =-1. ; PE->w[1] = 0. ; PE->u[2] = 1. ; PE->v[2] = 1. ; PE->w[2] = 0. ; PE->u[3] =-1. ; PE->v[3] = 1. ; PE->w[3] = 0. ; PE->u[4] = 0. ; PE->v[4] = 0. ; PE->w[4] = 1. ; POS_CUT_FILL; } break ; } } else { /* Skin: facets oriented with normals pointing outwards */ switch(GE->Type){ case TRIANGLE : PE = Create_PostElement(Index, LINE, 2, 1) ; /* nodes 1 2 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] = 0. ; PE->u[1] = 1. ; PE->v[1] = 0. ; PE->w[1] = 0. ; POS_CUT_SKIN ; PE = Create_PostElement(Index, LINE, 2, 1) ; /* nodes 2 3 */ PE->NumNodes[0] = GE->NumNodes[1] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->u[0] = 1. ; PE->v[0] = 0. ; PE->w[0] = 0. ; PE->u[1] = 0. ; PE->v[1] = 1. ; PE->w[1] = 0. ; POS_CUT_SKIN ; PE = Create_PostElement(Index, LINE, 2, 1) ; /* nodes 3 1 */ PE->NumNodes[0] = GE->NumNodes[2] ; PE->NumNodes[1] = GE->NumNodes[0] ; PE->u[0] = 0. ; PE->v[0] = 1. ; PE->w[0] = 0. ; PE->u[1] = 0. ; PE->v[1] = 0. ; PE->w[1] = 0. ; POS_CUT_SKIN ; break ; case QUADRANGLE : PE = Create_PostElement(Index, LINE, 2, 1) ; /* nodes 1 2 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] = 0. ; PE->u[1] = 1. ; PE->v[1] =-1. ; PE->w[1] = 0. ; POS_CUT_SKIN ; PE = Create_PostElement(Index, LINE, 2, 1) ; /* nodes 2 3 */ PE->NumNodes[0] = GE->NumNodes[1] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->u[0] = 1. ; PE->v[0] =-1. ; PE->w[0] = 0. ; PE->u[1] = 1. ; PE->v[1] = 1. ; PE->w[1] = 0. ; POS_CUT_SKIN ; PE = Create_PostElement(Index, LINE, 2, 1) ; /* nodes 3 4 */ PE->NumNodes[0] = GE->NumNodes[2] ; PE->NumNodes[1] = GE->NumNodes[3] ; PE->u[0] = 1. ; PE->v[0] = 1. ; PE->w[0] = 0. ; PE->u[1] =-1. ; PE->v[1] = 1. ; PE->w[1] = 0. ; POS_CUT_SKIN ; PE = Create_PostElement(Index, LINE, 2, 1) ; /* nodes 4 1 */ PE->NumNodes[0] = GE->NumNodes[3] ; PE->NumNodes[1] = GE->NumNodes[0] ; PE->u[0] =-1. ; PE->v[0] = 1. ; PE->w[0] = 0. ; PE->u[1] =-1. ; PE->v[1] =-1. ; PE->w[1] = 0. ; POS_CUT_SKIN ; break ; case TETRAHEDRON : PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 1 2 4 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->NumNodes[2] = GE->NumNodes[3] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] = 0. ; PE->u[1] = 1. ; PE->v[1] = 0. ; PE->w[1] = 0. ; PE->u[2] = 0. ; PE->v[2] = 0. ; PE->w[2] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 1 3 2 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->NumNodes[2] = GE->NumNodes[1] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] = 0. ; PE->u[1] = 0. ; PE->v[1] = 1. ; PE->w[1] = 0. ; PE->u[2] = 1. ; PE->v[2] = 0. ; PE->w[2] = 0. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 1 4 3 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[3] ; PE->NumNodes[2] = GE->NumNodes[2] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] = 0. ; PE->u[1] = 0. ; PE->v[1] = 0. ; PE->w[1] = 1. ; PE->u[2] = 0. ; PE->v[2] = 1. ; PE->w[2] = 0. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 2 3 4 */ PE->NumNodes[0] = GE->NumNodes[1] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->NumNodes[2] = GE->NumNodes[3] ; PE->u[0] = 1. ; PE->v[0] = 0. ; PE->w[0] = 0. ; PE->u[1] = 0. ; PE->v[1] = 1. ; PE->w[1] = 0. ; PE->u[2] = 0. ; PE->v[2] = 0. ; PE->w[2] = 1. ; POS_CUT_SKIN; break ; case HEXAHEDRON : if(DecomposeInSimplex){ PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 1 4 2 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[3] ; PE->NumNodes[2] = GE->NumNodes[1] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] =-1. ; PE->u[1] =-1. ; PE->v[1] = 1. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] =-1. ; PE->w[2] =-1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 2 4 3 */ PE->NumNodes[0] = GE->NumNodes[1] ; PE->NumNodes[1] = GE->NumNodes[3] ; PE->NumNodes[2] = GE->NumNodes[2] ; PE->u[0] = 1. ; PE->v[0] =-1. ; PE->w[0] =-1. ; PE->u[1] =-1. ; PE->v[1] = 1. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] = 1. ; PE->w[2] =-1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 5 6 8 */ PE->NumNodes[0] = GE->NumNodes[4] ; PE->NumNodes[1] = GE->NumNodes[5] ; PE->NumNodes[2] = GE->NumNodes[7] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] = 1. ; PE->u[1] = 1. ; PE->v[1] =-1. ; PE->w[1] = 1. ; PE->u[2] =-1. ; PE->v[2] = 1. ; PE->w[2] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 6 7 8 */ PE->NumNodes[0] = GE->NumNodes[5] ; PE->NumNodes[1] = GE->NumNodes[6] ; PE->NumNodes[2] = GE->NumNodes[7] ; PE->u[0] = 1. ; PE->v[0] =-1. ; PE->w[0] = 1. ; PE->u[1] = 1. ; PE->v[1] = 1. ; PE->w[1] = 1. ; PE->u[2] =-1. ; PE->v[2] = 1. ; PE->w[2] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 1 5 4 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[4] ; PE->NumNodes[2] = GE->NumNodes[3] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] =-1. ; PE->u[1] =-1. ; PE->v[1] =-1. ; PE->w[1] = 1. ; PE->u[2] =-1. ; PE->v[2] = 1. ; PE->w[2] =-1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 5 8 4 */ PE->NumNodes[0] = GE->NumNodes[4] ; PE->NumNodes[1] = GE->NumNodes[7] ; PE->NumNodes[2] = GE->NumNodes[3] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] = 1. ; PE->u[1] =-1. ; PE->v[1] = 1. ; PE->w[1] = 1. ; PE->u[2] =-1. ; PE->v[2] = 1. ; PE->w[2] =-1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 2 3 6 */ PE->NumNodes[0] = GE->NumNodes[1] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->NumNodes[2] = GE->NumNodes[5] ; PE->u[0] = 1. ; PE->v[0] =-1. ; PE->w[0] =-1. ; PE->u[1] = 1. ; PE->v[1] = 1. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] =-1. ; PE->w[2] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 6 3 7 */ PE->NumNodes[0] = GE->NumNodes[5] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->NumNodes[2] = GE->NumNodes[6] ; PE->u[0] = 1. ; PE->v[0] =-1. ; PE->w[0] = 1. ; PE->u[1] = 1. ; PE->v[1] = 1. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] = 1. ; PE->w[2] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 5 1 6 */ PE->NumNodes[0] = GE->NumNodes[4] ; PE->NumNodes[1] = GE->NumNodes[0] ; PE->NumNodes[2] = GE->NumNodes[5] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] = 1. ; PE->u[1] =-1. ; PE->v[1] =-1. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] =-1. ; PE->w[2] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 6 1 2 */ PE->NumNodes[0] = GE->NumNodes[5] ; PE->NumNodes[1] = GE->NumNodes[0] ; PE->NumNodes[2] = GE->NumNodes[1] ; PE->u[0] = 1. ; PE->v[0] =-1. ; PE->w[0] = 1. ; PE->u[1] =-1. ; PE->v[1] =-1. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] =-1. ; PE->w[2] =-1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 8 7 4 */ PE->NumNodes[0] = GE->NumNodes[7] ; PE->NumNodes[1] = GE->NumNodes[6] ; PE->NumNodes[2] = GE->NumNodes[3] ; PE->u[0] =-1. ; PE->v[0] = 1. ; PE->w[0] = 1. ; PE->u[1] = 1. ; PE->v[1] = 1. ; PE->w[1] = 1. ; PE->u[2] =-1. ; PE->v[2] = 1. ; PE->w[2] =-1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 7 3 4 */ PE->NumNodes[0] = GE->NumNodes[6] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->NumNodes[2] = GE->NumNodes[3] ; PE->u[0] = 1. ; PE->v[0] = 1. ; PE->w[0] = 1. ; PE->u[1] = 1. ; PE->v[1] = 1. ; PE->w[1] =-1. ; PE->u[2] =-1. ; PE->v[2] = 1. ; PE->w[2] =-1. ; POS_CUT_SKIN; } else{ PE = Create_PostElement(Index, QUADRANGLE, 4, 1) ; /* nodes 1 2 6 5 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->NumNodes[2] = GE->NumNodes[5] ; PE->NumNodes[3] = GE->NumNodes[4] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] =-1. ; PE->u[1] = 1. ; PE->v[1] =-1. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] =-1. ; PE->w[2] = 1. ; PE->u[3] =-1. ; PE->v[3] =-1. ; PE->w[3] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, QUADRANGLE, 4, 1) ; /* nodes 1 4 3 2 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[3] ; PE->NumNodes[2] = GE->NumNodes[2] ; PE->NumNodes[3] = GE->NumNodes[1] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] =-1. ; PE->u[1] =-1. ; PE->v[1] = 1. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] = 1. ; PE->w[2] =-1. ; PE->u[3] = 1. ; PE->v[3] =-1. ; PE->w[3] =-1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, QUADRANGLE, 4, 1) ; /* nodes 1 5 8 4 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[4] ; PE->NumNodes[2] = GE->NumNodes[7] ; PE->NumNodes[3] = GE->NumNodes[3] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] =-1. ; PE->u[1] =-1. ; PE->v[1] =-1. ; PE->w[1] = 1. ; PE->u[2] =-1. ; PE->v[2] = 1. ; PE->w[2] = 1. ; PE->u[3] =-1. ; PE->v[3] = 1. ; PE->w[3] =-1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, QUADRANGLE, 4, 1) ; /* nodes 2 3 7 6 */ PE->NumNodes[0] = GE->NumNodes[1] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->NumNodes[2] = GE->NumNodes[6] ; PE->NumNodes[3] = GE->NumNodes[5] ; PE->u[0] = 1. ; PE->v[0] =-1. ; PE->w[0] =-1. ; PE->u[1] = 1. ; PE->v[1] = 1. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] = 1. ; PE->w[2] = 1. ; PE->u[3] = 1. ; PE->v[3] =-1. ; PE->w[3] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, QUADRANGLE, 4, 1) ; /* nodes 3 4 8 7 */ PE->NumNodes[0] = GE->NumNodes[2] ; PE->NumNodes[1] = GE->NumNodes[3] ; PE->NumNodes[2] = GE->NumNodes[7] ; PE->NumNodes[3] = GE->NumNodes[6] ; PE->u[0] = 1. ; PE->v[0] = 1. ; PE->w[0] =-1. ; PE->u[1] =-1. ; PE->v[1] = 1. ; PE->w[1] =-1. ; PE->u[2] =-1. ; PE->v[2] = 1. ; PE->w[2] = 1. ; PE->u[3] = 1. ; PE->v[3] = 1. ; PE->w[3] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, QUADRANGLE, 4, 1) ; /* nodes 5 6 7 8 */ PE->NumNodes[0] = GE->NumNodes[4] ; PE->NumNodes[1] = GE->NumNodes[5] ; PE->NumNodes[2] = GE->NumNodes[6] ; PE->NumNodes[3] = GE->NumNodes[7] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] = 1. ; PE->u[1] = 1. ; PE->v[1] =-1. ; PE->w[1] = 1. ; PE->u[2] = 1. ; PE->v[2] = 1. ; PE->w[2] = 1. ; PE->u[3] =-1. ; PE->v[3] = 1. ; PE->w[3] = 1. ; POS_CUT_SKIN; } break ; case PRISM : PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 1 3 2 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->NumNodes[2] = GE->NumNodes[1] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] =-1. ; PE->u[1] = 0. ; PE->v[1] = 1. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] = 0. ; PE->w[2] =-1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 4 5 6 */ PE->NumNodes[0] = GE->NumNodes[3] ; PE->NumNodes[1] = GE->NumNodes[4] ; PE->NumNodes[2] = GE->NumNodes[5] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] = 1. ; PE->u[1] = 1. ; PE->v[1] = 0. ; PE->w[1] = 1. ; PE->u[2] = 0. ; PE->v[2] = 1. ; PE->w[2] = 1. ; POS_CUT_SKIN; if(DecomposeInSimplex){ PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 1 2 5 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->NumNodes[2] = GE->NumNodes[4] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] =-1. ; PE->u[1] = 1. ; PE->v[1] = 0. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] = 0. ; PE->w[2] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 1 5 4 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[4] ; PE->NumNodes[2] = GE->NumNodes[3] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] =-1. ; PE->u[1] = 1. ; PE->v[1] = 0. ; PE->w[1] = 1. ; PE->u[2] = 0. ; PE->v[2] = 0. ; PE->w[2] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 1 6 3 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[5] ; PE->NumNodes[2] = GE->NumNodes[2] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] =-1. ; PE->u[1] = 0. ; PE->v[1] = 1. ; PE->w[1] = 1. ; PE->u[2] = 0. ; PE->v[2] = 1. ; PE->w[2] =-1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 1 4 6 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[3] ; PE->NumNodes[2] = GE->NumNodes[5] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] =-1. ; PE->u[1] = 0. ; PE->v[1] = 0. ; PE->w[1] = 1. ; PE->u[2] = 0. ; PE->v[2] = 1. ; PE->w[2] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 2 3 5 */ PE->NumNodes[0] = GE->NumNodes[1] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->NumNodes[2] = GE->NumNodes[4] ; PE->u[0] = 1. ; PE->v[0] = 0. ; PE->w[0] =-1. ; PE->u[1] = 0. ; PE->v[1] = 1. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] = 0. ; PE->w[2] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 3 6 5 */ PE->NumNodes[0] = GE->NumNodes[2] ; PE->NumNodes[1] = GE->NumNodes[5] ; PE->NumNodes[2] = GE->NumNodes[4] ; PE->u[0] = 0. ; PE->v[0] = 1. ; PE->w[0] =-1. ; PE->u[1] = 0. ; PE->v[1] = 1. ; PE->w[1] = 1. ; PE->u[2] = 1. ; PE->v[2] = 0. ; PE->w[2] = 1. ; POS_CUT_SKIN; } else{ PE = Create_PostElement(Index, QUADRANGLE, 4, 1) ; /* nodes 1 2 5 4 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->NumNodes[2] = GE->NumNodes[4] ; PE->NumNodes[3] = GE->NumNodes[3] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] =-1. ; PE->u[1] = 1. ; PE->v[1] = 0. ; PE->w[1] =-1. ; PE->u[2] = 1. ; PE->v[2] = 0. ; PE->w[2] = 1. ; PE->u[3] = 0. ; PE->v[3] = 0. ; PE->w[3] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, QUADRANGLE, 4, 1) ; /* nodes 1 4 6 3 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[3] ; PE->NumNodes[2] = GE->NumNodes[5] ; PE->NumNodes[3] = GE->NumNodes[2] ; PE->u[0] = 0. ; PE->v[0] = 0. ; PE->w[0] =-1. ; PE->u[1] = 0. ; PE->v[1] = 0. ; PE->w[1] = 1. ; PE->u[2] = 0. ; PE->v[2] = 1. ; PE->w[2] = 1. ; PE->u[3] = 0. ; PE->v[3] = 1. ; PE->w[3] =-1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, QUADRANGLE, 4, 1) ; /* nodes 2 3 6 5 */ PE->NumNodes[0] = GE->NumNodes[1] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->NumNodes[2] = GE->NumNodes[5] ; PE->NumNodes[3] = GE->NumNodes[4] ; PE->u[0] = 1. ; PE->v[0] = 0. ; PE->w[0] =-1. ; PE->u[1] = 0. ; PE->v[1] = 1. ; PE->w[1] =-1. ; PE->u[2] = 0. ; PE->v[2] = 1. ; PE->w[2] = 1. ; PE->u[3] = 1. ; PE->v[3] = 0. ; PE->w[3] = 1. ; POS_CUT_SKIN; } break ; case PYRAMID : PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 1 2 5 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[1] ; PE->NumNodes[2] = GE->NumNodes[4] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] = 0. ; PE->u[1] = 1. ; PE->v[1] =-1. ; PE->w[1] = 0. ; PE->u[2] = 0. ; PE->v[2] = 0. ; PE->w[2] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 2 3 5 */ PE->NumNodes[0] = GE->NumNodes[1] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->NumNodes[2] = GE->NumNodes[4] ; PE->u[0] = 1. ; PE->v[0] =-1. ; PE->w[0] = 0. ; PE->u[1] = 1. ; PE->v[1] = 1. ; PE->w[1] = 0. ; PE->u[2] = 0. ; PE->v[2] = 0. ; PE->w[2] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 3 4 5 */ PE->NumNodes[0] = GE->NumNodes[2] ; PE->NumNodes[1] = GE->NumNodes[3] ; PE->NumNodes[2] = GE->NumNodes[4] ; PE->u[0] = 1. ; PE->v[0] = 1. ; PE->w[0] = 0. ; PE->u[1] =-1. ; PE->v[1] = 1. ; PE->w[1] = 0. ; PE->u[2] = 0. ; PE->v[2] = 0. ; PE->w[2] = 1. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 4 1 5 */ PE->NumNodes[0] = GE->NumNodes[3] ; PE->NumNodes[1] = GE->NumNodes[0] ; PE->NumNodes[2] = GE->NumNodes[4] ; PE->u[0] =-1. ; PE->v[0] = 1. ; PE->w[0] = 0. ; PE->u[1] =-1. ; PE->v[1] =-1. ; PE->w[1] = 0. ; PE->u[2] = 0. ; PE->v[2] = 0. ; PE->w[2] = 1. ; POS_CUT_SKIN; if(DecomposeInSimplex){ PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 1 3 2 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[2] ; PE->NumNodes[2] = GE->NumNodes[1] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] = 0. ; PE->u[1] = 1. ; PE->v[1] = 1. ; PE->w[1] = 0. ; PE->u[2] = 1. ; PE->v[2] =-1. ; PE->w[2] = 0. ; POS_CUT_SKIN; PE = Create_PostElement(Index, TRIANGLE, 3, 1) ; /* nodes 1 4 3 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[3] ; PE->NumNodes[2] = GE->NumNodes[2] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] = 0. ; PE->u[1] =-1. ; PE->v[1] = 1. ; PE->w[1] = 0. ; PE->u[2] = 1. ; PE->v[2] = 1. ; PE->w[2] = 0. ; POS_CUT_SKIN; } else{ PE = Create_PostElement(Index, QUADRANGLE, 4, 1) ; /* nodes 1 4 3 2 */ PE->NumNodes[0] = GE->NumNodes[0] ; PE->NumNodes[1] = GE->NumNodes[3] ; PE->NumNodes[2] = GE->NumNodes[2] ; PE->NumNodes[3] = GE->NumNodes[1] ; PE->u[0] =-1. ; PE->v[0] =-1. ; PE->w[0] = 0. ; PE->u[1] =-1. ; PE->v[1] = 1. ; PE->w[1] = 0. ; PE->u[2] = 1. ; PE->v[2] = 1. ; PE->w[2] = 0. ; PE->u[3] = 1. ; PE->v[3] =-1. ; PE->w[3] = 0. ; POS_CUT_SKIN; } break ; } } } } #undef POS_CUT_FILL #undef POS_CUT_SKIN /* ------------------------------------------------------------------------ */ /* S o r t B y C o n n e c t i v i t y */ /* ------------------------------------------------------------------------ */ int Compare_PostElement_Node(struct PostElement * PE1, int n1, struct PostElement * PE2, int n2) { double TOL=Current.GeoData->CharacteristicLength * 1.e-8; if ( (fabs(PE1->x[n1] - PE2->x[n2]) < TOL) && (fabs(PE1->y[n1] - PE2->y[n2]) < TOL) && (fabs(PE1->z[n1] - PE2->z[n2]) < TOL) ) return 1 ; return 0 ; } void Sort_PostElement_Connectivity(List_T *PostElement_L) { int ii, jj, start, end, iPost, NbrPost ; struct PostElement *PE, *PE2 ; NbrPost = List_Nbr(PostElement_L) ; /* u[0] = 1 if the element is in the ordered list, with natural orientation -1 if the element is in the ordered list, but with opposite orientation 0 if the element is not in the list v[0] = relative index (to the first element) in the ordered list */ for(ii = 0 ; ii < NbrPost ; ii++){ PE = *(struct PostElement**)List_Pointer(PostElement_L, ii); if(PE->NbrNodes != 2){ Message::Error("Connectivity sorting impossible for %d-noded elements", PE->NbrNodes) ; return; } PE->u[0] = 0. ; } PE = *(struct PostElement**)List_Pointer(PostElement_L, 0); PE->u[0] = 1. ; PE->v[0] = 0. ; iPost = 1 ; while(iPost < NbrPost){ for(ii = 0 ; ii < NbrPost ; ii++){ PE = *(struct PostElement**)List_Pointer(PostElement_L, ii); if(PE->u[0]){ if(PE->u[0] > 0){ start = 0 ; end = 1 ; } else{ start = 1 ; end = 0 ; } for(jj = 0 ; jj < NbrPost ; jj++){ if(jj != ii){ PE2 = *(struct PostElement**)List_Pointer(PostElement_L, jj); if(!PE2->u[0]){ if(Compare_PostElement_Node(PE, end, PE2, 0)){ PE2->u[0] = 1. ; PE2->v[0] = PE->v[0] + 1. ; iPost++ ; } else if (Compare_PostElement_Node(PE, start, PE2, 0)){ PE2->u[0] = -1. ; PE2->v[0] = PE->v[0] - 1. ; iPost++ ; } else if (Compare_PostElement_Node(PE, start, PE2, 1)){ PE2->u[0] = 1. ; PE2->v[0] = PE->v[0] - 1. ; iPost++ ; } else if (Compare_PostElement_Node(PE, end, PE2, 1)){ PE2->u[0] = -1. ; PE2->v[0] = PE->v[0] + 1. ; iPost++ ; } } } } } } List_Sort(PostElement_L, fcmp_PostElement_absu0) ; } List_Sort(PostElement_L, fcmp_PostElement_v0) ; } getdp-2.4.2-source/Legacy/BF_Edge.cpp000644 001750 001750 00000030360 12116424202 020717 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Christophe Trophime // #include "ProData.h" #include "Message.h" #define SQU(a) ((a)*(a)) #define NoEdge Message::Error("Missing Edge Entity in Element %d", Element->Num) /* ------------------------------------------------------------------------ */ /* B F _ E d g e */ /* ------------------------------------------------------------------------ */ #define WrongNumEdge Message::Error("Wrong Edge number in 'BF_Edge'") void BF_Edge(struct Element * Element, int NumEdge, double u, double v, double w, double s[]) { switch (Element->Type) { case LINE : switch(NumEdge) { case 1 : s[0] = 0.5 ; s[1] = 0. ; s[2] = 0. ; break ; default : WrongNumEdge ; } break ; case TRIANGLE : switch(NumEdge) { case 1 : s[0] = 1.-v ; s[1] = u ; s[2] = 0. ; break ; case 2 : s[0] = v ; s[1] = 1.-u ; s[2] = 0. ; break ; case 3 : s[0] = -v ; s[1] = u ; s[2] = 0. ; break ; default : WrongNumEdge ; } break ; case QUADRANGLE : switch(NumEdge) { case 1 : s[0] = 0.25 * (1.-v) ; s[1] = 0. ; s[2] = 0. ; break ; case 2 : s[0] = 0. ; s[1] = 0.25 * (1.-u) ; s[2] = 0. ; break ; case 3 : s[0] = 0. ; s[1] = 0.25 * (1.+u) ; s[2] = 0. ; break ; case 4 : s[0] = -0.25 * (1.+v) ; s[1] = 0. ; s[2] = 0. ; break ; default : WrongNumEdge ; } break ; case TETRAHEDRON : switch(NumEdge) { case 1 : s[0] = 1.-v-w ; s[1] = u ; s[2] = u ; break ; case 2 : s[0] = v ; s[1] = 1.-u-w ; s[2] = v ; break ; case 3 : s[0] = w ; s[1] = w ; s[2] = 1.-u-v ; break ; case 4 : s[0] = -v ; s[1] = u ; s[2] = 0. ; break ; case 5 : s[0] = -w ; s[1] = 0. ; s[2] = u ; break ; case 6 : s[0] = 0. ; s[1] = -w ; s[2] = v ; break ; default : WrongNumEdge ; } break ; case HEXAHEDRON : switch(NumEdge) { case 1 : s[0] = 0.125 * (1.-v) * (1.-w) ; s[1] = 0. ; s[2] = 0. ; break ; case 6 : s[0] = -0.125 * (1.+v) * (1.-w) ; s[1] = 0. ; s[2] = 0. ; break ; case 9 : s[0] = 0.125 * (1.-v) * (1.+w) ; s[1] = 0. ; s[2] = 0. ; break ; case 12 : s[0] = -0.125 * (1.+v) * (1.+w) ; s[1] = 0. ; s[2] = 0. ; break ; case 2 : s[0] = 0. ; s[1] = 0.125 * (1.-u) * (1.-w) ; s[2] = 0. ; break ; case 4 : s[0] = 0. ; s[1] = 0.125 * (1.+u) * (1.-w) ; s[2] = 0. ; break ; case 10 : s[0] = 0. ; s[1] = 0.125 * (1.-u) * (1.+w) ; s[2] = 0. ; break ; case 11 : s[0] = 0. ; s[1] = 0.125 * (1.+u) * (1.+w) ; s[2] = 0. ; break ; case 3 : s[0] = 0. ; s[1] = 0. ; s[2] = 0.125 * (1.-u) * (1.-v) ; break ; case 5 : s[0] = 0. ; s[1] = 0. ; s[2] = 0.125 * (1.+u) * (1.-v) ; break ; case 7 : s[0] = 0. ; s[1] = 0. ; s[2] = 0.125 * (1.+u) * (1.+v) ; break ; case 8 : s[0] = 0. ; s[1] = 0. ; s[2] = 0.125 * (1.-u) * (1.+v) ; break ; default : WrongNumEdge ; } break ; case PRISM : switch(NumEdge) { case 1 : s[0] = 0.5 * (1.-v) * (1.-w) ; s[1] = 0.5 * u * (1.-w) ; s[2] = 0. ; break ; case 2 : s[0] = 0.5 * v * (1.-w) ; s[1] = 0.5 * (1.-u) * (1.-w) ; s[2] = 0. ; break ; case 3 : s[0] = 0. ; s[1] = 0. ; s[2] = 0.5 * (1.-u-v) ; break ; case 4 : s[0] = -0.5 * v * (1.-w) ; s[1] = 0.5 * u * (1.-w) ; s[2] = 0. ; break ; case 5 : s[0] = 0. ; s[1] = 0. ; s[2] = 0.5 * u ; break ; case 6 : s[0] = 0. ; s[1] = 0. ; s[2] = 0.5 * v ; break ; case 7 : s[0] = 0.5 * (1.-v) * (1.+w) ; s[1] = 0.5 * u * (1.+w) ; s[2] = 0. ; break ; case 8 : s[0] = 0.5 * v * (1.+w) ; s[1] = 0.5 * (1.-u) * (1.+w) ; s[2] = 0. ; break ; case 9 : s[0] = -0.5 * v * (1.+w) ; s[1] = 0.5 * u * (1.+w) ; s[2] = 0. ; break ; default : WrongNumEdge ; } break ; case PYRAMID : if (w != 1){ switch(NumEdge) { case 1 : s[0] = 0.25 * (1 - v - w) ; s[1] = 0. ; s[2] = 0.25 * (u - u * v / (1. - w)) ; break ; case 2 : s[0] = 0. ; s[1] = 0.25 * (1 - u - w) ; s[2] = 0.25 * (v - u * v / (1. - w)) ; break ; case 4 : s[0] = 0. ; s[1] = 0.25 * (1 + u - w) ; s[2] = 0.25 * (v + u * v / (1. - w)) ; break ; case 6 : s[0] = -0.25 * (1 + v - w) ; s[1] = 0. ; s[2] = -0.25 * (u + u * v / (1. - w)) ; break ; case 3 : s[0] = 0.25 * (w - v * w / (1. - w)) ; s[1] = 0.25 * (w - u * w / (1. - w)) ; s[2] = 0.25 * (1. - u - v + u * v / SQU(1. - w) - 2 * u * v * w / SQU(1. - w)) ; break ; case 5 : s[0] = -0.25 * (w - v * w / (1. - w)) ; s[1] = 0.25 * (w + u * w / (1. - w)) ; s[2] = 0.25 * (1. + u - v - u * v / SQU(1. - w) + 2 * u * v * w / SQU(1. - w)) ; break ; case 7 : s[0] = -0.25 * (w + v * w / (1. - w)) ; s[1] = -0.25 * (w + u * w / (1. - w)) ; s[2] = 0.25 * (1. + u + v + u * v / SQU(1. - w) - 2 * u * v * w / SQU(1. - w)) ; break ; case 8 : s[0] = 0.25 * (w + v * w / (1. - w)) ; s[1] = -0.25 * (w - u * w / (1. - w)) ; s[2] = 0.25 * (1. - u + v - u * v / SQU(1. - w) + 2 * u * v * w / SQU(1. - w)) ; break ; default : WrongNumEdge ; } } else switch(NumEdge) { case 1 : s[0] = -0.25 * v ; s[1] = 0. ; s[2] = 0.25 * u ; break ; case 2 : s[0] = 0. ; s[1] = -0.25 * u ; s[2] = 0.25 * v ; break ; case 4 : s[0] = 0. ; s[1] = 0.25 * u ; s[2] = 0.25 * v ; break ; case 6 : s[0] = -0.25 * v ; s[1] = 0. ; s[2] = -0.25 * u ; break ; case 3 : s[0] = 0.25 ; s[1] = 0.25 ; s[2] = 0.25 * (1. - u - v) ; break ; case 5 : s[0] = -0.25 ; s[1] = 0.25 ; s[2] = 0.25 * (1. + u - v) ; break ; case 7 : s[0] = -0.25 ; s[1] = -0.25 ; s[2] = 0.25 * (1. + u + v) ; break ; case 8 : s[0] = 0.25 ; s[1] = -0.25 ; s[2] = 0.25 * (1. - u + v) ; break ; default : WrongNumEdge ; } break ; default : Message::Error("Unkown type of Element in BF_Edge"); break; } if (!Element->GeoElement->NumEdges) NoEdge ; if (Element->GeoElement->NumEdges[NumEdge-1] < 0) { s[0] = - s[0] ; s[1] = - s[1] ; s[2] = - s[2] ; } } #undef WrongNumEdge /* ------------------------------------------------------------------------ */ /* B F _ C u r l E d g e */ /* ------------------------------------------------------------------------ */ #define WrongNumEdge Message::Error("Wrong Edge number in 'BF_CurlEdge'") void BF_CurlEdge(struct Element * Element, int NumEdge, double u, double v, double w, double s[]) { switch (Element->Type) { case LINE : switch(NumEdge) { case 1 : s[0] = 0. ; s[1] = 0. ; s[2] = 0. ; break ; default : WrongNumEdge ; } break ; case TRIANGLE : switch(NumEdge) { case 1 : s[0] = 0. ; s[1] = 0. ; s[2] = 2. ; break ; case 2 : s[0] = 0. ; s[1] = 0. ; s[2] = -2. ; break ; case 3 : s[0] = 0. ; s[1] = 0. ; s[2] = 2. ; break ; default : WrongNumEdge ; } break ; case QUADRANGLE : switch(NumEdge) { case 1 : s[0] = 0. ; s[1] = 0. ; s[2] = 0.25 ; break ; case 2 : s[0] = 0. ; s[1] = 0. ; s[2] = -0.25 ; break ; case 3 : s[0] = 0. ; s[1] = 0. ; s[2] = 0.25 ; break ; case 4 : s[0] = 0. ; s[1] = 0. ; s[2] = 0.25 ; break ; default : WrongNumEdge ; } break ; case TETRAHEDRON : switch(NumEdge) { case 1 : s[0] = 0. ; s[1] = -2. ; s[2] = 2. ; break ; case 2 : s[0] = 2. ; s[1] = 0. ; s[2] = -2. ; break ; case 3 : s[0] = -2. ; s[1] = 2. ; s[2] = 0. ; break ; case 4 : s[0] = 0. ; s[1] = 0. ; s[2] = 2. ; break ; case 5 : s[0] = 0. ; s[1] = -2. ; s[2] = 0. ; break ; case 6 : s[0] = 2. ; s[1] = 0. ; s[2] = 0. ; break ; default : WrongNumEdge ; } break ; case HEXAHEDRON : switch(NumEdge) { case 1 : s[0] = 0. ; s[1] = 0.125*(v-1.) ; s[2] = 0.125*(1.-w) ; break ; case 6 : s[0] = 0. ; s[1] = 0.125*(v+1.) ; s[2] = 0.125*(1.-w) ; break ; case 9 : s[0] = 0. ; s[1] = 0.125*(1.-v) ; s[2] = 0.125*(1.+w) ; break ; case 12 : s[0] = 0. ; s[1] =-0.125*(v+1.) ; s[2] = 0.125*(1.+w) ; break ; case 2 : s[0] = 0.125*(1.-u) ; s[1] = 0. ; s[2] = 0.125*(w-1.) ; break ; case 4 : s[0] = 0.125*(1.+u) ; s[1] = 0. ; s[2] = 0.125*(1.-w) ; break ; case 10 : s[0] = 0.125*(u-1.) ; s[1] = 0. ; s[2] =-0.125*(w+1.) ; break ; case 11 : s[0] =-0.125*(1.+u) ; s[1] = 0. ; s[2] = 0.125*(w+1.) ; break ; case 3 : s[0] = 0.125*(u-1.) ; s[1] = 0.125*(1.-v) ; s[2] = 0. ; break ; case 5 : s[0] =-0.125*(u+1.) ; s[1] = 0.125*(v-1.) ; s[2] = 0. ; break ; case 7 : s[0] = 0.125*(u+1.) ; s[1] =-0.125*(1.+v) ; s[2] = 0. ; break ; case 8 : s[0] = 0.125*(1.-u) ; s[1] = 0.125*(1.+v) ; s[2] = 0. ; break ; default : WrongNumEdge ; } break ; case PRISM : switch(NumEdge) { case 1 : s[0] = 0.5*u ; s[1] = 0.5*(v-1.) ; s[2] = 1.-w ; break ; case 2 : s[0] = 0.5*(1.-u) ; s[1] = -0.5*v ; s[2] = w-1. ; break ; case 3 : s[0] = -0.5 ; s[1] = 0.5 ; s[2] = 0. ; break ; case 4 : s[0] = 0.5*u ; s[1] = 0.5*v ; s[2] = 1.-w ; break ; case 5 : s[0] = 0. ; s[1] = -0.5 ; s[2] = 0. ; break ; case 6 : s[0] = 0.5 ; s[1] = 0. ; s[2] = 0. ; break ; case 7 : s[0] = -0.5*u ; s[1] = 0.5*(1.-v) ; s[2] = 1.+w ; break ; case 8 : s[0] = 0.5*(u-1.) ; s[1] = 0.5*v ; s[2] = -1.-w ; break ; case 9 : s[0] = -0.5*u ; s[1] = -0.5*v ; s[2] = 1.+w ; break ; default : WrongNumEdge ; } break ; case PYRAMID : if (w != 1){ switch(NumEdge) { case 1 : s[0] = -0.25 * u / (1. - w) ; s[1] = -0.5 + 0.25 * v / (1. - w) ; s[2] = 0.25 ; break ; case 2 : s[0] = 0.5 - 0.25 * u / (1. - w) ; s[1] = 0.25 * v / (1. - w) ; s[2] = -0.25 ; break ; case 4 : s[0] = 0.5 + 0.25 * u / (1. - w) ; s[1] = -0.25 * v / (1. - w) ; s[2] = 0.25 ; break ; case 6 : s[0] = -0.25 * u / (1. - w) ; s[1] = 0.5 + 0.25 * v / (1. - w) ; s[2] = 0.25 ; break ; case 3 : s[0] = -0.5 * (1. - u / (1. - w)) ; s[1] = 0.5 * (1. - v / (1. - w)) ; s[2] = 0. ; break; case 5 : s[0] = -0.5 * (1. + u / (1. - w)) ; s[1] = -0.5 * (1. - v / (1. - w)) ; s[2] = 0. ; break; case 7 : s[0] = 0.5 * (1. + u / (1. - w)) ; s[1] = -0.5 * (1. + v / (1. - w)) ; s[2] = 0. ; break; case 8 : s[0] = 0.5 * (1. - u / (1. - w)) ; s[1] = 0.5 * (1. + v / (1. - w)) ; s[2] = 0. ; break; default : WrongNumEdge ; } } else { switch(NumEdge) { case 1 : s[0] = 0. ; s[1] = -0.5 ; s[2] = 0.25 ; break ; case 2 : s[0] = 0.5 ; s[1] = 0. ; s[2] = -0.25 ; break ; case 4 : s[0] = 0.5 ; s[1] = 0. ; s[2] = 0.25 ; break ; case 6 : s[0] = 0. ; s[1] = 0.5 ; s[2] = 0.25 ; break ; case 3 : s[0] = -0.5 ; s[1] = 0.5 ; s[2] = 0. ; break; case 5 : s[0] = -0.5 ; s[1] = -0.5 ; s[2] = 0. ; break; case 7 : s[0] = 0.5 ; s[1] = -0.5 ; s[2] = 0. ; break; case 8 : s[0] = 0.5 ; s[1] = 0.5 ; s[2] = 0. ; break; default : WrongNumEdge ; } } break ; default : Message::Error("Unkown type of Element in BF_CurlEdge"); break; } if (!Element->GeoElement->NumEdges) NoEdge ; if (Element->GeoElement->NumEdges[NumEdge-1] < 0) { s[0] = - s[0] ; s[1] = - s[1] ; s[2] = - s[2] ; } } #undef WrongNumEdge #undef NoEdge getdp-2.4.2-source/Legacy/Cal_SolutionErrorRatio.cpp000644 001750 001750 00000012424 12116424202 024111 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Michael Asam #include #include #include #include "ProData.h" #include "DofData.h" #include "SolvingOperations.h" #include "Message.h" void Cal_SolutionErrorRatio(gVector *dx, gVector *x, double reltol, double abstol, int NormType, double *ErrorRatio) { int xLength; double AbsVal_x, AbsVal_dx, ImagVal_x, ImagVal_dx; double *ErrorRatioVec; bool Is_NaN_or_Inf; LinAlg_GetVectorSize(dx, &xLength); ErrorRatioVec = new double[xLength]; *ErrorRatio = 0.; Is_NaN_or_Inf = false; for (int i = 0; i < xLength; i++) { if (gSCALAR_SIZE == 1) { LinAlg_GetAbsDoubleInVector(&AbsVal_x, x, i) ; LinAlg_GetAbsDoubleInVector(&AbsVal_dx, dx, i) ; } if (gSCALAR_SIZE == 2) { LinAlg_GetComplexInVector(&AbsVal_x, &ImagVal_x, x, i, -1); LinAlg_GetComplexInVector(&AbsVal_dx, &ImagVal_dx, dx, i, -1); AbsVal_x = sqrt( AbsVal_x*AbsVal_x + ImagVal_x*ImagVal_x); AbsVal_dx = sqrt( AbsVal_dx*AbsVal_dx + ImagVal_dx*ImagVal_dx); } ErrorRatioVec[i] = AbsVal_dx / (abstol + reltol * AbsVal_x); if ( ErrorRatioVec[i] != ErrorRatioVec[i] || // Solution is NaN ErrorRatioVec[i] == -std::numeric_limits::infinity() || // Solution is -Inf ErrorRatioVec[i] == std::numeric_limits::infinity() ) // Solution is Inf Is_NaN_or_Inf = true; } if ( Is_NaN_or_Inf ) { Message::Warning("No valid solution found (NaN or Inf)!"); *ErrorRatio = std::numeric_limits::quiet_NaN(); } else{ // Calculating the norm of the error ratio vector switch (NormType){ case LINFNORM: for (int i = 0; i < xLength; i++) { if (ErrorRatioVec[i] > *ErrorRatio) *ErrorRatio = ErrorRatioVec[i]; } break; case L1NORM: for (int i = 0; i < xLength; i++) { *ErrorRatio += ErrorRatioVec[i]; } break; case MEANL1NORM: for (int i = 0; i < xLength; i++) { *ErrorRatio += ErrorRatioVec[i]; } *ErrorRatio /= xLength; break; case L2NORM: for (int i = 0; i < xLength; i++) { *ErrorRatio += ErrorRatioVec[i] * ErrorRatioVec[i]; } *ErrorRatio = sqrt(*ErrorRatio); break; case MEANL2NORM: for (int i = 0; i < xLength; i++) { *ErrorRatio += ErrorRatioVec[i] * ErrorRatioVec[i]; } *ErrorRatio = sqrt(*ErrorRatio / xLength); break; default: Message::Error("Wrong error norm in Cal_SolutionErrorRatio"); break; } } delete [] ErrorRatioVec; } /* ------------------------------------------------------------------------ */ /* C a l _ S o l u t i o n E r r o r */ /* ------------------------------------------------------------------------ */ void Cal_SolutionError(gVector *dx, gVector *x, int diff, double *MeanError) { // This is not a very good implementation: it should be replaced with // Cal_SolutionErrorRatio above int i, n; double valx, valdx, valxi = 0., valdxi = 0.,errsqr = 0., xmoy = 0., dxmoy = 0.; double tol, nvalx, nvaldx ; LinAlg_GetVectorSize(dx, &n); if (gSCALAR_SIZE == 1) for (i=0 ; i 1.e-30) { tol = xmoy*1.e-10 ; if (gSCALAR_SIZE == 1) for (i=0 ; i tol) errsqr += fabs(valdx-valx)/valx ; else errsqr += fabs(valdx-valx) ; } else{ if (valx > tol) errsqr += valdx/valx ; else errsqr += valdx ; } } if (gSCALAR_SIZE == 2) for (i=0 ; i tol) errsqr += sqrt((valdx-valx)*(valdx-valx)+(valdxi-valxi)*(valdxi-valxi))/nvalx ; else errsqr += sqrt((valdx-valx)*(valdx-valx)+(valdxi-valxi)*(valdxi-valxi)); } else{ if (nvalx > tol) errsqr += nvaldx/nvalx ; else errsqr += nvaldx ; } } *MeanError = errsqr/(double)n ; } else{ if (dxmoy > 1.e-30) *MeanError = 1. ; else *MeanError = 0. ; } } getdp-2.4.2-source/Legacy/Pos_FemInterpolation.cpp000644 001750 001750 00000036362 12116424202 023614 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "ProData.h" #include "GeoData.h" #include "DofData.h" #include "Get_DofOfElement.h" #include "Get_ElementSource.h" #include "Get_Geometry.h" #include "Get_FunctionValue.h" #include "Cal_IntegralQuantity.h" #include "Pos_Search.h" #include "Message.h" extern struct Problem Problem_S ; extern struct CurrentData Current ; extern List_T *GeoData_L ; /* ------------------------------------------------------------------------ */ /* P o s _ F e m I n t e r p o l a t i o n */ /* ------------------------------------------------------------------------ */ void Pos_FemInterpolation(struct Element * Element, struct QuantityStorage * QuantityStorage_P0, struct QuantityStorage * QuantityStorage_P, int Type_Quantity, int Type_Operator, int Type_Dimension, int UseXYZ, double u, double v, double w, double x, double y, double z, double Val[], int * Type_Value, int Flag_ChangeOfCoordinates) { void (*xFunctionBF[NBR_MAX_BASISFUNCTIONS]) (struct Element *, int, double, double, double, double []) ; void (*xChangeOfCoordinates) () = 0; struct IntegralQuantityActive IQA ; struct Value vBFxDof[NBR_MAX_BASISFUNCTIONS] ; struct GeoData * GeoData_P ; struct Element TheElement, * TheElement_P ; struct QuantityStorage * QS_P ; double vBFu[NBR_MAX_BASISFUNCTIONS][MAX_DIM] ; double Val_Dof, Val_Dof_r, Val_Dof_i ; int Type_DefineQuantity, SubType_DefineQuantity, Type_Form ; int i, j, k, Nbr_Dof = 0 ; int GeoDataNum = 0, UseNewGeo = 0 ; /* ------------- Quantity Type ------------- */ Type_DefineQuantity = QuantityStorage_P->DefineQuantity->Type ; if(Type_DefineQuantity == INTEGRALQUANTITY){ if(QuantityStorage_P->DefineQuantity->IntegralQuantity.DefineQuantityIndexDof < 0){ SubType_DefineQuantity = NODOF ; } else{ SubType_DefineQuantity = INTEGRALQUANTITY ; } } else{ SubType_DefineQuantity = Type_DefineQuantity ; } /* --------------- Get The Element --------------- */ if(SubType_DefineQuantity != NODOF) { if(!QuantityStorage_P->FunctionSpace){ Message::Error("No available function space for quantity"); return; } if(!QuantityStorage_P->FunctionSpace->DofData){ Message::Error("No available data to interpolate quantity"); return; } GeoDataNum = QuantityStorage_P->FunctionSpace->DofData->GeoDataIndex; UseNewGeo = (GeoDataNum != Current.GeoData->Num) ; if(UseXYZ || UseNewGeo){ if(UseNewGeo){ GeoData_P = (struct GeoData *)List_Pointer(GeoData_L, GeoDataNum); GeoDataNum = Current.GeoData->Num ; Geo_SetCurrentGeoData(Current.GeoData = GeoData_P) ; } if(!UseXYZ){ x = y = z = 0. ; for (i = 0 ; i < Element->GeoElement->NbrNodes ; i++) { x += Element->x[i] * Element->n[i] ; y += Element->y[i] * Element->n[i] ; z += Element->z[i] * Element->n[i] ; } } Init_SearchGrid(&Current.GeoData->Grid); InWhichElement(Current.GeoData->Grid, NULL, &TheElement, (Type_Dimension >= 0) ? Type_Dimension : _ALL, x, y, z, &u, &v, &w) ; TheElement_P = &TheElement ; Get_InitDofOfElement(&TheElement) ; Get_DofOfElement (&TheElement, QuantityStorage_P->FunctionSpace, QuantityStorage_P, QuantityStorage_P->DefineQuantity->IndexInFunctionSpace) ; } else{ TheElement_P = Element; } } else{ TheElement_P = Element ; } /* ------------------ Init LocalQuantity ------------------ */ if (Type_DefineQuantity == LOCALQUANTITY) { if (TheElement_P->Num != NO_ELEMENT) { Nbr_Dof = QuantityStorage_P->NbrElementaryBasisFunction ; Get_FunctionValue(Nbr_Dof, (void (**)())xFunctionBF, Type_Operator, QuantityStorage_P, &Type_Form) ; xChangeOfCoordinates = (void (*)())Get_ChangeOfCoordinates ((Flag_ChangeOfCoordinates && TheElement_P->Num != NO_ELEMENT), Type_Form) ; } else { Message::Warning("No element found in mesh for LocalQuantity interpolation"); Nbr_Dof = 0 ; Type_Form = VECTOR ; } } /* --------------------- Init IntegralQuantity --------------------- */ else if (Type_DefineQuantity == INTEGRALQUANTITY) { if(Type_Operator != NOOP){ Message::Error("Operator acting on Integral Quantity"); } Type_Form = VECTOR ; Get_InitElementSource(TheElement_P, QuantityStorage_P->DefineQuantity->IntegralQuantity.InIndex) ; IQA.IntegrationCase_L = ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, QuantityStorage_P->DefineQuantity-> IntegralQuantity.IntegrationMethodIndex)) ->IntegrationCase ; IQA.CriterionIndex = ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, QuantityStorage_P->DefineQuantity-> IntegralQuantity.IntegrationMethodIndex)) ->CriterionIndex ; IQA.JacobianCase_L = ((struct JacobianMethod *) List_Pointer(Problem_S.JacobianMethod, QuantityStorage_P->DefineQuantity-> IntegralQuantity.JacobianMethodIndex)) ->JacobianCase ; xChangeOfCoordinates = (void (*)())Get_ChangeOfCoordinates(0, Type_Form) ; } /* ---------------------- Compute GlobalQuantity ---------------------- */ if (Type_DefineQuantity == GLOBALQUANTITY) { if(Current.NbrHar==1){ if (Type_Quantity == QUANTITY_BF) Val[0] = (QuantityStorage_P->BasisFunction[0].Dof->Entity == Current.SubRegion)? 1. : 0. ; else Dof_GetRealDofValue (QuantityStorage_P->FunctionSpace->DofData, QuantityStorage_P->BasisFunction[0].Dof, &Val[0]) ; } else{ for (k = 0 ; k < Current.NbrHar ; k+=2) { if (Type_Quantity == QUANTITY_BF) { Val[MAX_DIM*k] = (QuantityStorage_P->BasisFunction[0].Dof->Entity == Current.SubRegion)? 1. : 0. ; Val[MAX_DIM*(k+1)] = 0. ; } else { Dof_GetComplexDofValue (QuantityStorage_P->FunctionSpace->DofData, QuantityStorage_P->BasisFunction[0].Dof + k/2*gCOMPLEX_INCREMENT, &Val[MAX_DIM*k], &Val[MAX_DIM*(k+1)]) ; } } } *Type_Value = SCALAR ; return ; } /* ----------------------------------- Compute Local / Integral Quantities ----------------------------------- */ i = Current.NbrHar * MAX_DIM ; for (k = 0 ; k < i ; k++) Val[k] = 0. ; while (1) { if (Type_DefineQuantity == INTEGRALQUANTITY) { if (Get_NextElementSource(TheElement_P->ElementSource)) { Get_NodesCoordinatesOfElement(TheElement_P->ElementSource) ; if(SubType_DefineQuantity != NODOF){ Get_DofOfElement(TheElement_P->ElementSource, QuantityStorage_P->FunctionSpace, QuantityStorage_P, QuantityStorage_P->DefineQuantity->IndexInFunctionSpace) ; Nbr_Dof = QuantityStorage_P->NbrElementaryBasisFunction ; Get_FunctionValue(Nbr_Dof, (void (**)())xFunctionBF, QuantityStorage_P->DefineQuantity->IntegralQuantity.TypeOperatorDof, QuantityStorage_P, &IQA.Type_FormDof) ; Type_Form = IQA.Type_FormDof ; /* good form */ } else{ Nbr_Dof = 1 ; xFunctionBF[0] = NULL ; /* for analytic integration tests */ Type_Form = IQA.Type_FormDof = VECTOR ; /* form type unknown */ for (j = 0 ; j < QuantityStorage_P->DefineQuantity->IntegralQuantity.NbrQuantityIndex ; j++) { QS_P = QuantityStorage_P0 + QuantityStorage_P->DefineQuantity->IntegralQuantity.QuantityIndexTable[j] ; Get_DofOfElement(TheElement_P->ElementSource, QS_P->FunctionSpace, QS_P, QS_P->DefineQuantity->IndexInFunctionSpace) ; } } Cal_InitIntegralQuantity (TheElement_P, &IQA, QuantityStorage_P); } else break ; } /* ----- Local ----- */ if (Type_DefineQuantity == LOCALQUANTITY) { if (TheElement_P->Num != NO_ELEMENT) { for (j = 0 ; j < Nbr_Dof ; j++) { xFunctionBF[j] (TheElement_P, QuantityStorage_P->BasisFunction[j].NumEntityInElement+1, u, v, w, vBFu[j]) ; ((void (*)(struct Element*, double*, double*)) xChangeOfCoordinates) (TheElement_P, vBFu[j], vBFxDof[j].Val) ; } } /* interpolate (vBFxDof is real-valued) */ switch (Type_Form) { case FORM0 : case FORM3 : case FORM3P : case SCALAR : if(Current.NbrHar==1){ for (j = 0 ; j < Nbr_Dof ; j++){ if (Type_Quantity == QUANTITY_BF) Val_Dof = (QuantityStorage_P->BasisFunction[j].Dof->Entity == Current.SubRegion)? 1. : 0. ; else Dof_GetRealDofValue (QuantityStorage_P->FunctionSpace->DofData, QuantityStorage_P->BasisFunction[j].Dof, &Val_Dof) ; Val[0] += vBFxDof[j].Val[0] * Val_Dof ; } } else{ for (j = 0 ; j < Nbr_Dof ; j++){ for (k = 0 ; k < Current.NbrHar ; k+=2) { if (Type_Quantity == QUANTITY_BF) { Val_Dof_r = (QuantityStorage_P->BasisFunction[j].Dof->Entity == Current.SubRegion)? 1. : 0. ; Val_Dof_i = 0. ; } else { Dof_GetComplexDofValue (QuantityStorage_P->FunctionSpace->DofData, QuantityStorage_P->BasisFunction[j].Dof + k/2*gCOMPLEX_INCREMENT, &Val_Dof_r, &Val_Dof_i) ; } Val[MAX_DIM*k] += vBFxDof[j].Val[0] * Val_Dof_r ; Val[MAX_DIM*(k+1)] += vBFxDof[j].Val[0] * Val_Dof_i ; } } } *Type_Value = SCALAR ; break ; case FORM1 : case FORM1P : case FORM2 : case FORM2P : case FORM1S : case FORM2S : case VECTOR : case VECTORP : if(Current.NbrHar==1){ for (j = 0 ; j < Nbr_Dof ; j++){ if (Type_Quantity == QUANTITY_BF) Val_Dof = (QuantityStorage_P->BasisFunction[j].Dof->Entity == Current.SubRegion)? 1. : 0. ; else Dof_GetRealDofValue (QuantityStorage_P->FunctionSpace->DofData, QuantityStorage_P->BasisFunction[j].Dof, &Val_Dof) ; Val[0] += vBFxDof[j].Val[0] * Val_Dof ; Val[1] += vBFxDof[j].Val[1] * Val_Dof ; Val[2] += vBFxDof[j].Val[2] * Val_Dof ; } } else{ for (j = 0 ; j < Nbr_Dof ; j++){ for (k = 0 ; k < Current.NbrHar ; k+=2) { if (Type_Quantity == QUANTITY_BF) { Val_Dof_r = (QuantityStorage_P->BasisFunction[j].Dof->Entity == Current.SubRegion)? 1. : 0. ; Val_Dof_i = 0. ; } else { Dof_GetComplexDofValue (QuantityStorage_P->FunctionSpace->DofData, QuantityStorage_P->BasisFunction[j].Dof + k/2*gCOMPLEX_INCREMENT, &Val_Dof_r, &Val_Dof_i) ; } Val[MAX_DIM*k ] += vBFxDof[j].Val[0] * Val_Dof_r ; Val[MAX_DIM*k+1] += vBFxDof[j].Val[1] * Val_Dof_r ; Val[MAX_DIM*k+2] += vBFxDof[j].Val[2] * Val_Dof_r ; Val[MAX_DIM*(k+1) ] += vBFxDof[j].Val[0] * Val_Dof_i ; Val[MAX_DIM*(k+1)+1] += vBFxDof[j].Val[1] * Val_Dof_i ; Val[MAX_DIM*(k+1)+2] += vBFxDof[j].Val[2] * Val_Dof_i ; } } } *Type_Value = VECTOR ; break ; default : Message::Error("Unknown Form type in 'Pos_FemInterpolation'"); break; } } /* -------- Integral -------- */ /* FIXME: Ce qu'il faut faire, c'est ne pas reinterpoler ici, mais laisser au Cal_Quantity dans Cal_IntegralQuantity le soin de reinterpoler directment la quantity local intervenant ds la qte integrale s'il y a lieu (mais, comment faire avec l'integration analytique ?) */ else { if (IQA.IntegrationCase_P->Type == ANALYTIC) Cal_AnalyticIntegralQuantity (Current.Element = TheElement_P, QuantityStorage_P, Nbr_Dof, (void (**)())xFunctionBF, vBFxDof) ; else Cal_NumericalIntegralQuantity (Current.Element = TheElement_P, &IQA, QuantityStorage_P0, QuantityStorage_P, SubType_DefineQuantity, Nbr_Dof, (void (**)())xFunctionBF, vBFxDof) ; Type_Form = vBFxDof[0].Type ; /* interpolate (vBFxDof can be complex-valued) */ if(SubType_DefineQuantity == NODOF){ switch (Type_Form) { case FORM0 : case FORM3 : case FORM3P : case SCALAR : for (k = 0 ; k < Current.NbrHar ; k++) Val[MAX_DIM*k] += vBFxDof[0].Val[MAX_DIM*k] ; *Type_Value = SCALAR ; break ; case FORM1 : case FORM1P : case FORM2 : case FORM2P : case FORM1S : case FORM2S : case VECTOR : case VECTORP : for (k = 0 ; k < Current.NbrHar ; k++) { Val[MAX_DIM*k] += vBFxDof[0].Val[MAX_DIM*k] ; Val[MAX_DIM*k+1] += vBFxDof[0].Val[MAX_DIM*k+1] ; Val[MAX_DIM*k+2] += vBFxDof[0].Val[MAX_DIM*k+2] ; } *Type_Value = VECTOR ; break ; default : Message::Error("Unknown Form type in 'Pos_FemInterpolation'"); break; } } else{ switch (Type_Form) { case FORM0 : case FORM3 : case FORM3P : case SCALAR : if(Current.NbrHar==1){ for (j = 0 ; j < Nbr_Dof ; j++){ Dof_GetRealDofValue (QuantityStorage_P->FunctionSpace->DofData, QuantityStorage_P->BasisFunction[j].Dof, &Val_Dof) ; Val[0] += vBFxDof[j].Val[0] * Val_Dof ; } } else{ for (j = 0 ; j < Nbr_Dof ; j++){ for (k = 0 ; k < Current.NbrHar ; k+=2) { Dof_GetComplexDofValue (QuantityStorage_P->FunctionSpace->DofData, QuantityStorage_P->BasisFunction[j].Dof + k/2*gCOMPLEX_INCREMENT, &Val_Dof_r, &Val_Dof_i) ; Val[MAX_DIM*k] += vBFxDof[j].Val[MAX_DIM*k] * Val_Dof_r - vBFxDof[j].Val[MAX_DIM*(k+1)] * Val_Dof_i ; Val[MAX_DIM*(k+1)] += vBFxDof[j].Val[MAX_DIM*k] * Val_Dof_i + vBFxDof[j].Val[MAX_DIM*(k+1)] * Val_Dof_r ; } } } *Type_Value = SCALAR ; break ; case FORM1 : case FORM1P : case FORM2 : case FORM2P : case FORM1S : case FORM2S : case VECTOR : case VECTORP : if(Current.NbrHar==1){ for (j = 0 ; j < Nbr_Dof ; j++){ Dof_GetRealDofValue (QuantityStorage_P->FunctionSpace->DofData, QuantityStorage_P->BasisFunction[j].Dof, &Val_Dof) ; Val[0] += vBFxDof[j].Val[0] * Val_Dof ; Val[1] += vBFxDof[j].Val[1] * Val_Dof ; Val[2] += vBFxDof[j].Val[2] * Val_Dof ; } } else{ for (j = 0 ; j < Nbr_Dof ; j++){ for (k = 0 ; k < Current.NbrHar ; k+=2) { Dof_GetComplexDofValue (QuantityStorage_P->FunctionSpace->DofData, QuantityStorage_P->BasisFunction[j].Dof + k/2*gCOMPLEX_INCREMENT, &Val_Dof_r, &Val_Dof_i) ; Val[MAX_DIM*k] += vBFxDof[j].Val[MAX_DIM*k] * Val_Dof_r - vBFxDof[j].Val[MAX_DIM*(k+1)] * Val_Dof_i ; Val[MAX_DIM*(k+1)] += vBFxDof[j].Val[MAX_DIM*k] * Val_Dof_i + vBFxDof[j].Val[MAX_DIM*(k+1)] * Val_Dof_r ; Val[MAX_DIM*k+1] += vBFxDof[j].Val[MAX_DIM*k+1] * Val_Dof_r - vBFxDof[j].Val[MAX_DIM*(k+1)+1] * Val_Dof_i ; Val[MAX_DIM*(k+1)+1] += vBFxDof[j].Val[MAX_DIM*k+1] * Val_Dof_i + vBFxDof[j].Val[MAX_DIM*(k+1)+1] * Val_Dof_r ; Val[MAX_DIM*k+2] += vBFxDof[j].Val[MAX_DIM*k+2] * Val_Dof_r - vBFxDof[j].Val[MAX_DIM*(k+1)+2] * Val_Dof_i ; Val[MAX_DIM*(k+1)+2] += vBFxDof[j].Val[MAX_DIM*k+2] * Val_Dof_i + vBFxDof[j].Val[MAX_DIM*(k+1)+2] * Val_Dof_r ; } } } *Type_Value = VECTOR ; break ; default : Message::Error("Unknown Form type in 'Pos_FemInterpolation'"); break; } } } if (Type_DefineQuantity != INTEGRALQUANTITY) break ; } /* while (1) ... */ if(UseNewGeo){ GeoData_P = (struct GeoData *)List_Pointer(GeoData_L, GeoDataNum); Geo_SetCurrentGeoData(Current.GeoData = GeoData_P) ; } } getdp-2.4.2-source/Legacy/F.h000644 001750 001750 00000020413 12211017577 017345 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _F_H_ #define _F_H_ #include "ProData.h" /* ------------------------------------------------------------------------ */ /* Warning: the pointers A and V can be identical. You must */ /* use temporary variables in your computations: you can only */ /* affect to V at the very last time (when you're sure you will */ /* not use A anymore). */ /* ------------------------------------------------------------------------ */ #define F_ARG struct Function * Fct, struct Value * A, struct Value * V /* F_Analytic */ // using +iwt convention void F_JFIE_ZPolCyl (F_ARG) ; void F_RCS_ZPolCyl (F_ARG) ; void F_JFIE_TransZPolCyl (F_ARG) ; void F_JFIE_SphTheta (F_ARG) ; void F_RCS_SphTheta (F_ARG) ; void F_JFIE_SphPhi (F_ARG) ; void F_RCS_SphPhi (F_ARG) ; void F_CurrentPerfectlyConductingSphere(F_ARG); // using -iwt convention void F_ElectricFieldPerfectlyConductingSphereMwt(F_ARG); void F_ElectricFieldDielectricSphereMwt(F_ARG); void F_ExactOsrcSolutionPerfectlyConductingSphereMwt(F_ARG); void F_CurrentPerfectlyConductingSphereMwt(F_ARG); void F_AcousticFieldSoftSphere(F_ARG) ; void F_DrAcousticFieldSoftSphere(F_ARG) ; void F_RCSSoftSphere(F_ARG) ; void F_AcousticFieldHardSphere(F_ARG) ; void F_RCSHardSphere(F_ARG) ; void F_AcousticFieldSoftCylinder(F_ARG) ; void F_AcousticFieldSoftCylinderABC(F_ARG) ; void F_DrAcousticFieldSoftCylinder(F_ARG) ; void F_RCSSoftCylinder(F_ARG) ; void F_AcousticFieldHardCylinder(F_ARG) ; void F_AcousticFieldHardCylinderABC(F_ARG) ; void F_DthetaAcousticFieldHardCylinder(F_ARG) ; void F_RCSHardCylinder(F_ARG) ; void F_OSRC_C0(F_ARG); void F_OSRC_Aj(F_ARG); void F_OSRC_Bj(F_ARG); /* F_Geometry */ void F_ProjectPointOnEllipse(F_ARG); void F_Normal (F_ARG) ; void F_NormalSource (F_ARG) ; void F_Tangent (F_ARG) ; void F_TangentSource (F_ARG) ; void F_ElementVol (F_ARG) ; void F_SurfaceArea (F_ARG) ; void F_GetVolume (F_ARG) ; /* F_Raytracing */ void F_CylinderPhase(F_ARG); void F_DiamondPhase(F_ARG); /* F_Math */ void F_Exp (F_ARG) ; void F_Log (F_ARG) ; void F_Log10 (F_ARG) ; void F_Sqrt (F_ARG) ; void F_Sin (F_ARG) ; void F_Asin (F_ARG) ; void F_Cos (F_ARG) ; void F_Acos (F_ARG) ; void F_Tan (F_ARG) ; void F_Atan (F_ARG) ; void F_Sinh (F_ARG) ; void F_Cosh (F_ARG) ; void F_Tanh (F_ARG) ; void F_Fabs (F_ARG) ; void F_Floor (F_ARG) ; void F_Ceil (F_ARG) ; void F_Fmod (F_ARG) ; void F_Sign (F_ARG) ; void F_Jn (F_ARG) ; void F_Yn (F_ARG) ; void F_dJn (F_ARG) ; void F_dYn (F_ARG) ; /* F_ExtMath */ void F_Hypot (F_ARG) ; void F_Atan2 (F_ARG) ; void F_TanhC2 (F_ARG) ; void F_Transpose (F_ARG) ; void F_Inv (F_ARG) ; void F_Det (F_ARG) ; void F_Trace (F_ARG) ; void F_RotateXYZ (F_ARG) ; void F_Norm (F_ARG) ; void F_SquNorm (F_ARG) ; void F_Unit (F_ARG) ; void F_ScalarUnit (F_ARG) ; void F_Cos_wt_p (F_ARG) ; void F_Sin_wt_p (F_ARG) ; void F_Period (F_ARG) ; void F_Interval (F_ARG) ; void F_Complex (F_ARG) ; void F_Complex_MH (F_ARG) ; void F_Re (F_ARG) ; void F_Im (F_ARG) ; void F_Conj (F_ARG) ; void F_Cart2Pol (F_ARG) ; void F_Vector (F_ARG) ; void F_Tensor (F_ARG) ; void F_TensorV (F_ARG) ; void F_TensorSym (F_ARG) ; void F_TensorDiag (F_ARG) ; void F_SquDyadicProduct(F_ARG) ; void F_CompX (F_ARG) ; void F_CompY (F_ARG) ; void F_CompZ (F_ARG) ; void F_CompXX (F_ARG) ; void F_CompXY (F_ARG) ; void F_CompXZ (F_ARG) ; void F_CompYX (F_ARG) ; void F_CompYY (F_ARG) ; void F_CompYZ (F_ARG) ; void F_CompZX (F_ARG) ; void F_CompZY (F_ARG) ; void F_CompZZ (F_ARG) ; void F_Cart2Sph (F_ARG) ; void F_Cart2Cyl (F_ARG) ; void F_UnitVectorX (F_ARG) ; void F_UnitVectorY (F_ARG) ; void F_UnitVectorZ (F_ARG) ; /* F_Coord */ // se basent sur le uvw courant (-> en cal) void F_CoordX (F_ARG) ; void F_CoordY (F_ARG) ; void F_CoordZ (F_ARG) ; void F_CoordXYZ (F_ARG) ; // se basent sur le xyz courant, i.e. les coord d'un noeud (-> en pre) void F_aX_bY_cZ (F_ARG) ; void F_aX21_bY21_cZ21 (F_ARG) ; void F_CoordXS (F_ARG) ; void F_CoordYS (F_ARG) ; void F_CoordZS (F_ARG) ; void F_CoordXYZS (F_ARG) ; /* F_Misc */ void F_Printf (F_ARG) ; void F_Rand (F_ARG) ; void F_CompElementNum (F_ARG) ; void F_VirtualWork (F_ARG) ; void F_AssDiag (F_ARG) ; /* pour Patrick */ /* F_Interpolation */ void F_InterpolationLinear (F_ARG) ; void F_dInterpolationLinear (F_ARG) ; void F_dInterpolationLinear2 (F_ARG) ; void F_InterpolationAkima (F_ARG) ; void F_dInterpolationAkima (F_ARG) ; void F_InterpolationBilinear (F_ARG) ; void F_dInterpolationBilinear (F_ARG) ; bool Fi_InterpolationBilinear (double *x, double *y, double *M, int NL, int NC, double xp, double yp, double *zp); bool Fi_dInterpolationBilinear(double *x, double *y, double *M, int NL, int NC, double xp, double yp, double *dzp_dx, double *dzp_dy); void Fi_InitListX (F_ARG) ; // List void Fi_InitListXY (F_ARG) ; // ListAlt void Fi_InitListXY2 (F_ARG) ; void Fi_InitAkima (F_ARG) ; void Fi_InitListMatrix (F_ARG) ; void F_ValueFromIndex (F_ARG) ; void F_VectorFromIndex (F_ARG) ; void Fi_InitValueFromIndex (F_ARG) ; void Fi_InitVectorFromIndex (F_ARG) ; void F_TransformTensor (F_ARG) ; /* pour Tuan */ void F_TransformPerm (F_ARG) ; /* pour Tuan */ void F_TransformPiezo (F_ARG) ; /* pour Tuan */ void F_TransformPiezoT (F_ARG) ; /* pour Tuan */ /* F_Hysteresis */ void F_dhdb_Jiles (F_ARG) ; void F_dbdh_Jiles (F_ARG) ; void F_h_Jiles (F_ARG) ; void F_b_Jiles (F_ARG) ; void F_dhdb_Ducharne(F_ARG) ; void F_h_Ducharne (F_ARG) ; void F_nu_Ducharne(F_ARG) ; double Fi_h_Ducharne (double *hi, double *bi, double *M, int NL, int NC, double h0, double b0, double b); void F_nu_Vinch (F_ARG) ; void F_mu_Vinch (F_ARG) ; void F_h_Vinch (F_ARG) ; void F_dhdb_Vinch(F_ARG) ; void F_dbdh_Vinch(F_ARG) ; void F_Update_Jk (F_ARG) ; void F_Update_Jk_sd (F_ARG) ; /* F_MultiHar */ void F_MHToTime (F_ARG) ; // the following should go somewhere else void Fi_MHTimeIntegration(int TypePsi, int NbrTimePoint, List_T * WholeQuantity_L, int FreqOffSet, struct Element * Element, struct QuantityStorage * QuantityStorage_P0, double u, double v, double w, struct Value *ValueOut) ; void F_MHToTime0 (int init, struct Value * A, struct Value * V, int iTime, int NbrTimePoint, double * TimeMH) ;/* OJO!!! int *init */ void MHTransform(struct Element * Element, struct QuantityStorage * QuantityStorage_P0, double u, double v, double w, struct Value *MH_Value, struct Expression * Expression_P, int NbrPoints); /* F_BiotSavart */ void F_BiotSavart (F_ARG) ; void F_Pocklington (F_ARG) ; /* F_Gmsh */ void F_Field(F_ARG) ; void F_ScalarField(F_ARG) ; void F_VectorField(F_ARG) ; void F_TensorField(F_ARG) ; void F_ComplexScalarField(F_ARG) ; void F_ComplexVectorField(F_ARG) ; void F_ComplexTensorField(F_ARG) ; /* F_DiffGeom */ void F_Hodge(F_ARG) ; void F_InnerProduct(F_ARG) ; void F_Sharp(F_ARG) ; void F_Flat(F_ARG) ; void F_WedgeProduct(F_ARG) ; void F_TensorProduct(F_ARG) ; void F_InteriorProduct(F_ARG) ; void F_PullBack(F_ARG) ; void F_PullBackMetric(F_ARG) ; void F_PushForward(F_ARG) ; void F_InvPullBack(F_ARG) ; void F_InvPushForward(F_ARG) ; #endif getdp-2.4.2-source/Legacy/Pos_Formulation.cpp000644 001750 001750 00000043500 12221300353 022621 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include "ProData.h" #include "DofData.h" #include "GeoData.h" #include "Get_DofOfElement.h" #include "Pos_Print.h" #include "Pos_Format.h" #include "ListUtils.h" #include "Message.h" #include "OS.h" #if defined(HAVE_GMSH) #include #include #include #include #include #endif #include "MallocUtils.h" #include "SolvingAnalyse.h" #if defined(HAVE_GSL) #include #include #endif #define TWO_PI 6.2831853071795865 extern struct Problem Problem_S ; extern struct CurrentData Current ; extern int Flag_BIN, Flag_GMSH_VERSION ; extern char *Name_Path ; FILE *PostStream = stdout; /* ------------------------------------------------------------------------ */ /* P o s _ F e m F o r m u l a t i o n */ /* ------------------------------------------------------------------------ */ void Pos_FemFormulation(struct Formulation *Formulation_P, struct PostQuantity *NCPQ_P, struct PostQuantity *CPQ_P, int Order, struct PostSubOperation *PostSubOperation_P) { struct Element Element ; struct DefineQuantity *DefineQuantity_P0 ; struct QuantityStorage *QuantityStorage_P0, QuantityStorage ; List_T *QuantityStorage_L ; int i ; Get_InitDofOfElement(&Element) ; DefineQuantity_P0 = (struct DefineQuantity*) List_Pointer(Formulation_P->DefineQuantity, 0) ; QuantityStorage_L = List_Create(List_Nbr(Formulation_P->DefineQuantity), 1, sizeof (struct QuantityStorage) ) ; for(i = 0 ; i < List_Nbr(Formulation_P->DefineQuantity) ; i++) { QuantityStorage.DefineQuantity = DefineQuantity_P0 + i ; if(QuantityStorage.DefineQuantity->Type == INTEGRALQUANTITY && QuantityStorage.DefineQuantity->IntegralQuantity.DefineQuantityIndexDof < 0){ QuantityStorage.TypeQuantity = VECTOR ; /* on ne sait pas... */ } else{ QuantityStorage.TypeQuantity = ((struct FunctionSpace *) List_Pointer(Problem_S.FunctionSpace, (DefineQuantity_P0+i)->FunctionSpaceIndex))->Type ; } QuantityStorage.NumLastElementForFunctionSpace = 0 ; List_Add(QuantityStorage_L, &QuantityStorage) ; } QuantityStorage_P0 = (struct QuantityStorage*)List_Pointer(QuantityStorage_L, 0) ; switch (PostSubOperation_P->Type) { case POP_PRINT : switch (PostSubOperation_P->SubType) { case PRINT_ONREGION : Pos_PrintOnRegion(NCPQ_P, CPQ_P, Order, DefineQuantity_P0, QuantityStorage_P0, PostSubOperation_P) ; break ; case PRINT_ONELEMENTSOF : case PRINT_ONGRID : Pos_PrintOnElementsOf(NCPQ_P, CPQ_P, Order, DefineQuantity_P0, QuantityStorage_P0, PostSubOperation_P) ; break ; case PRINT_ONSECTION_1D : case PRINT_ONSECTION_2D : Pos_PrintOnSection(NCPQ_P, CPQ_P, Order, DefineQuantity_P0, QuantityStorage_P0, PostSubOperation_P) ; break ; case PRINT_ONGRID_0D : case PRINT_ONGRID_1D : case PRINT_ONGRID_2D : case PRINT_ONGRID_3D : case PRINT_ONGRID_PARAM : Pos_PrintOnGrid(NCPQ_P, CPQ_P, Order, DefineQuantity_P0, QuantityStorage_P0, PostSubOperation_P) ; break ; case PRINT_WITHARGUMENT : Pos_PrintWithArgument(NCPQ_P, CPQ_P, Order, DefineQuantity_P0, QuantityStorage_P0, PostSubOperation_P) ; break ; default : Message::Error("Unknown Operation type for Print"); break; } break ; case POP_EXPRESSION : Pos_PrintExpression(PostSubOperation_P); break; case POP_GROUP : Pos_PrintGroup(PostSubOperation_P); break; default : Message::Error("Unknown PostSubOperation type") ; break; } List_Delete(QuantityStorage_L); } /* ------------------------------------------------------------------------ */ /* P o s _ I n i t T i m e S t e p s */ /* ------------------------------------------------------------------------ */ int Pos_InitTimeSteps(struct PostSubOperation *PostSubOperation_P) { int iTime, NbTimeStep; if(PostSubOperation_P->LastTimeStepOnly || PostSubOperation_P->AppendTimeStepToFileName){ iTime = List_Nbr(Current.DofData->Solutions) - 1; List_Reset(PostSubOperation_P->TimeStep_L); List_Add(PostSubOperation_P->TimeStep_L, &iTime); return 1; } NbTimeStep = List_Nbr(PostSubOperation_P->TimeStep_L); if(!NbTimeStep || !PostSubOperation_P->FrozenTimeStepList){ NbTimeStep = List_Nbr(Current.DofData->Solutions); List_Reset(PostSubOperation_P->TimeStep_L); for(iTime = 0 ; iTime < NbTimeStep ; iTime++) List_Add(PostSubOperation_P->TimeStep_L, &iTime); } return NbTimeStep; } /* ------------------------------------------------------------------------ */ /* P o s _ I n i t A l l S o l u t i o n s */ /* ------------------------------------------------------------------------ */ void Pos_InitAllSolutions(List_T * TimeStep_L, int Index_TimeStep) { int TimeStepIndex, k, Num_Solution ; List_Read(TimeStep_L, Index_TimeStep, &TimeStepIndex) ; for(k = 0 ; k < Current.NbrSystem ; k++) if( (Num_Solution = std::min(List_Nbr((Current.DofData_P0+k)->Solutions)-1, TimeStepIndex)) >=0 ) (Current.DofData_P0+k)->CurrentSolution = (struct Solution*) List_Pointer((Current.DofData_P0+k)->Solutions, Num_Solution) ; Current.Time = Current.DofData->CurrentSolution->Time ; Current.TimeImag = Current.DofData->CurrentSolution->TimeImag ; if(List_Nbr(Current.DofData->Solutions) > TimeStepIndex) Current.TimeStep = ((struct Solution*)List_Pointer (Current.DofData->Solutions, TimeStepIndex))->TimeStep ; else // Warning: this can be wrong Current.TimeStep = TimeStepIndex; } /* ------------------------------------------------------------------------ */ /* P o s _ R e s a m p l e T i m e */ /* ------------------------------------------------------------------------ */ #if !defined(HAVE_GSL) void Pos_ResampleTime(struct PostOperation *PostOperation_P) { Message::Error("ResampleTime requires the GSL"); } #else void Pos_ResampleTime(struct PostOperation *PostOperation_P) { double ResampleTimeStart, ResampleTimeStop, ResampleTimeStep; double OriginalStopTime, *OriginalTime_P, *OriginalValueR_P, *OriginalValueI_P; double InterpValueRe, InterpValueIm; int OriginalNbrOfSolutions, NewNbrOfSolutions, xLength; Solution *Solution_P, Solution_S; List_T *NewSolutions_L; ResampleTimeStart = PostOperation_P->ResampleTimeStart; ResampleTimeStop = PostOperation_P->ResampleTimeStop; ResampleTimeStep = PostOperation_P->ResampleTimeStep; OriginalNbrOfSolutions = List_Nbr(Current.DofData->Solutions); OriginalTime_P = (double *)Malloc(OriginalNbrOfSolutions * sizeof(double)); OriginalValueR_P = (double *)Malloc(OriginalNbrOfSolutions * sizeof(double)); if (gSCALAR_SIZE == 2) OriginalValueI_P = (double *)Malloc(OriginalNbrOfSolutions * sizeof(double)); else OriginalValueI_P = NULL; Solution_P = (struct Solution*)List_Pointer(Current.DofData->Solutions, OriginalNbrOfSolutions-1); OriginalStopTime = Solution_P->Time; ResampleTimeStop = (OriginalStopTime < ResampleTimeStop) ? OriginalStopTime : ResampleTimeStop; for (int i=0; iSolutions, i); if (!Solution_P->SolutionExist) Message::Error("Empty solution(s) found"); OriginalTime_P[i] = Solution_P->Time; } LinAlg_GetVectorSize(&Solution_P->x, &xLength); NewNbrOfSolutions = floor((ResampleTimeStop-ResampleTimeStart) / ResampleTimeStep) + 1; if (NewNbrOfSolutions < 1) Message::Error("Invalid ResampleTime settings - t_start: %.6g t_stop: %.6g " "t_sample: %.6g", ResampleTimeStart, ResampleTimeStop, ResampleTimeStep); NewSolutions_L = List_Create(NewNbrOfSolutions, 1, sizeof(Solution)); for (int i=0; iSolver, xLength); List_Add(NewSolutions_L, &Solution_S); } for (int i=0; iSolutions, j); LinAlg_GetDoubleInVector(&OriginalValueR_P[j], &Solution_P->x, i); } gsl_interp_accel *acc = gsl_interp_accel_alloc (); gsl_spline *spline = gsl_spline_alloc (gsl_interp_cspline, OriginalNbrOfSolutions); gsl_spline_init (spline, OriginalTime_P, OriginalValueR_P, OriginalNbrOfSolutions); for (int j=0; jTime, acc); LinAlg_SetDoubleInVector(InterpValueRe, &Solution_P->x, i); } gsl_spline_free (spline); gsl_interp_accel_free (acc); } if (gSCALAR_SIZE == 2) { for (int j=0; jSolutions, j); LinAlg_GetComplexInVector(&OriginalValueR_P[j], &OriginalValueI_P[j], &Solution_P->x, i, -1); } gsl_interp_accel *accRe = gsl_interp_accel_alloc (); gsl_interp_accel *accIm = gsl_interp_accel_alloc (); gsl_spline *splineRe = gsl_spline_alloc (gsl_interp_cspline, OriginalNbrOfSolutions); gsl_spline *splineIm = gsl_spline_alloc (gsl_interp_cspline, OriginalNbrOfSolutions); gsl_spline_init (splineRe, OriginalTime_P, OriginalValueR_P, OriginalNbrOfSolutions); gsl_spline_init (splineIm, OriginalTime_P, OriginalValueI_P, OriginalNbrOfSolutions); for (int j=0; jTime, accRe); InterpValueIm = gsl_spline_eval (splineIm, Solution_P->Time, accIm); LinAlg_SetComplexInVector(InterpValueRe, InterpValueIm, &Solution_P->x, i, -1); } gsl_spline_free (splineRe); gsl_spline_free (splineIm); gsl_interp_accel_free (accRe); gsl_interp_accel_free (accIm); } } Current.DofData->Solutions = NewSolutions_L; Current.DofData->CurrentSolution = (struct Solution*) List_Pointer(NewSolutions_L, List_Nbr(NewSolutions_L)-1) ; for (int j=0; jSolutions, j); Solution_P->TimeFunctionValues = Get_TimeFunctionValues(Current.DofData) ; } Free(OriginalTime_P); Free(OriginalValueR_P); Free(OriginalValueI_P); } #endif /* ------------------------------------------------------------------------ */ /* P o s _ F o r m u l a t i o n */ /* ------------------------------------------------------------------------ */ void Pos_Formulation(struct Formulation *Formulation_P, struct PostProcessing *PostProcessing_P, struct PostSubOperation *PostSubOperation_P) { // currently cannot postprocess in parallel! if(Message::GetIsCommWorld() && Message::GetCommRank()) return; struct PostQuantity *NCPQ_P = NULL, *CPQ_P = NULL ; double Pulsation ; int i, Order = 0 ; char FileName[256], AddExt[100] ; if(PostSubOperation_P->FileOut){ if(PostSubOperation_P->FileOut[0] == '/' || PostSubOperation_P->FileOut[0] == '\\'){ strcpy(FileName, PostSubOperation_P->FileOut); } else{ strcpy(FileName, Name_Path); strcat(FileName, PostSubOperation_P->FileOut); } if(PostSubOperation_P->AppendTimeStepToFileName) { /* We should implement something more general, like strings with tags (e.g., "file_%TimeStep.pos") */ sprintf(AddExt, "_%03d", (PostSubOperation_P->OverrideTimeStepValue >= 0) ? PostSubOperation_P->OverrideTimeStepValue : (int)Current.TimeStep) ; strcat(FileName, AddExt); } if(!PostSubOperation_P->CatFile) { if((PostStream = FOpen(FileName, Flag_BIN ? "wb" : "w"))) Message::Direct(4, " > '%s'", FileName) ; else{ Message::Error("Unable to open file '%s'", FileName) ; PostStream = stdout ; } } else { if((PostStream = FOpen(FileName, Flag_BIN ? "ab" : "a"))) Message::Direct(4, " >> '%s'", FileName) ; else{ Message::Error("Unable to open file '%s'", FileName) ; PostStream = stdout ; } } } else{ PostStream = stdout ; } // force Gmsh version 1 for anything else than OnElementsOf, or if we store in // memory (which requires old-style list ordering) int oldVersion = Flag_GMSH_VERSION; if(PostSubOperation_P->SubType != PRINT_ONELEMENTSOF || PostSubOperation_P->Depth != 1 || PostSubOperation_P->StoreInField >= 0) Flag_GMSH_VERSION = 1; if(PostSubOperation_P->StoreInField >= 0 && PostSubOperation_P->Format != FORMAT_GMSH) Message::Warning("StoreInField only available with Gmsh output format"); if(PostSubOperation_P->CatFile == 2) fprintf(PostStream, "\n\n") ; /* two blanks lines for -index in gnuplot */ Format_PostFormat(PostSubOperation_P) ; if(PostSubOperation_P->PostQuantityIndex[0] >= 0) { if(PostSubOperation_P->PostQuantitySupport[0] < 0) { /* Noncumulative */ NCPQ_P = (struct PostQuantity *) List_Pointer(PostProcessing_P->PostQuantity, PostSubOperation_P->PostQuantityIndex[0]) ; CPQ_P = (PostSubOperation_P->PostQuantityIndex[1] >= 0) ? (struct PostQuantity *)List_Pointer(PostProcessing_P->PostQuantity, PostSubOperation_P->PostQuantityIndex[1]) : NULL ; Order = 1 ; } else { CPQ_P = (struct PostQuantity *) List_Pointer(PostProcessing_P->PostQuantity, PostSubOperation_P->PostQuantityIndex[0]) ; NCPQ_P = (PostSubOperation_P->PostQuantityIndex[1] >= 0) ? (struct PostQuantity *)List_Pointer(PostProcessing_P->PostQuantity, PostSubOperation_P->PostQuantityIndex[1]) : NULL ; Order = 0 ; } } if(List_Nbr(PostSubOperation_P->Frequency_L)){ if(List_Nbr(PostSubOperation_P->Frequency_L) > List_Nbr(Current.DofData->Pulsation)) Message::Error("Too many frequencies specified in PostOperation"); else{ for(i = 0 ; i < List_Nbr(PostSubOperation_P->Frequency_L) ; i++){ Pulsation = *((double *)List_Pointer(PostSubOperation_P->Frequency_L, i)) * TWO_PI ; List_Write(Current.DofData->Pulsation, i, &Pulsation) ; } } } switch (Formulation_P->Type) { case FEMEQUATION : Pos_FemFormulation(Formulation_P, NCPQ_P, CPQ_P, Order, PostSubOperation_P) ; break ; case GLOBALEQUATION : break ; default : Message::Error("Unknown Type for Formulation (%s)", Formulation_P->Name) ; break; } Flag_GMSH_VERSION = oldVersion; if(PostSubOperation_P->FileOut){ fclose(PostStream) ; if(PostSubOperation_P->SendToServer == NULL || strcmp(PostSubOperation_P->SendToServer, "No")){ if(PostSubOperation_P->Format == FORMAT_GMSH_PARSED || PostSubOperation_P->Format == FORMAT_GMSH){ // send merge request Message::SendMergeFileRequest(FileName); } // Add link to file Message::AddOnelabStringChoice(Message::GetOnelabClientName() + "/9Output files", "file", FileName); } /* NewCoordinates print option: write a new mesh */ if(PostSubOperation_P->NewCoordinates){ #if defined(HAVE_GMSH) GmshMergeFile(std::string(FileName)); int iview = PView::list.size() - 1; PViewData *data = PView::list[iview]->getData(); GModel* m = new GModel(); m->readMSH(std::string(Current.GeoData->Name)); std::vector entities; m->getEntities(entities); std::map, MVertexLessThanNum> newcoords; for(unsigned int i = 0; i < entities.size(); i++) { for(unsigned int j = 0; j < entities[i]->mesh_vertices.size(); j++) { MVertex* v = entities[i]->mesh_vertices[j]; std::vector xyz(3); if(!data->searchVector(v->x(), v->y(), v->z(), &xyz[0])) Message::Error("Did not find new coordinate Vector at point (%g,%g,%g) " "from file %s", v->x(), v->y(), v->z(), FileName); newcoords[v] = xyz; } } for(std::map, MVertexLessThanNum>::iterator it = newcoords.begin(); it != newcoords.end(); it++) { it->first->x() = it->second[0]; it->first->y() = it->second[1]; it->first->z() = it->second[2]; } char NewCoordsFileName[256]; if(PostSubOperation_P->NewCoordinatesFile[0] == '/' || PostSubOperation_P->NewCoordinatesFile[0] == '\\'){ strcpy(NewCoordsFileName, PostSubOperation_P->NewCoordinatesFile); } else{ strcpy(NewCoordsFileName, Name_Path); strcat(NewCoordsFileName, PostSubOperation_P->NewCoordinatesFile); } m->writeMSH(NewCoordsFileName); Message::Info("Wrote new coordinates in file %s", NewCoordsFileName); delete m; delete PView::list[iview]; PView::list.pop_back(); #else Message::Error("You need to compile GetDP with Gmsh support to use 'NewCoordinates'"); #endif } } } getdp-2.4.2-source/Legacy/Pos_Print.h000644 001750 001750 00000001601 12116424202 021062 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _POS_PRINT_H_ #define _POS_PRINT_H_ #include "ProData.h" #define ARG struct PostQuantity *NCPQ_P, \ struct PostQuantity *CPQ_P, \ int Order, \ struct DefineQuantity *DefineQuantity_P0, \ struct QuantityStorage *QuantityStorage_P0, \ struct PostSubOperation *PostSubOperation_P void Pos_PrintOnRegion (ARG); void Pos_PrintOnElementsOf (ARG); void Pos_PrintOnSection (ARG); void Pos_PrintOnGrid (ARG); void Pos_PrintWithArgument (ARG); #undef ARG void Pos_PrintGroup(struct PostSubOperation *PostSubOperation_P); void Pos_PrintExpression(struct PostSubOperation *PostSubOperation_P); #endif getdp-2.4.2-source/Legacy/GF.h000644 001750 001750 00000002763 12116424202 017453 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _GF_H_ #define _GF_H_ #include "ProData.h" /* ------------------------------------------------------------------------ */ /* G r e e n F u n c t i o n s */ /* ------------------------------------------------------------------------ */ #define GF_ARG struct Function * Fct, struct Value * A, struct Value * V void GF_Laplace (GF_ARG) ; void GF_GradLaplace (GF_ARG) ; void GF_NPxGradLaplace (GF_ARG) ; void GF_NSxGradLaplace (GF_ARG) ; void GF_ApproximateLaplace (GF_ARG) ; void GF_Helmholtz (GF_ARG) ; void GF_GradHelmholtz (GF_ARG) ; void GF_NSxGradHelmholtz (GF_ARG) ; void GF_NPxGradHelmholtz (GF_ARG) ; void GF_HelmholtzThinWire (GF_ARG) ; #define GF_ARGX \ struct Element * Element, struct Function * Fct, \ void (*xFunctionBF) (), int EntityNum, \ double x, double y, double z, struct Value * Val void GF_LaplacexForm (GF_ARGX) ; void GF_GradLaplacexForm (GF_ARGX) ; void GF_NPxGradLaplacexForm (GF_ARGX) ; void GF_NSxGradLaplacexForm (GF_ARGX) ; void GF_ApproximateLaplacexForm (GF_ARGX) ; void GF_HelmholtzxForm (GF_ARGX) ; #endif getdp-2.4.2-source/Legacy/EigenSolve.h000644 001750 001750 00000001167 12116424202 021214 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _EIGEN_SOLVE_H_ #define _EIGEN_SOLVE_H_ #include "DofData.h" void EigenSolve(struct DofData * DofData_P, int NumEigenvalues, double shift_r, double shift_i); void EigenSolve_ARPACK(struct DofData * DofData_P, int NumEigenvalues, double shift_r, double shift_i); void EigenSolve_SLEPC(struct DofData * DofData_P, int NumEigenvalues, double shift_r, double shift_i); #endif getdp-2.4.2-source/Legacy/BF_Edge_2.cpp000644 001750 001750 00000007375 12116424202 021152 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "ProData.h" #include "Message.h" /* ------------------------------------------------------------------------ */ /* B F _ E d g e _ 2 */ /* ------------------------------------------------------------------------ */ /* ------- */ /* Edges */ /* ------- */ #define WrongNumEntity Message::Error("Wrong Edge number in 'BF_Edge_2E'") void BF_Edge_2E(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { switch (Element->Type) { case LINE : switch(NumEntity) { case 1 : s[0] = u ; s[1] = 0. ; s[2] = 0. ; break ; default : WrongNumEntity ; } break ; case TRIANGLE : switch(NumEntity) { case 1 : s[0] = -2.0*u+1.0-v ; s[1] = -u ; s[2] = 0. ; break ; case 2 : s[0] = -v ; s[1] = -2.0*v+1.0-u ; s[2] = 0. ; break ; case 3 : s[0] = v ; s[1] = u ; s[2] = 0. ; break ; default : WrongNumEntity ; } break ; case QUADRANGLE : switch(NumEntity) { default : Message::Error("BF_Edge_2E not ready for QUADRANGLE"); } break ; case TETRAHEDRON : switch(NumEntity) { case 1 : s[0] = -2.0*u+1.0-v-w ; s[1] = -u ; s[2] = -u ; break ; case 2 : s[0] = -v ; s[1] = -2.0*v+1.0-u-w ; s[2] = -v ; break ; case 3 : s[0] = -w ; s[1] = -w ; s[2] = -2.0*w+1.0-u-v ; break ; case 4 : s[0] = v ; s[1] = u ; s[2] = 0. ; break ; case 5 : s[0] = w ; s[1] = 0. ; s[2] = u ; break ; case 6 : s[0] = 0. ; s[1] = w ; s[2] = v ; break ; default : WrongNumEntity ; } break ; case HEXAHEDRON : switch(NumEntity) { default : Message::Error("BF_Edge_2E not ready for HEXAHEDRON"); } break ; case PRISM : switch(NumEntity) { default : Message::Error("BF_Edge_2E not ready for PRISM"); } break ; case PYRAMID : switch(NumEntity) { default : Message::Error("BF_Edge_2E not ready for PYRAMID"); } break ; default : Message::Error("Unkown type of Element in BF_Edge_2E"); break ; } } #undef WrongNumEntity /* ------- */ /* Faces */ /* ------- */ #define WrongNumEntity Message::Error("Wrong Face number in 'BF_Edge_2F'") void BF_Edge_2F(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { Message::Error("You should never end up here!") ; } #undef WrongNumEntity /* -------- */ /* Volume */ /* -------- */ void BF_Edge_2V(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { Message::Error("You should never end up here!") ; } /* ------------------------------------------------------------------------ */ /* B F _ C u r l E d g e _ 2 */ /* ------------------------------------------------------------------------ */ /* ------- */ /* Edges */ /* ------- */ void BF_CurlEdge_2E(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { s[0] = 0. ; s[1] = 0. ; s[2] = 0. ; } /* ------- */ /* Faces */ /* ------- */ void BF_CurlEdge_2F(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { s[0] = 0. ; s[1] = 0. ; s[2] = 0. ; } /* -------- */ /* Volume */ /* -------- */ void BF_CurlEdge_2V(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { s[0] = 0. ; s[1] = 0. ; s[2] = 0. ; } getdp-2.4.2-source/Legacy/Operation_TimeLoopAdaptive.cpp000644 001750 001750 00000111602 12166744450 024750 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Michael Asam #include #include #include #include #include "GetDPConfig.h" #if defined(HAVE_GSL) #include #endif #include "ProData.h" #include "DofData.h" #include "SolvingOperations.h" #include "SolvingAnalyse.h" #include "Message.h" #include "MallocUtils.h" #include "Legendre.h" extern struct CurrentData Current; extern int Flag_IterativeLoopConverged; extern int Flag_RESTART; /* ------------------------------------------------------------------------ */ /* C a l c I n t e g r a t i o n C o e f f i c i e n t s */ /* ------------------------------------------------------------------------ */ #if !defined(HAVE_GSL) void CalcIntegrationCoefficients(Resolution *Resolution_P, DofData *DofData_P0, List_T *TLAsystems_L, List_T *TLAPostOp_L, int Order) { Message::Error("TimeLoopAdaptive requires the GSL"); } #else void CalcIntegrationCoefficients(Resolution *Resolution_P, DofData *DofData_P0, List_T *TLAsystems_L, List_T *TLAPostOp_L, int Order) { DefineSystem *System_P=NULL; DofData *DofData_P=NULL; Solution *Solution_P; TimeLoopAdaptiveSystem TLAsystem; List_T *Solutions_L=NULL; PostOpSolutions *PostOpSolutions_P0; int j, s, NbrOfSolutions=0; double t[8], temp; double A_data[49], b_data[7]; bool RecomputeTimeStep; gsl_matrix_view A; gsl_vector_view b; gsl_vector *coeff; gsl_permutation *p; // Initialization for (int i=0; i<7; i++) Current.aPredCoeff[i] = 0.0; for (int i=0; i<6; i++) Current.aCorrCoeff[i] = 0.0; Current.bCorrCoeff = 0.0; Current.PredErrorConst = 0.0; Current.CorrErrorConst = 0.0; if (Order < 1 || Order > 6) Message::Error("Order has to be in the range 1 .. 6"); // First get the past time points // ------------------------------ if (List_Nbr(TLAsystems_L)==0 && List_Nbr(TLAPostOp_L)==0) { Message::Error("Neither systems nor PostOperations are specified " "for TimeLoopAdaptive"); } if (List_Nbr(TLAsystems_L)) { List_Read(TLAsystems_L, 0, &TLAsystem); System_P = (DefineSystem*)List_Pointer(Resolution_P->DefineSystem, TLAsystem.SystemIndex); DofData_P = DofData_P0 + TLAsystem.SystemIndex; Solutions_L = DofData_P->Solutions; NbrOfSolutions = List_Nbr(Solutions_L); if (!NbrOfSolutions) Message::Error("No initial solution for system %s", System_P->Name); if (NbrOfSolutions <= Order && Order > 1) Message::Error("Too few past solutions for system %s", System_P->Name); } if (List_Nbr(TLAPostOp_L)) { PostOpSolutions_P0 = (PostOpSolutions *)List_Pointer(Current.PostOpData_L, 0); Solutions_L = PostOpSolutions_P0->Solutions_L; NbrOfSolutions = List_Nbr(Solutions_L); if (!NbrOfSolutions) Message::Error("No initial PostOperations"); if (NbrOfSolutions <= Order && Order > 1) Message::Error("Too few past PostOperations results"); } // Set the predictor's and corrector's order // ----------------------------------------- Solution_P = (struct Solution*)List_Pointer(Solutions_L, NbrOfSolutions-1); // Check if we recompute actual TimeStep RecomputeTimeStep = (Solution_P->TimeStep == (int)Current.TimeStep); if (NbrOfSolutions < (2 + (RecomputeTimeStep ? 1 : 0))){ Current.PredOrder = 0; // For 1st TimeStep just copy the initial solution Current.CorrOrder = 1; } else{ Current.PredOrder = Order; Current.CorrOrder = Order; } // Time values // t_n+1 -> t[0] // t_n -> t[1] // t_n-1 -> t[2] // ... // t_n-k -> t[k+1] k=Order t[0] = Current.Time; for(int i=1; i <= Current.PredOrder+1; i++) { j = RecomputeTimeStep ? i+1 : i; Solution_P = (struct Solution*)List_Pointer(Solutions_L, NbrOfSolutions-j); t[i] = Solution_P->Time; } // Calculation of predictor integration constants // ---------------------------------------------- /* The new solution is predicted by extrapolating the past solutions * by a polynom of order "PredOrder". The polynom coefficients * are calculated by solving a matrix equation A*coeff=b for the * exactness constraints. * E.g. for PredOder=3 we have: * * _ _ _ _ _ _ * | 1 1 1 1 | | a_0 | | 1 | * | (t_n)^1 (t_n-1)^1 (t_n-2)^1 (t_n-3)^1 | | a_1 | | (t_n+1)^1 | * | (t_n)^2 (t_n-1)^2 (t_n-2)^2 (t_n-3)^2 | * | a_2 | = | (t_n+1)^2 | * | (t_n)^3 (t_n-1)^3 (t_n-2)^3 (t_n-3)^3 | | a_3 | | (t_n+1)^3 | * |_ _| |_ _| |_ _| * */ if (Current.PredOrder == 0) Current.aPredCoeff[0] = 1.0; else { for (int c=0; c <= Current.PredOrder; c++) { A_data[c] = 1.0; for (int r=1; r <= Current.PredOrder; r++) A_data[c + r*((int)Current.PredOrder+1)] = pow(t[c+1],r); } A = gsl_matrix_view_array(A_data, Current.PredOrder+1, Current.PredOrder+1); b_data[0] = 1.0; for (int r=1; r <= Current.PredOrder; r++) b_data[r] = pow(t[0],r); b = gsl_vector_view_array(b_data, Current.PredOrder+1); coeff = gsl_vector_alloc(Current.PredOrder+1); p = gsl_permutation_alloc(Current.PredOrder+1); gsl_linalg_LU_decomp(&A.matrix, p, &s); gsl_linalg_LU_solve(&A.matrix, p, &b.vector, coeff); for (int i=0; i<=Current.PredOrder; i++) Current.aPredCoeff[i] = gsl_vector_get(coeff, i); gsl_permutation_free(p); gsl_vector_free(coeff); } // Calculation of corrector integration constants // ---------------------------------------------- /* * The coefficients for the Gear method (BDF) are also * calculated by solving a matrix equation A*coeff=b for the * exactness constraints. * E.g. for CorrOder=3 we have: * * _ _ _ _ _ _ * | 1 1 1 0 | | a_0 | | 1 | * | (t_n)^1 (t_n-1)^1 (t_n-2)^1 1*(t_n+1 - t_n) | | a_1 | | (t_n+1)^1 | * | (t_n)^2 (t_n-1)^2 (t_n-2)^2 2*(t_n+1 - t_n)*(t_n+1)^1 | * | a_2 | = | (t_n+1)^2 | * | (t_n)^3 (t_n-1)^3 (t_n-2)^3 3*(t_n+1 - t_n)*(t_n+1)^2 | | b_-1 | | (t_n+1)^3 | * |_ _| |_ _| |_ _| * */ if (Current.TypeTime == TIME_GEAR) { for (int c=0; c < Current.CorrOrder; c++) { A_data[c] = 1.0; for (int r=1; r <= Current.CorrOrder; r++) A_data[c + r*((int)Current.CorrOrder+1)] = pow(t[c+1],r); } A_data[(int)Current.CorrOrder] = 0.0; A_data[(int)Current.CorrOrder + 1*((int)Current.CorrOrder+1)] = t[0]-t[1]; for (int r=2; r <= Current.CorrOrder; r++) A_data[(int)Current.CorrOrder + r*((int)Current.CorrOrder+1)] = r*pow(t[0],r-1)*(t[0]-t[1]); A = gsl_matrix_view_array(A_data, Current.CorrOrder+1, Current.CorrOrder+1); b_data[0] = 1.0; for (int r=1; r <= Current.CorrOrder; r++) b_data[r] = pow(t[0],r); b = gsl_vector_view_array(b_data, Current.CorrOrder+1); coeff = gsl_vector_alloc(Current.CorrOrder+1); p = gsl_permutation_alloc(Current.CorrOrder+1); gsl_linalg_LU_decomp(&A.matrix, p, &s); gsl_linalg_LU_solve(&A.matrix, p, &b.vector, coeff); for (int i=0; iDefineSystem, TLAsystem.SystemIndex); DofData_P = DofData_P0 + TLAsystem.SystemIndex; if (!List_Nbr(DofData_P->Solutions)) Message::Error("No initial solution for system %s", System_P->Name); Solution_P = (struct Solution*) List_Pointer(DofData_P->Solutions, List_Nbr(DofData_P->Solutions)-1); TimeStep = (int)Current.TimeStep; if (Solution_P->TimeStep != TimeStep) { // if we compute a new time step Solution_S.TimeStep = TimeStep ; Solution_S.Time = Current.Time ; Solution_S.TimeImag = Current.TimeImag ; Solution_S.TimeFunctionValues = Get_TimeFunctionValues(DofData_P) ; Solution_S.SolutionExist = 1 ; LinAlg_CreateVector(&Solution_S.x, &DofData_P->Solver, DofData_P->NbrDof); List_Add(DofData_P->Solutions, &Solution_S); DofData_P->CurrentSolution = (struct Solution*) List_Pointer(DofData_P->Solutions, List_Nbr(DofData_P->Solutions)-1) ; Solution_P = DofData_P->CurrentSolution; } else { // fix time values if we recompute the same step (with different time) Solution_P->Time = Current.Time ; Solution_P->TimeImag = Current.TimeImag ; Free(Solution_P->TimeFunctionValues); Solution_P->TimeFunctionValues = Get_TimeFunctionValues(DofData_P) ; } NbrSolutions = List_Nbr(DofData_P->Solutions); if(NbrSolutions < Current.PredOrder + 2) Message::Error("Too few past solutions for system %s", System_P->Name); LinAlg_ZeroVector(&Solution_P->x); for (int j=0; j<=Current.PredOrder; j++) { PastSolution_P = (struct Solution*)List_Pointer(DofData_P->Solutions, NbrSolutions-2-j); if (!PastSolution_P->SolutionExist) Message::Error("Too few past solutions for system %s", System_P->Name); x_NminusJ_P = &PastSolution_P->x; LinAlg_AddVectorProdVectorDouble(&Solution_P->x, x_NminusJ_P, Current.aPredCoeff[j], &Solution_P->x); } xPredicted_P = (gVector*)List_Pointer(xPredicted_L, i); LinAlg_CopyVector(&Solution_P->x, xPredicted_P); } // Loop through all specified PostOperations if (List_Nbr(TLAPostOp_L) != List_Nbr(Current.PostOpData_L)) Message::Error("Current.PostOpData_L list is not up to date"); for(int i = 0; i < List_Nbr(TLAPostOp_L); i++){ PostOpSolutions_P = (struct PostOpSolutions*) List_Pointer(Current.PostOpData_L, i); NbrSolutions = List_Nbr(PostOpSolutions_P->Solutions_L); if (!NbrSolutions) Message::Error("No initial result for PostOperation %s", PostOpSolutions_P->PostOperation_P->Name); Solution_P = (struct Solution*)List_Pointer(PostOpSolutions_P->Solutions_L, NbrSolutions-1); TimeStep = (int)Current.TimeStep; if (Solution_P->TimeStep != TimeStep) { // if we compute a new time step Solution_S.TimeStep = TimeStep ; Solution_S.Time = Current.Time ; Solution_S.TimeImag = Current.TimeImag ; Solution_S.SolutionExist = 1 ; Solution_S.TimeFunctionValues = NULL; LinAlg_GetVectorSize(&Solution_P->x, &PostOpSolLength); LinAlg_CreateVector(&Solution_S.x, &DofData_P0->Solver, PostOpSolLength); List_Add(PostOpSolutions_P->Solutions_L, &Solution_S); Solution_P = (struct Solution*) List_Pointer(PostOpSolutions_P->Solutions_L, List_Nbr(PostOpSolutions_P->Solutions_L)-1); } else { // fix time values if we recompute the same step (with different time) Solution_P->Time = Current.Time ; Solution_P->TimeImag = Current.TimeImag ; } NbrSolutions = List_Nbr(PostOpSolutions_P->Solutions_L); if(NbrSolutions < Current.PredOrder + 2) Message::Error("Too few past results for PostOperation %s", PostOpSolutions_P->PostOperation_P->Name); PostOpSolPredicted_P = (gVector*)List_Pointer(PostOpSolPredicted_L, i); LinAlg_ZeroVector(PostOpSolPredicted_P); for (int j=0; j<=Current.PredOrder; j++) { PastSolution_P = (struct Solution*)List_Pointer(PostOpSolutions_P->Solutions_L, NbrSolutions-2-j); if (!PastSolution_P->SolutionExist) Message::Error("Too few past results for PostOperation %s", PostOpSolutions_P->PostOperation_P->Name); x_NminusJ_P = &PastSolution_P->x; LinAlg_AddVectorProdVectorDouble(PostOpSolPredicted_P, x_NminusJ_P, Current.aPredCoeff[j], PostOpSolPredicted_P); } } } /* ------------------------------------------------------------------------ */ /* C a l M a x L T E r a t i o */ /* ------------------------------------------------------------------------ */ double CalcMaxLTEratio(Resolution *Resolution_P, DofData *DofData_P0, List_T *TLAsystems_L, List_T *TLAPostOp_L, int Order, List_T *xPredicted_L, List_T *PostOpSolPredicted_L) { DefineSystem *DefineSystem_P; DofData *DofData_P; PostOpSolutions *PostOpSolutions_P; TimeLoopAdaptiveSystem TLAsystem; LoopErrorPostOperation TLAPostOp; Solution *Solution_P; gVector *xPredictor_P, *xCorrector_P; // predicted and actual solution vector gVector xLTE; // Local Truncation Error vector gVector *PostOpSolPred_P, *PostOpSolCorr_P; // predicted and actual solution vector gVector PostOpSolLTE; // Local Truncation Error vector double pec, cec; // predictor and corrector error constants double ErrorRatio, MaxErrorRatio; int NbrSolutions, PostOpSolLength; MaxErrorRatio = 0.; // Determine error constants pec = Current.PredErrorConst; // Predictor error constant cec = Current.CorrErrorConst; // Corrector error constant // Loop through all given systems for(int i = 0; i < List_Nbr(TLAsystems_L); i++) { List_Read(TLAsystems_L, i, &TLAsystem); DefineSystem_P = (DefineSystem*)List_Pointer(Resolution_P->DefineSystem, TLAsystem.SystemIndex); DofData_P = DofData_P0 + TLAsystem.SystemIndex; NbrSolutions = List_Nbr(DofData_P->Solutions); if(NbrSolutions < Order + 1) Message::Error("Too few past solutions for system %s", DefineSystem_P->Name); xPredictor_P = (gVector*)List_Pointer(xPredicted_L, i); xCorrector_P = &((struct Solution*)List_Pointer(DofData_P->Solutions, NbrSolutions-1))->x; // Vector of all local truncation errors // xLTE = cec / (pec - cec) * (xCorrector - xPredictor) LinAlg_CreateVector(&xLTE, &DofData_P->Solver, DofData_P->NbrDof); LinAlg_CopyVector(xCorrector_P, &xLTE); LinAlg_SubVectorVector(&xLTE, xPredictor_P, &xLTE); LinAlg_ProdVectorDouble(&xLTE, cec / (pec - cec), &xLTE); Cal_SolutionErrorRatio(&xLTE, xCorrector_P, TLAsystem.SystemLTEreltol, TLAsystem.SystemLTEabstol, TLAsystem.NormType, &ErrorRatio); LinAlg_DestroyVector(&xLTE); if (ErrorRatio != ErrorRatio) { // If ErrorRatio = NaN => There was no valid solution! MaxErrorRatio = ErrorRatio; break; } if (ErrorRatio > MaxErrorRatio) MaxErrorRatio = ErrorRatio; if(Message::GetVerbosity() > 5) { Message::Info("LTE %s of error ratio from system %s: %.3g", TLAsystem.NormTypeString, DefineSystem_P->Name, ErrorRatio); } } // Loop through all given PostOperations if (List_Nbr(TLAPostOp_L) != List_Nbr(Current.PostOpData_L)) Message::Error("Current PostOpData_L list is not up to date"); for(int i = 0; i < List_Nbr(TLAPostOp_L); i++) { List_Read(TLAPostOp_L, i, &TLAPostOp); PostOpSolutions_P = (struct PostOpSolutions*) List_Pointer(Current.PostOpData_L, i); NbrSolutions = List_Nbr(PostOpSolutions_P->Solutions_L); if(NbrSolutions < Order + 1) Message::Error("Too few past solutions for PostOperations %s", PostOpSolutions_P->PostOperation_P->Name); Solution_P = (struct Solution*) List_Pointer(PostOpSolutions_P->Solutions_L, NbrSolutions-1); PostOpSolPred_P = (gVector*)List_Pointer(PostOpSolPredicted_L, i); PostOpSolCorr_P = &Solution_P->x; // Vector of all local truncation errors // xLTE = cec / (pec - cec) * (xCorrector - xPredictor) LinAlg_GetVectorSize(PostOpSolCorr_P, &PostOpSolLength); LinAlg_CreateVector(&PostOpSolLTE, &DofData_P0->Solver, PostOpSolLength); LinAlg_CopyVector(PostOpSolCorr_P, &PostOpSolLTE); LinAlg_SubVectorVector(&PostOpSolLTE, PostOpSolPred_P, &PostOpSolLTE); LinAlg_ProdVectorDouble(&PostOpSolLTE, cec / (pec - cec), &PostOpSolLTE); Cal_SolutionErrorRatio(&PostOpSolLTE, PostOpSolCorr_P, TLAPostOp.PostOperationReltol, TLAPostOp.PostOperationAbstol, TLAPostOp.NormType, &ErrorRatio); LinAlg_DestroyVector(&PostOpSolLTE); if (ErrorRatio != ErrorRatio) { // If ErrorRatio = NaN => There was no valid solution! MaxErrorRatio = ErrorRatio; break; } if (ErrorRatio > MaxErrorRatio) MaxErrorRatio = ErrorRatio; if(Message::GetVerbosity() > 5) { Message::Info("LTE %s of error ratio from PostOperation %s: %.3g", TLAPostOp.NormTypeString, PostOpSolutions_P->PostOperation_P->Name, ErrorRatio); } } return MaxErrorRatio; } /* ------------------------------------------------------------------------ */ /* G e t I n t e g r a t i o n S c h e m e */ /* ------------------------------------------------------------------------ */ void GetIntegrationScheme(Operation *Operation_P, int *TypeTime, int *MaxOrder) { if (!strcmp(Operation_P->Case.TimeLoopAdaptive.Scheme, "Euler")) { *TypeTime = TIME_THETA; *MaxOrder = 1; } else if (!strcmp(Operation_P->Case.TimeLoopAdaptive.Scheme, "Trapezoidal")) { *TypeTime = TIME_THETA; *MaxOrder = 2; } else if (!strcmp(Operation_P->Case.TimeLoopAdaptive.Scheme, "Gear_2") || !strcmp(Operation_P->Case.TimeLoopAdaptive.Scheme, "BDF_2")) { *TypeTime = TIME_GEAR; *MaxOrder = 2; } else if (!strcmp(Operation_P->Case.TimeLoopAdaptive.Scheme, "Gear_3") || !strcmp(Operation_P->Case.TimeLoopAdaptive.Scheme, "BDF_3")) { *TypeTime = TIME_GEAR; *MaxOrder = 3; } else if (!strcmp(Operation_P->Case.TimeLoopAdaptive.Scheme, "Gear_4") || !strcmp(Operation_P->Case.TimeLoopAdaptive.Scheme, "BDF_4")) { *TypeTime = TIME_GEAR; *MaxOrder = 4; } else if (!strcmp(Operation_P->Case.TimeLoopAdaptive.Scheme, "Gear_5") || !strcmp(Operation_P->Case.TimeLoopAdaptive.Scheme, "BDF_5")) { *TypeTime = TIME_GEAR; *MaxOrder = 5; } else if (!strcmp(Operation_P->Case.TimeLoopAdaptive.Scheme, "Gear_6") || !strcmp(Operation_P->Case.TimeLoopAdaptive.Scheme, "BDF_6")) { *TypeTime = TIME_GEAR; *MaxOrder = 6; } else Message::Error("Unknown integration scheme: %s", Operation_P->Case.TimeLoopAdaptive.Scheme); } /* ------------------------------------------------------------------------ */ /* O p e r a t i o n _ T i m e L o o p A d a p t i v e */ /* ------------------------------------------------------------------------ */ void Operation_TimeLoopAdaptive(Resolution *Resolution_P, Operation *Operation_P, DofData *DofData_P0, GeoData *GeoData_P0, int *Flag_Break) { int TypeTime=0, MaxOrder=0, Order=0, TLATimeStep; int Try, BreakpointNum, NbrSolutions=0, NbrPostOps; double Save_Time, Save_DTime, Save_Theta, maxLTEratio=0, nextBreakpoint; double Save_TimeStep, FirstTimePoint, DTimeBeforeBreakpoint=1.; bool TimeStepAccepted=true, DTimeMinAtLastStep, BreakpointListCreated; bool BreakpointAtThisStep, BreakpointAtNextStep; double Time0, TimeMax, DTimeInit, DTimeMin, DTimeMax; double LTEtarget, DTimeMaxScal, DTimeScal_NotConverged, DTimeScal_PETScError; double DTimeScal=1.0; List_T *Breakpoints_L, *TLAsystems_L, *LEPostOp_L; List_T *LEPostOpNames_L; List_T *xPredicted_L, *PostOpSolPredicted_L; TimeLoopAdaptiveSystem TLAsystem; DofData *DofData_P=NULL; gVector xPredicted_S; // Some default values for constants influencing the time stepping LTEtarget = 0.8; // target LTE ratio for next step (should be below 1) DTimeMaxScal = 2.0; // maximum factor for increasing the time step DTime DTimeScal_NotConverged = 0.25; // step size scaling in case of a not converged iterative loop DTimeScal_PETScError = 0.25; // step size scaling in case of a PETSc error // Override default values if they are provided by the user LTEtarget = (Operation_P->Case.TimeLoopAdaptive.LTEtarget < 0) ? LTEtarget : Operation_P->Case.TimeLoopAdaptive.LTEtarget; DTimeMaxScal = (Operation_P->Case.TimeLoopAdaptive.DTimeMaxScal < 0 ) ? DTimeMaxScal : Operation_P->Case.TimeLoopAdaptive.DTimeMaxScal; DTimeScal_NotConverged = (Operation_P->Case.TimeLoopAdaptive.DTimeScal_NotConverged < 0) ? DTimeScal_NotConverged : Operation_P->Case.TimeLoopAdaptive.DTimeScal_NotConverged; DTimeScal_PETScError = (Operation_P->Case.TimeLoopAdaptive.DTimeScal_NotConverged < 0) ? DTimeScal_PETScError : Operation_P->Case.TimeLoopAdaptive.DTimeScal_NotConverged; Time0 = Operation_P->Case.TimeLoopAdaptive.Time0; TimeMax = Operation_P->Case.TimeLoopAdaptive.TimeMax; DTimeInit = Operation_P->Case.TimeLoopAdaptive.DTimeInit; DTimeMin = Operation_P->Case.TimeLoopAdaptive.DTimeMin; DTimeMax = Operation_P->Case.TimeLoopAdaptive.DTimeMax; Breakpoints_L = Operation_P->Case.TimeLoopAdaptive.Breakpoints_L; TLAsystems_L = Operation_P->Case.TimeLoopAdaptive.TimeLoopAdaptiveSystems_L; LEPostOp_L = Operation_P->Case.TimeLoopAdaptive.TimeLoopAdaptivePOs_L; GetIntegrationScheme(Operation_P, &TypeTime, &MaxOrder); xPredicted_L = List_Create(4,4,sizeof(gVector)); PostOpSolPredicted_L = List_Create(4,4,sizeof(gVector)); // Just some checks // ---------------- if (TLAsystems_L == NULL) TLAsystems_L = List_Create(1,1,sizeof(TimeLoopAdaptiveSystem)); if (LEPostOp_L == NULL) LEPostOp_L = List_Create(1,1,sizeof(LoopErrorPostOperation)); // Check the timing values if (Time0 > TimeMax) Message::Error("Time0 > TimeMax"); if (DTimeInit < DTimeMin) Message::Error("DTimeInit < DTimeMin"); if (DTimeInit > DTimeMax) Message::Error("DTimeInit > DTimeMax"); if (DTimeInit > TimeMax - Time0) Message::Error("DTimeInit > (TimeMax - Time0"); // Initialization before starting the time loop // -------------------------------------------- // Check if initial solutions for all specified systems are available // and create vectors for the predicted solutions for(int i = 0; i < List_Nbr(TLAsystems_L); i++){ List_Read(TLAsystems_L, i, &TLAsystem); DefineSystem *System_P = (DefineSystem*)List_Pointer(Resolution_P->DefineSystem, TLAsystem.SystemIndex); DofData_P = DofData_P0 + TLAsystem.SystemIndex; NbrSolutions = List_Nbr(DofData_P->Solutions); if(!NbrSolutions) Message::Error("No initial solution for system %s", System_P->Name); LinAlg_CreateVector(&xPredicted_S, &DofData_P->Solver, DofData_P->NbrDof); List_Add(xPredicted_L, &xPredicted_S); } // Initializing stuff for PostOperations NbrPostOps = List_Nbr(LEPostOp_L); LEPostOpNames_L = List_Create(NbrPostOps,1,sizeof(char *)); InitLEPostOperation(Resolution_P, DofData_P0, GeoData_P0, LEPostOp_L, LEPostOpNames_L, PostOpSolPredicted_L); // Some other necessary initializations if(Flag_RESTART && NbrSolutions > 1) Current.DTime = ((struct Solution*)List_Pointer(DofData_P->Solutions, NbrSolutions-1))->Time - ((struct Solution*)List_Pointer(DofData_P->Solutions, NbrSolutions-2))->Time; else Current.DTime = DTimeInit; if(Flag_RESTART) { if (Current.Time < TimeMax) Flag_RESTART = 0 ; } else Current.Time = Time0 ; Current.TimeStep += 1.0; TLATimeStep = 1; // Starting with 1st order (Backward Euler corrector) Order = 1; if (TypeTime == TIME_THETA) Current.Theta = 1.0; BreakpointListCreated = !Breakpoints_L; if (BreakpointListCreated) Breakpoints_L = List_Create(1,1,sizeof(double)); List_Add(Breakpoints_L, &TimeMax); List_Sort(Breakpoints_L, fcmp_double); BreakpointNum = 0; BreakpointAtNextStep = false; List_Read(Breakpoints_L, BreakpointNum, &nextBreakpoint); FirstTimePoint = Current.Time+Current.DTime; Current.Breakpoint = List_ISearchSeq(Breakpoints_L, &FirstTimePoint, fcmp_double); if (Current.Breakpoint >= 0) { BreakpointAtNextStep = true; DTimeBeforeBreakpoint = Current.DTime; } for (int i = 0; i < List_Nbr(Breakpoints_L); i++){ List_Read(Breakpoints_L, i, &nextBreakpoint); if (nextBreakpoint > (FirstTimePoint + DTimeMin)) { BreakpointNum = i; break; } } Try = 0; // Start the time loop // ------------------- while (Current.Time < TimeMax) { if(Message::GetOnelabAction() == "stop") break; Message::SetOperatingInTimeLoopAdaptive(true); Current.TypeTime = TypeTime; Current.Time += Current.DTime; Save_DTime = Current.DTime; Save_Time = Current.Time; Save_TimeStep = Current.TimeStep; Save_Theta = Current.Theta; Try++; BreakpointAtThisStep = BreakpointAtNextStep; Message::SetLastPETScError(0); Message::Info("Time step %d Try %d Time = %.8g s Stepsize = %.8g s Integr. Order = %d", (int)Current.TimeStep, Try, Current.Time, Current.DTime, Order); if(Message::GetProgressMeterStep() > 0 && Message::GetProgressMeterStep() < 100){ Message::AddOnelabNumberChoice(Message::GetOnelabClientName() + "/TimeLoopAdaptive/Time", Current.Time); Message::AddOnelabNumberChoice(Message::GetOnelabClientName() + "/TimeLoopAdaptive/DTime", Current.DTime); } // Calculate integration coefficients CalcIntegrationCoefficients(Resolution_P, DofData_P0,TLAsystems_L, LEPostOp_L, Order); // Execute predictor Predictor(Resolution_P, DofData_P0, TLAsystems_L, LEPostOp_L, Order, xPredicted_L, PostOpSolPredicted_L); if (NbrPostOps && TimeStepAccepted) Free_UnusedPOresults(); // Execute corrector // ----------------- Flag_IterativeLoopConverged = 1; Treatment_Operation(Resolution_P, Operation_P->Case.TimeLoopAdaptive.Operation, DofData_P0, GeoData_P0, NULL, NULL) ; Current.Time = Save_Time; Current.TypeTime = TypeTime; Current.DTime = Save_DTime; Current.TimeStep = Save_TimeStep; Current.Theta = Save_Theta; if(*Flag_Break) { *Flag_Break = 0; Message::Info("Flag Break detected. Aborting TimeLoopAdaptive"); break; } // Assessing the current time step and eventually // execute the 2nd set of operations // ---------------------------------------------- if (Flag_IterativeLoopConverged != 1){ TimeStepAccepted = false; DTimeScal = DTimeScal_NotConverged; Message::Info("Time step %d Try %d Time = %.8g s rejected (IterativeLoop not " "converged)", (int)Current.TimeStep, Try, Current.Time); } else if (Message::GetLastPETScError()) { TimeStepAccepted = false; Flag_IterativeLoopConverged = 0; DTimeScal = DTimeScal_PETScError; Message::Warning("Time step %d Try %d Time = %.8g s rejected:", (int)Current.TimeStep, Try, Current.Time); Message::Warning("No valid solution found (PETSc-Error: %d)!", Message::GetLastPETScError()); Message::SetLastPETScError(0); } else{ if (NbrPostOps) // Execute the PostOperations if necessary Operation_PostOperation(Resolution_P, DofData_P0, GeoData_P0, LEPostOpNames_L); maxLTEratio = CalcMaxLTEratio(Resolution_P, DofData_P0, TLAsystems_L, LEPostOp_L, Order, xPredicted_L, PostOpSolPredicted_L); if (maxLTEratio != maxLTEratio) { // If maxLTEratio = NaN => There was no valid solution! TimeStepAccepted = false; Flag_IterativeLoopConverged = 0; DTimeScal = DTimeScal_PETScError; Message::Info("Time step %d Try %d Time = %.8g s rejected: No valid solution " "found (NaN or Inf)!", (int)Current.TimeStep, Try, Current.Time); } else { if(Message::GetVerbosity() > 4) Message::AddOnelabNumberChoice(Message::GetOnelabClientName() + "/TimeLoopAdaptive/LTEmaxErrorRatio", maxLTEratio); if (maxLTEratio <= 1.0){ TimeStepAccepted = true; Message::Info("Time step %d Try %d Time = %.8g s accepted (max. LTE ratio = %.3g)", (int)Current.TimeStep, Try, Current.Time, maxLTEratio); } else{ TimeStepAccepted = false; Message::Info("Time step %d Try %d Time = %.8g s rejected (max. LTE ratio = %.3g)", (int)Current.TimeStep, Try, Current.Time, maxLTEratio); } } } if (TimeStepAccepted == true) { Treatment_Operation(Resolution_P, Operation_P->Case.TimeLoopAdaptive.OperationEnd, DofData_P0, GeoData_P0, NULL, NULL) ; Current.Time = Save_Time; Current.TypeTime = TypeTime; Current.DTime = Save_DTime; Current.TimeStep = Save_TimeStep; Current.Theta = Save_Theta; Current.TimeStep += 1.; TLATimeStep += 1; Try = 0; } else{ if (BreakpointAtThisStep) { BreakpointNum = List_ISearchSeq(Breakpoints_L, &Current.Time, fcmp_double); List_Read(Breakpoints_L, BreakpointNum, &nextBreakpoint); } Current.Time -= Current.DTime; BreakpointAtThisStep = (bool) List_Search(Breakpoints_L, &Current.Time, fcmp_double); } if(*Flag_Break) { *Flag_Break = 0; Message::Info("Flag Break detected. Aborting TimeLoopAdaptive"); break; } // Calculate new time step // ----------------------- DTimeMinAtLastStep = Current.DTime <= DTimeMin; if (TimeStepAccepted == false && DTimeMinAtLastStep && Order < 2) Message::Error("Time step too small! Simulation aborted!"); if (Flag_IterativeLoopConverged == 1){ // Milne's estimate if (maxLTEratio <= 0) DTimeScal = DTimeMaxScal; else { if (Current.TimeStep < 1.5 || (NbrPostOps > 0 && TLATimeStep <= 2) ) // linear adjustment because predictor is of order 0 DTimeScal = LTEtarget/maxLTEratio; else DTimeScal = pow(LTEtarget/maxLTEratio, 1./(Order+1.)); } if (DTimeScal >= DTimeMaxScal) { if (BreakpointAtThisStep) { double dt1, dt2, dtmax; dt1 = Current.DTime * DTimeMaxScal; dt2 = DTimeBeforeBreakpoint; dtmax = (dt1 > dt2) ? dt1 : dt2; DTimeScal = dtmax / Current.DTime; } else DTimeScal = DTimeMaxScal; } } Current.DTime *= DTimeScal; // Limit the max step size if (Current.DTime > DTimeMax) Current.DTime = DTimeMax; // Check that we do not jump over a breakpoint if ((Current.DTime + Current.Time >= nextBreakpoint - DTimeMin) && (BreakpointNum >= 0)){ DTimeBeforeBreakpoint = Current.DTime; Current.DTime = nextBreakpoint - Current.Time; BreakpointAtNextStep = true; Current.Breakpoint = BreakpointNum; if (BreakpointNum < List_Nbr(Breakpoints_L)-1){ // There are further breakpoints BreakpointNum++; List_Read(Breakpoints_L, BreakpointNum, &nextBreakpoint); } else //No further breakpoint BreakpointNum = -1; } else { BreakpointAtNextStep = false; Current.Breakpoint = -1.; } // Limit the min step size if (Current.DTime < DTimeMin) Current.DTime = DTimeMin; // Adjust order // ------------ if ( Flag_IterativeLoopConverged != 1 || // BreakpointAtThisStep || DTimeMinAtLastStep ) Order = 1; else if ( TLATimeStep > 2 && Current.DTime > DTimeMin && TimeStepAccepted && !BreakpointAtThisStep && Order < MaxOrder ) Order++; if (TypeTime == TIME_THETA) switch(Order){ case 1: Current.Theta = 1.0; // Corrector: Backward Euler break; case 2: Current.Theta = 0.5; // Corrector: Trapezoidal Method break; default : Message::Error("Order %d not allowed for Theta scheme.", Order); break; } } // while loop Message::SetOperatingInTimeLoopAdaptive(false); Current.TimeStep -= 1.; // Correct the time step counter // Finally clean up, destroy vectors and delete lists // -------------------------------------------------- for(int i = 0; i < List_Nbr(TLAsystems_L); i++) LinAlg_DestroyVector((gVector*)List_Pointer(xPredicted_L, i)); List_Delete(TLAsystems_L); List_Delete(xPredicted_L); ClearLEPostOperation(Resolution_P, DofData_P0, GeoData_P0, LEPostOp_L, LEPostOpNames_L, PostOpSolPredicted_L, true); if (BreakpointListCreated) List_Delete(Breakpoints_L); } getdp-2.4.2-source/Legacy/Operation_PostOperation.cpp000755 001750 001750 00000026425 12116424202 024344 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // #include #include #include #include #include "GetDPConfig.h" #include "ProData.h" #include "DofData.h" #include "SolvingOperations.h" #include "SolvingAnalyse.h" #include "Message.h" #include "MallocUtils.h" extern struct CurrentData Current; extern struct Problem Problem_S; /* ------------------------------------------------------------------------ */ /* O p e r a t i o n _ P o s t O p e r a t i o n */ /* ------------------------------------------------------------------------ */ void Operation_PostOperation(Resolution *Resolution_P, DofData *DofData_P0, GeoData *GeoData_P0, List_T *PostOperationNames) { double Save_Time, Save_TimeImag, Save_TimeStep; char *str; int i, j, k; Element *Save_Element; PostOperation *PostOperation_P; PostProcessing *PostProcessing_P ; Save_Time = Current.Time ; Save_TimeImag = Current.TimeImag ; Save_TimeStep = Current.TimeStep ; Save_Element = Current.Element; for(int i=0 ; iPostProcessingIndex) ; Current.PostOpDataIndex = i; Treatment_PostOperation(Resolution_P, DofData_P0, (struct DefineSystem *)List_Pointer(Resolution_P->DefineSystem, 0), GeoData_P0, PostProcessing_P, PostOperation_P) ; } } /* the post-processing can (and usually will) change the current timestep, current time and current solution pointers: we need to reset them */ Current.Time = Save_Time ; Current.TimeImag = Save_TimeImag ; Current.TimeStep = Save_TimeStep ; for (k = 0 ; k < Current.NbrSystem ; k++){ i = List_Nbr((Current.DofData_P0+k)->Solutions) - 1; if(i >= 0) (Current.DofData_P0+k)->CurrentSolution = (struct Solution*) List_Pointer((Current.DofData_P0+k)->Solutions, i); } Current.Element = Save_Element; Current.PostOpDataIndex = -1; } /* ------------------------------------------------------------------------ */ /* I n i t L E P o s t O p e r a t i o n */ /* ------------------------------------------------------------------------ */ void InitLEPostOperation(Resolution *Resolution_P, DofData *DofData_P0, GeoData *GeoData_P0, List_T *LEPostOp_L, List_T *LEPostOpNames_L, List_T *PostOpSolution_L) { int NbrPostOps, Index, NbrPostSubOperation, PostOpSolLength; int *Save_Format_P, *Save_LastTimeStepOnly_P; char **Save_FileOut_P; PostOpSolutions *PostOpSolutions_P, PostOpSolutions_S; LoopErrorPostOperation *LEPostOp_P; PostSubOperation *PostSubOperation_P; List_T *PostSubOperation_L; gVector PostOpSolution_S; Current.PostOpData_L = NULL; NbrPostOps = List_Nbr(LEPostOp_L); if (NbrPostOps) { Current.PostOpData_L = List_Create(NbrPostOps,1,sizeof(PostOpSolutions)); for (int i=0; i < NbrPostOps; i++) { LEPostOp_P = (struct LoopErrorPostOperation*)List_Pointer(LEPostOp_L, i); Index = List_ISearchSeq(Problem_S.PostOperation, LEPostOp_P->PostOperationName, fcmp_PostOperation_Name); LEPostOp_P->PostOperationIndex = Index; if(Index < 0) Message::Error("Unknown PostOperation %s in TimeLoopAdaptive", LEPostOp_P->PostOperationName); PostOpSolutions_S.PostOperation_P = (struct PostOperation*) List_Pointer(Problem_S.PostOperation, Index) ; PostSubOperation_L = PostOpSolutions_S.PostOperation_P->PostSubOperation; NbrPostSubOperation = List_Nbr(PostSubOperation_L); if (NbrPostSubOperation) { LEPostOp_P->Save_Format_L = List_Create(NbrPostSubOperation,2, sizeof(int)); LEPostOp_P->Save_LastTimeStepOnly_L = List_Create(NbrPostSubOperation, 2,sizeof(int)); LEPostOp_P->Save_FileOut_L = List_Create(NbrPostSubOperation, 2,sizeof(char *)); } for (int j=0; jFormat; Save_LastTimeStepOnly_P = &PostSubOperation_P->LastTimeStepOnly; Save_FileOut_P = &PostSubOperation_P->FileOut; List_Add(LEPostOp_P->Save_Format_L, Save_Format_P); List_Add(LEPostOp_P->Save_LastTimeStepOnly_L, Save_LastTimeStepOnly_P); List_Add(LEPostOp_P->Save_FileOut_L, Save_FileOut_P); *Save_Format_P = FORMAT_LOOP_ERROR; *Save_LastTimeStepOnly_P = 1; *Save_FileOut_P = NULL; } PostOpSolutions_S.Solutions_L = List_Create(2,2,sizeof(Solution)); List_Add(Current.PostOpData_L, &PostOpSolutions_S); List_Add(LEPostOpNames_L, &LEPostOp_P->PostOperationName); } // Execute the PostOperations Operation_PostOperation(Resolution_P, DofData_P0, GeoData_P0, LEPostOpNames_L); // Creating vectors for the PostOperation-solution for (int i=0; i < NbrPostOps; i++) { PostOpSolutions_P = (struct PostOpSolutions*) List_Pointer(Current.PostOpData_L, i); LinAlg_GetVectorSize (&((struct Solution*)List_Pointer(PostOpSolutions_P->Solutions_L, 0))->x, &PostOpSolLength); LinAlg_CreateVector(&PostOpSolution_S, &DofData_P0->Solver, PostOpSolLength); List_Add(PostOpSolution_L, &PostOpSolution_S); } } } /* ------------------------------------------------------------------------ */ /* F r e e _ U n u s e d P o s t O p e r a t i o n R e s u l t s */ /* ------------------------------------------------------------------------ */ void Free_UnusedPOresults() { struct Solution *Solution_P; int index = -1; PostOpSolutions *PostOpSolutions_P; for(int i = 0; i < List_Nbr(Current.PostOpData_L); i++) { PostOpSolutions_P = (struct PostOpSolutions*) List_Pointer(Current.PostOpData_L, i); // We store 1 solution too much (to allow for an imbricated iterative loop) switch (Current.TypeTime) { case TIME_THETA : index = List_Nbr(PostOpSolutions_P->Solutions_L)-4 ; // Fore TimeLoopAdaptive (Trapezoidal) we need 3 past solutions for the predictor index = Message::GetOperatingInTimeLoopAdaptive() ? index - 1 : index; break; case TIME_GEAR : // With -9 we store 7 past solutions (for Gear_6) index = List_Nbr(PostOpSolutions_P->Solutions_L)-9 ; break; case TIME_NEWMARK : index = List_Nbr(PostOpSolutions_P->Solutions_L)-4 ; break; } if(index >= 0){ Solution_P = (struct Solution*) List_Pointer(PostOpSolutions_P->Solutions_L, index); if(Solution_P->SolutionExist){ Message::Info("Freeing PostOperationResult %d", index); LinAlg_DestroyVector(&Solution_P->x); if (Solution_P->TimeFunctionValues) Free(Solution_P->TimeFunctionValues); Solution_P->SolutionExist = 0 ; } } } } /* ------------------------------------------------------------------------ */ /* F r e e _ A l l P o s t O p e r a t i o n R e s u l t s */ /* ------------------------------------------------------------------------ */ void Free_AllPOresults() { PostOpSolutions *PostOpSolutions_P; Solution *Solution_P; for (int i=0; i < List_Nbr(Current.PostOpData_L); i++) { PostOpSolutions_P = (struct PostOpSolutions*)List_Pointer(Current.PostOpData_L, i); for (int j=0; j < List_Nbr(PostOpSolutions_P->Solutions_L); j++) { Solution_P = (struct Solution*)List_Pointer(PostOpSolutions_P->Solutions_L, j); if (Solution_P->SolutionExist) LinAlg_DestroyVector(&Solution_P->x); if (Solution_P->TimeFunctionValues) Free(Solution_P->TimeFunctionValues); } List_Delete(PostOpSolutions_P->Solutions_L); } List_Delete(Current.PostOpData_L); Current.PostOpData_L = NULL; Current.PostOpDataIndex = -1; } /* ------------------------------------------------------------------------ */ /* C l e a r L E P o s t O p e r a t i o n */ /* ------------------------------------------------------------------------ */ void ClearLEPostOperation(Resolution *Resolution_P, DofData *DofData_P0, GeoData *GeoData_P0, List_T *LEPostOp_L, List_T *LEPostOpNames_L, List_T *PostOpSolution_L, bool Delete_LEPostOp_L) { int Index, NbrPostSubOperation; int *Format_P, *LastTimeStepOnly_P; char **FileOut_P; LoopErrorPostOperation *LEPostOp_P; PostSubOperation *PostSubOperation_P; List_T *PostSubOperation_L; for(int i = 0; i < List_Nbr(LEPostOp_L); i++) { LEPostOp_P = (struct LoopErrorPostOperation*)List_Pointer(LEPostOp_L, i); NbrPostSubOperation = List_Nbr(LEPostOp_P->Save_Format_L); Index = LEPostOp_P->PostOperationIndex; PostSubOperation_L = ((struct PostOperation*) List_Pointer(Problem_S.PostOperation, Index)) ->PostSubOperation; // Restore variables Format, LastTimeStepOnly and FileOut of all used PostOperations for (int j=0; jFormat; LastTimeStepOnly_P = &PostSubOperation_P->LastTimeStepOnly; FileOut_P = &PostSubOperation_P->FileOut; List_Read(LEPostOp_P->Save_Format_L, j, Format_P); List_Read(LEPostOp_P->Save_LastTimeStepOnly_L, j, LastTimeStepOnly_P); List_Read(LEPostOp_P->Save_FileOut_L, j, FileOut_P); } if (Delete_LEPostOp_L) free(LEPostOp_P->PostOperationName); LinAlg_DestroyVector((gVector*)List_Pointer(PostOpSolution_L, i)); } if (Delete_LEPostOp_L) List_Delete(LEPostOp_L); List_Delete(PostOpSolution_L); Free_AllPOresults(); List_Delete(LEPostOpNames_L); } getdp-2.4.2-source/Legacy/BF_NodeXYZ.cpp000644 001750 001750 00000016415 12116424202 021360 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "ProData.h" #include "BF.h" #include "Get_Geometry.h" #include "Message.h" #define ARGS \ struct Element * Element, int NumNode, \ double u, double v, double w, double s[] /* ------------------------------------------------------------------------ */ /* B F _ N o d e X , Y , Z */ /* ------------------------------------------------------------------------ */ #define BF(BF_NodeX_, BF_Node_, use_, dum1_, dum2_) \ s[dum1_] = s[dum2_] = 0. ; \ (BF_Node_)(Element, NumNode, u, v, w, &s[use_]); void BF_NodeX(ARGS) { BF("BF_NodeX", BF_Node, 0, 1, 2) ; } void BF_NodeX_2E(ARGS) { BF("BF_NodeX_2E", BF_Node_2E, 0, 1, 2) ; } void BF_NodeX_2F(ARGS) { BF("BF_NodeX_2F", BF_Node_2F, 0, 1, 2) ; } void BF_NodeX_2V(ARGS) { BF("BF_NodeX_2V", BF_Node_2V, 0, 1, 2) ; } void BF_NodeX_3E(ARGS) { BF("BF_NodeX_3E", BF_Node_3E, 0, 1, 2) ; } void BF_NodeX_3F(ARGS) { BF("BF_NodeX_3F", BF_Node_3F, 0, 1, 2) ; } void BF_NodeX_3V(ARGS) { BF("BF_NodeX_3V", BF_Node_3V, 0, 1, 2) ; } void BF_NodeY(ARGS) { BF("BF_NodeY", BF_Node, 1, 0, 2) ; } void BF_NodeY_2E(ARGS) { BF("BF_NodeY_2E", BF_Node_2E, 1, 0, 2) ; } void BF_NodeY_2F(ARGS) { BF("BF_NodeY_2F", BF_Node_2F, 1, 0, 2) ; } void BF_NodeY_2V(ARGS) { BF("BF_NodeY_2V", BF_Node_2V, 1, 0, 2) ; } void BF_NodeY_3E(ARGS) { BF("BF_NodeY_3E", BF_Node_3E, 1, 0, 2) ; } void BF_NodeY_3F(ARGS) { BF("BF_NodeY_3F", BF_Node_3F, 1, 0, 2) ; } void BF_NodeY_3V(ARGS) { BF("BF_NodeY_3V", BF_Node_3V, 1, 0, 2) ; } void BF_NodeZ(ARGS) { BF("BF_NodeZ", BF_Node, 2, 0, 1) ; } void BF_NodeZ_2E(ARGS) { BF("BF_NodeZ_2E", BF_Node_2E, 2, 0, 1) ; } void BF_NodeZ_2F(ARGS) { BF("BF_NodeZ_2F", BF_Node_2F, 2, 0, 1) ; } void BF_NodeZ_2V(ARGS) { BF("BF_NodeZ_2V", BF_Node_2V, 2, 0, 1) ; } void BF_NodeZ_3E(ARGS) { BF("BF_NodeZ_3E", BF_Node_3E, 2, 0, 1) ; } void BF_NodeZ_3F(ARGS) { BF("BF_NodeZ_3F", BF_Node_3F, 2, 0, 1) ; } void BF_NodeZ_3V(ARGS) { BF("BF_NodeZ_3V", BF_Node_3V, 2, 0, 1) ; } #undef BF /* ------------------------------------------------------------------------ */ /* B F _ N o d e X , Y , Z _ D . . . */ /* ------------------------------------------------------------------------ */ void BF_NodeX_D12(struct Element * Element, int NumNode, double u, double v, double w, double s[]) { double su[3] ; BF_GradNode(Element, NumNode, u, v, w, su) ; ChangeOfCoord_Form1(Element, su, s) ; s[2] = s[1] ; s[1] = 0. ; } void BF_NodeY_D12(struct Element * Element, int NumNode, double u, double v, double w, double s[]) { double su[3] ; BF_GradNode(Element, NumNode, u, v, w, su) ; ChangeOfCoord_Form1(Element, su, s) ; s[2] = s[0] ; s[0] = 0. ; } void BF_NodeZ_D12(struct Element * Element, int NumNode, double u, double v, double w, double s[]) { s[0] = s[1] = s[2] = 0. ; } void BF_NodeX_D12_2E(struct Element * Element, int NumEdge, double u, double v, double w, double s[]) { double su[3] ; BF_GradNode_2E(Element, NumEdge, u, v, w, su) ; ChangeOfCoord_Form1(Element, su, s) ; s[2] = s[1] ; s[1] = 0. ; } void BF_NodeY_D12_2E(struct Element * Element, int NumEdge, double u, double v, double w, double s[]) { double su[3] ; BF_GradNode_2E(Element, NumEdge, u, v, w, su) ; ChangeOfCoord_Form1(Element, su, s) ; s[2] = s[0] ; s[0] = 0. ; } void BF_NodeZ_D12_2E(struct Element * Element, int NumEdge, double u, double v, double w, double s[]) { s[0] = s[1] = s[2] = 0. ; } /* ------------------------------------------------------------------------ */ #define BF(BF_NodeX_D1_, BF_GradNode_, zero1_, zero2_) \ double su[3] ; \ (BF_GradNode_)(Element, NumNode, u, v, w, su) ; \ ChangeOfCoord_Form1(Element, su, s) ; \ s[zero1_] = s[zero2_] = 0; void BF_NodeX_D1(ARGS) { BF("BF_NodeX_D1", BF_GradNode, 1, 2) ; } void BF_NodeX_D1_2E(ARGS) { BF("BF_NodeX_D1_2E", BF_GradNode_2E, 1, 2) ; } void BF_NodeX_D1_2F(ARGS) { BF("BF_NodeX_D1_2F", BF_GradNode_2F, 1, 2) ; } void BF_NodeX_D1_2V(ARGS) { BF("BF_NodeX_D1_2V", BF_GradNode_2V, 1, 2) ; } void BF_NodeX_D1_3E(ARGS) { BF("BF_NodeX_D1_3E", BF_GradNode_3E, 1, 2) ; } void BF_NodeX_D1_3F(ARGS) { BF("BF_NodeX_D1_3F", BF_GradNode_3F, 1, 2) ; } void BF_NodeX_D1_3V(ARGS) { BF("BF_NodeX_D1_3V", BF_GradNode_3V, 1, 2) ; } void BF_NodeY_D1(ARGS) { BF("BF_NodeY_D1", BF_GradNode, 0, 2) ; } void BF_NodeY_D1_2E(ARGS) { BF("BF_NodeY_D1_2E", BF_GradNode_2E, 0, 2) ; } void BF_NodeY_D1_2F(ARGS) { BF("BF_NodeY_D1_2F", BF_GradNode_2F, 0, 2) ; } void BF_NodeY_D1_2V(ARGS) { BF("BF_NodeY_D1_2V", BF_GradNode_2V, 0, 2) ; } void BF_NodeY_D1_3E(ARGS) { BF("BF_NodeY_D1_3E", BF_GradNode_3E, 0, 2) ; } void BF_NodeY_D1_3F(ARGS) { BF("BF_NodeY_D1_3F", BF_GradNode_3F, 0, 2) ; } void BF_NodeY_D1_3V(ARGS) { BF("BF_NodeY_D1_3V", BF_GradNode_3V, 0, 2) ; } void BF_NodeZ_D1(ARGS) { BF("BF_NodeZ_D1", BF_GradNode, 0, 1) ; } void BF_NodeZ_D1_2E(ARGS) { BF("BF_NodeZ_D1_2E", BF_GradNode_2E, 0, 1) ; } void BF_NodeZ_D1_2F(ARGS) { BF("BF_NodeZ_D1_2F", BF_GradNode_2F, 0, 1) ; } void BF_NodeZ_D1_2V(ARGS) { BF("BF_NodeZ_D1_2V", BF_GradNode_2V, 0, 1) ; } void BF_NodeZ_D1_3E(ARGS) { BF("BF_NodeZ_D1_3E", BF_GradNode_3E, 0, 1) ; } void BF_NodeZ_D1_3F(ARGS) { BF("BF_NodeZ_D1_3F", BF_GradNode_3F, 0, 1) ; } void BF_NodeZ_D1_3V(ARGS) { BF("BF_NodeZ_D1_3V", BF_GradNode_3V, 0, 1) ; } #undef BF /* ------------------------------------------------------------------------ */ #define BF(BF_NodeX_D2_, BF_GradNode_, idx1_, idx2_) \ double su[3] ; \ (BF_GradNode_)(Element, NumNode, u, v, w, su) ; \ ChangeOfCoord_Form1(Element, su, s) ; \ s[idx1_] = s[idx2_] ; s[idx2_] = 0 ; void BF_NodeX_D2(ARGS) { BF("BF_NodeX_D2", BF_GradNode, 0, 1) ; } void BF_NodeX_D2_2E(ARGS) { BF("BF_NodeX_D2_2E", BF_GradNode_2E, 0, 1) ; } void BF_NodeX_D2_2F(ARGS) { BF("BF_NodeX_D2_2F", BF_GradNode_2F, 0, 1) ; } void BF_NodeX_D2_2V(ARGS) { BF("BF_NodeX_D2_2V", BF_GradNode_2V, 0, 1) ; } void BF_NodeX_D2_3E(ARGS) { BF("BF_NodeX_D2_3E", BF_GradNode_3E, 0, 1) ; } void BF_NodeX_D2_3F(ARGS) { BF("BF_NodeX_D2_3F", BF_GradNode_3F, 0, 1) ; } void BF_NodeX_D2_3V(ARGS) { BF("BF_NodeX_D2_3V", BF_GradNode_3V, 0, 1) ; } void BF_NodeY_D2(ARGS) { BF("BF_NodeY_D2", BF_GradNode, 1, 2) ; } void BF_NodeY_D2_2E(ARGS) { BF("BF_NodeY_D2_2E", BF_GradNode_2E, 1, 2) ; } void BF_NodeY_D2_2F(ARGS) { BF("BF_NodeY_D2_2F", BF_GradNode_2F, 1, 2) ; } void BF_NodeY_D2_2V(ARGS) { BF("BF_NodeY_D2_2V", BF_GradNode_2V, 1, 2) ; } void BF_NodeY_D2_3E(ARGS) { BF("BF_NodeY_D2_3E", BF_GradNode_3E, 1, 2) ; } void BF_NodeY_D2_3F(ARGS) { BF("BF_NodeY_D2_3F", BF_GradNode_3F, 1, 2) ; } void BF_NodeY_D2_3V(ARGS) { BF("BF_NodeY_D2_3V", BF_GradNode_3V, 1, 2) ; } void BF_NodeZ_D2(ARGS) { BF("BF_NodeZ_D2", BF_GradNode, 2, 0) ; } void BF_NodeZ_D2_2E(ARGS) { BF("BF_NodeZ_D2_2E", BF_GradNode_2E, 2, 0) ; } void BF_NodeZ_D2_2F(ARGS) { BF("BF_NodeZ_D2_2F", BF_GradNode_2F, 2, 0) ; } void BF_NodeZ_D2_2V(ARGS) { BF("BF_NodeZ_D2_2V", BF_GradNode_2V, 2, 0) ; } void BF_NodeZ_D2_3E(ARGS) { BF("BF_NodeZ_D2_3E", BF_GradNode_3E, 2, 0) ; } void BF_NodeZ_D2_3F(ARGS) { BF("BF_NodeZ_D2_3F", BF_GradNode_3F, 2, 0) ; } void BF_NodeZ_D2_3V(ARGS) { BF("BF_NodeZ_D2_3V", BF_GradNode_3V, 2, 0) ; } #undef BF getdp-2.4.2-source/Legacy/Pos_Iso.h000644 001750 001750 00000000651 12116424202 020524 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _POS_ISO_H_ #define _POS_ISO_H_ #include "Pos_Element.h" #include "ListUtils.h" void Cal_Iso(struct PostElement *PE, List_T *list, double val, double vmin, double vmax, int DecomposeInSimplex) ; #endif getdp-2.4.2-source/Legacy/Cal_Value.cpp000644 001750 001750 00000250475 12205340470 021355 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Johan Gyselinck // #include #include #include #include "ProData.h" #include "ProDefine.h" #include "Cal_Value.h" #include "Message.h" extern struct CurrentData Current ; #define SQU(a) ((a)*(a)) /* ------------------------------------------------------------------------ */ /* O p e r a t o r s o n V a l u e s */ /* ------------------------------------------------------------------------ */ /* Warning: the pointers V1 and R or V2 and R can be identical. You must */ /* use temporary variables in your computations: you can only */ /* affect to R at the very last time (when you're sure you will */ /* not use V1 or V2 any more). */ /* ------------------------------------------------------------------------ */ static double a0; static double a1 [NBR_MAX_HARMONIC * MAX_DIM] ; static double a2 [NBR_MAX_HARMONIC * MAX_DIM] ; static double b1 [NBR_MAX_HARMONIC * MAX_DIM] ; static double b2 [NBR_MAX_HARMONIC * MAX_DIM] ; static double b3 [NBR_MAX_HARMONIC * MAX_DIM] ; static double c1 [NBR_MAX_HARMONIC * MAX_DIM] ; static double c2 [NBR_MAX_HARMONIC * MAX_DIM] ; static double c3 [NBR_MAX_HARMONIC * MAX_DIM] ; static double tmp[27][NBR_MAX_HARMONIC * MAX_DIM] ; static int TENSOR_SYM_MAP[] = {0,1,2,1,3,4,2,4,5}; static int TENSOR_DIAG_MAP[] = {0,-1,-1,-1,1,-1,-1,-1,2}; void Cal_ComplexProduct(double V1[], double V2[], double P[]) { P[0] = V1[0] * V2[0] - V1[MAX_DIM] * V2[MAX_DIM] ; P[MAX_DIM] = V1[0] * V2[MAX_DIM] + V1[MAX_DIM] * V2[0] ; } void Cal_ComplexDivision(double V1[], double V2[], double P[]) { double Mod2 ; Mod2 = SQU(V2[0]) + SQU(V2[MAX_DIM]) ; if(!Mod2){ Message::Error("Division by zero in 'Cal_ComplexDivision'"); return; } P[0] = ( V1[0] * V2[0] + V1[MAX_DIM] * V2[MAX_DIM]) / Mod2 ; P[MAX_DIM] = (- V1[0] * V2[MAX_DIM] + V1[MAX_DIM] * V2[0]) / Mod2 ; } void Cal_ComplexInvert(double V1[], double P[]) { double Mod2 ; Mod2 = SQU(V1[0]) + SQU(V1[MAX_DIM]) ; if(!Mod2){ Message::Error("Division by zero in 'Cal_ComplexInvert'"); return; } P[0] = V1[0] / Mod2 ; P[MAX_DIM] = - V1[MAX_DIM] / Mod2 ; } /* ------------------------------------------------------------------------ R <- V1 ------------------------------------------------------------------------ */ void Cal_CopyValue(struct Value * V1, struct Value * R) { int k ; if (V1->Type == SCALAR) { R->Type = SCALAR ; for (k = 0 ; k < Current.NbrHar ; k++) R->Val[MAX_DIM*k ] = V1->Val[MAX_DIM*k ] ; } else if (V1->Type == VECTOR || V1->Type == TENSOR_DIAG){ R->Type = V1->Type ; for (k = 0 ; k < Current.NbrHar ; k++) { R->Val[MAX_DIM*k ] = V1->Val[MAX_DIM*k ] ; R->Val[MAX_DIM*k+1] = V1->Val[MAX_DIM*k+1] ; R->Val[MAX_DIM*k+2] = V1->Val[MAX_DIM*k+2] ; } } else if (V1->Type == TENSOR_SYM){ R->Type = TENSOR_SYM ; for (k = 0 ; k < Current.NbrHar ; k++) { R->Val[MAX_DIM*k ] = V1->Val[MAX_DIM*k ] ; R->Val[MAX_DIM*k+1] = V1->Val[MAX_DIM*k+1] ; R->Val[MAX_DIM*k+2] = V1->Val[MAX_DIM*k+2] ; R->Val[MAX_DIM*k+3] = V1->Val[MAX_DIM*k+3] ; R->Val[MAX_DIM*k+4] = V1->Val[MAX_DIM*k+4] ; R->Val[MAX_DIM*k+5] = V1->Val[MAX_DIM*k+5] ; } } else if (V1->Type == TENSOR){ R->Type = TENSOR ; for (k = 0 ; k < Current.NbrHar ; k++) { R->Val[MAX_DIM*k ] = V1->Val[MAX_DIM*k ] ; R->Val[MAX_DIM*k+1] = V1->Val[MAX_DIM*k+1] ; R->Val[MAX_DIM*k+2] = V1->Val[MAX_DIM*k+2] ; R->Val[MAX_DIM*k+3] = V1->Val[MAX_DIM*k+3] ; R->Val[MAX_DIM*k+4] = V1->Val[MAX_DIM*k+4] ; R->Val[MAX_DIM*k+5] = V1->Val[MAX_DIM*k+5] ; R->Val[MAX_DIM*k+6] = V1->Val[MAX_DIM*k+6] ; R->Val[MAX_DIM*k+7] = V1->Val[MAX_DIM*k+7] ; R->Val[MAX_DIM*k+8] = V1->Val[MAX_DIM*k+8] ; } } } /* ------------------------------------------------------------------------ R <- V1 ------------------------------------------------------------------------ */ void Cal_CopyValueArray(struct Value *V1, struct Value *R, int Nbr_Values) { int k, i; if (V1[0].Type == SCALAR) { for (i = 0 ; i < Nbr_Values ; i++){ R[i].Type = SCALAR ; for (k = 0 ; k < Current.NbrHar ; k++) R[i].Val[MAX_DIM*k ] = V1[i].Val[MAX_DIM*k ] ; } } else if (V1[0].Type == VECTOR || V1[0].Type == TENSOR_DIAG){ for (i = 0 ; i < Nbr_Values ; i++){ R[i].Type = V1[i].Type ; for (k = 0 ; k < Current.NbrHar ; k++) { R[i].Val[MAX_DIM*k ] = V1[i].Val[MAX_DIM*k ] ; R[i].Val[MAX_DIM*k+1] = V1[i].Val[MAX_DIM*k+1] ; R[i].Val[MAX_DIM*k+2] = V1[i].Val[MAX_DIM*k+2] ; } } } else if (V1[0].Type == TENSOR_SYM){ for (i = 0 ; i < Nbr_Values ; i++){ R[i].Type = TENSOR_SYM ; for (k = 0 ; k < Current.NbrHar ; k++) { R[i].Val[MAX_DIM*k ] = V1[i].Val[MAX_DIM*k ] ; R[i].Val[MAX_DIM*k+1] = V1[i].Val[MAX_DIM*k+1] ; R[i].Val[MAX_DIM*k+2] = V1[i].Val[MAX_DIM*k+2] ; R[i].Val[MAX_DIM*k+3] = V1[i].Val[MAX_DIM*k+3] ; R[i].Val[MAX_DIM*k+4] = V1[i].Val[MAX_DIM*k+4] ; R[i].Val[MAX_DIM*k+5] = V1[i].Val[MAX_DIM*k+5] ; } } } else if (V1[0].Type == TENSOR){ for (i = 0 ; i < Nbr_Values ; i++){ R[i].Type = TENSOR ; for (k = 0 ; k < Current.NbrHar ; k++) { R[i].Val[MAX_DIM*k ] = V1[i].Val[MAX_DIM*k ] ; R[i].Val[MAX_DIM*k+1] = V1[i].Val[MAX_DIM*k+1] ; R[i].Val[MAX_DIM*k+2] = V1[i].Val[MAX_DIM*k+2] ; R[i].Val[MAX_DIM*k+3] = V1[i].Val[MAX_DIM*k+3] ; R[i].Val[MAX_DIM*k+4] = V1[i].Val[MAX_DIM*k+4] ; R[i].Val[MAX_DIM*k+5] = V1[i].Val[MAX_DIM*k+5] ; R[i].Val[MAX_DIM*k+6] = V1[i].Val[MAX_DIM*k+6] ; R[i].Val[MAX_DIM*k+7] = V1[i].Val[MAX_DIM*k+7] ; R[i].Val[MAX_DIM*k+8] = V1[i].Val[MAX_DIM*k+8] ; } } } } void Cal_ValueArray2DoubleArray(struct Value *V1, double *R, int Nbr_Values) { int k, i; if (V1[0].Type == SCALAR) { for (i = 0 ; i < Nbr_Values ; i++){ for (k = 0 ; k < Current.NbrHar ; k++) R[Current.NbrHar*i+k] = V1[i].Val[MAX_DIM*k ] ; } } else if (V1[0].Type == VECTOR){ for (i = 0 ; i < Nbr_Values ; i++){ for (k = 0 ; k < Current.NbrHar ; k++) { R[3*(Current.NbrHar*i+k) ] = V1[i].Val[MAX_DIM*k ] ; R[3*(Current.NbrHar*i+k)+1] = V1[i].Val[MAX_DIM*k+1] ; R[3*(Current.NbrHar*i+k)+2] = V1[i].Val[MAX_DIM*k+2] ; } } } else { Message::Error("Wrong type conversion: %s ", Get_StringForDefine(Field_Type, V1[0].Type)); } } void Cal_AddValueArray2DoubleArray(struct Value *V1, double *R, int Nbr_Values) { int k, i; if (V1[0].Type == SCALAR) { for (i = 0 ; i < Nbr_Values ; i++){ for (k = 0 ; k < Current.NbrHar ; k++){ R[Current.NbrHar*i+k] += V1[i].Val[MAX_DIM*k ] ; } } } else if (V1[0].Type == VECTOR){ for (i = 0 ; i < Nbr_Values ; i++){ for (k = 0 ; k < Current.NbrHar ; k++) { R[3*(Current.NbrHar*i+k) ] += V1[i].Val[MAX_DIM*k ] ; R[3*(Current.NbrHar*i+k)+1] += V1[i].Val[MAX_DIM*k+1] ; R[3*(Current.NbrHar*i+k)+2] += V1[i].Val[MAX_DIM*k+2] ; } } } else { Message::Error("Wrong type conversion: %s ", Get_StringForDefine(Field_Type, V1[0].Type)); } } /* ------------------------------------------------------------------------ R <- 0 ------------------------------------------------------------------------ */ static double VALUE_ZERO [NBR_MAX_HARMONIC * MAX_DIM] = {0.,0.,0., 0.,0.,0., 0.,0.,0., 0.,0.,0., 0.,0.,0., 0.,0.,0.} ; void Cal_ZeroValue(struct Value * R) { memcpy(R->Val, VALUE_ZERO, Current.NbrHar*MAX_DIM*sizeof(double)); } /* ------------------------------------------------------------------------ R <- V1 + V2 ------------------------------------------------------------------------ */ #define ADD(i) R->Val[i] = V1->Val[i] + V2->Val[i] #define CADD(i) R->Val[MAX_DIM*k+i] = V1->Val[MAX_DIM*k+i] + V2->Val[MAX_DIM*k+i] void Cal_AddValue(struct Value * V1, struct Value * V2, struct Value * R) { int i, k; int i1,i2; struct Value A; if (V1->Type == SCALAR && V2->Type == SCALAR) { if (Current.NbrHar == 1) { ADD(0); } else { for (k = 0 ; k < Current.NbrHar ; k++) { CADD(0); } } R->Type = SCALAR ; } else if ((V1->Type == VECTOR && V2->Type == VECTOR) || (V1->Type == TENSOR_DIAG && V2->Type == TENSOR_DIAG)) { if (Current.NbrHar == 1) { ADD(0); ADD(1); ADD(2); } else { for (k = 0 ; k < Current.NbrHar ; k++) { CADD(0); CADD(1); CADD(2); } } R->Type = V1->Type; } else if (V1->Type == TENSOR_SYM && V2->Type == TENSOR_SYM) { if (Current.NbrHar == 1) { ADD(0); ADD(1); ADD(2); ADD(3); ADD(4); ADD(5); } else { for (k = 0 ; k < Current.NbrHar ; k++) { CADD(0); CADD(1); CADD(2); CADD(3); CADD(4); CADD(5); } } R->Type = TENSOR_SYM; } else if (V1->Type == TENSOR && V2->Type == TENSOR) { if (Current.NbrHar == 1) { ADD(0); ADD(1); ADD(2); ADD(3); ADD(4); ADD(5); ADD(6); ADD(7); ADD(8); } else { for (k = 0 ; k < Current.NbrHar ; k++) { CADD(0); CADD(1); CADD(2); CADD(3); CADD(4); CADD(5); CADD(6); CADD(7); CADD(8); } } R->Type = TENSOR; } else if ((V1->Type == TENSOR && V2->Type == TENSOR_SYM) || (V1->Type == TENSOR && V2->Type == TENSOR_DIAG)|| (V1->Type == TENSOR_SYM && V2->Type == TENSOR_DIAG)){ A.Type = V1->Type; for (k = 0 ; k < Current.NbrHar ; k++) { for(i=0 ; i<9 ; i++){ i1 = (V1->Type==TENSOR)?i:TENSOR_SYM_MAP[i]; i2 = (V2->Type==TENSOR_SYM)?TENSOR_SYM_MAP[i]:TENSOR_DIAG_MAP[i]; A.Val[MAX_DIM*k+i1] = V1->Val[MAX_DIM*k+i1] + ((i2<0)?0.0:V2->Val[MAX_DIM*k+i2]); } } Cal_CopyValue(&A,R); } else if ((V1->Type == TENSOR_SYM && V2->Type == TENSOR) || (V1->Type == TENSOR_DIAG && V2->Type == TENSOR) || (V1->Type == TENSOR_DIAG && V2->Type == TENSOR_SYM)){ A.Type = V2->Type; for (k = 0 ; k < Current.NbrHar ; k++) { for(i=0 ; i<9 ; i++){ i1 = (V1->Type==TENSOR_SYM)?TENSOR_SYM_MAP[i]:TENSOR_DIAG_MAP[i]; i2 = (V2->Type==TENSOR)?i:TENSOR_SYM_MAP[i]; A.Val[MAX_DIM*k+i2] = ((i1<0)?0.0:V1->Val[MAX_DIM*k+i1]) + V2->Val[MAX_DIM*k+i2]; } } Cal_CopyValue(&A,R); } else { Message::Error("Addition of different quantities: %s + %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } } #undef ADD #undef CADD /* ------------------------------------------------------------------------ R <- V1 + V2 ------------------------------------------------------------------------ */ #define ADD(i,j) R[i].Val[j] = V1[i].Val[j] + V2[i].Val[j] #define CADD(i,j) R[i].Val[MAX_DIM*k+j] = V1[i].Val[MAX_DIM*k+j] + V2[i].Val[MAX_DIM*k+j] void Cal_AddValueArray (struct Value *V1, struct Value *V2, struct Value *R, int Nbr_Values) { int i, ii, k, i1,i2; struct Value A; if (V1[0].Type == SCALAR && V2[0].Type == SCALAR){ if (Current.NbrHar == 1) for(i = 0 ; i < Nbr_Values; i++){ R[i].Type = SCALAR ; ADD(i,0); } else for(i = 0 ; i < Nbr_Values; i++){ R[i].Type = SCALAR ; for (k = 0 ; k < Current.NbrHar ; k++) CADD(i,0); } } else if ((V1[0].Type == VECTOR && V2[0].Type == VECTOR) || (V1[0].Type == TENSOR_DIAG && V2[0].Type == TENSOR_DIAG)){ if (Current.NbrHar == 1) for(i = 0 ; i < Nbr_Values; i++){ R[i].Type = V1[i].Type; ADD(i,0); ADD(i,1); ADD(i,2); } else for(i = 0 ; i < Nbr_Values; i++){ R[i].Type = V1[i].Type; for (k = 0 ; k < Current.NbrHar ; k++) { CADD(i,0); CADD(i,1); CADD(i,2); } } } else if (V1[0].Type == TENSOR_SYM && V2[0].Type == TENSOR_SYM){ if (Current.NbrHar == 1) for(i = 0 ; i < Nbr_Values; i++){ R[i].Type = TENSOR_SYM; ADD(i,0); ADD(i,1); ADD(i,2); ADD(i,3); ADD(i,4); ADD(i,5); } else for(i = 0 ; i < Nbr_Values; i++){ R[i].Type = TENSOR_SYM; for (k = 0 ; k < Current.NbrHar ; k++) { CADD(i,0); CADD(i,1); CADD(i,2); CADD(i,3); CADD(i,4); CADD(i,5); } } } else if (V1[0].Type == TENSOR && V2[0].Type == TENSOR){ if (Current.NbrHar == 1) for(i = 0 ; i < Nbr_Values; i++){ R[i].Type = TENSOR; ADD(i,0); ADD(i,1); ADD(i,2); ADD(i,3); ADD(i,4); ADD(i,5); ADD(i,6); ADD(i,7); ADD(i,8); } else for(i = 0 ; i < Nbr_Values; i++){ R[i].Type = TENSOR; for (k = 0 ; k < Current.NbrHar ; k++) { CADD(i,0); CADD(i,1); CADD(i,2); CADD(i,3); CADD(i,4); CADD(i,5); CADD(i,6); CADD(i,7); CADD(i,8); } } } else if ((V1[0].Type == TENSOR && V2[0].Type == TENSOR_SYM) || (V1[0].Type == TENSOR && V2[0].Type == TENSOR_DIAG)|| (V1[0].Type == TENSOR_SYM && V2[0].Type == TENSOR_DIAG)){ A.Type = V1[0].Type; for(i = 0 ; i < Nbr_Values; i++){ for (k = 0 ; k < Current.NbrHar ; k++) { for(ii=0 ; ii<9 ; ii++){ i1 = (V1[0].Type==TENSOR)?ii:TENSOR_SYM_MAP[ii]; i2 = (V2[0].Type==TENSOR_SYM)?TENSOR_SYM_MAP[ii]:TENSOR_DIAG_MAP[ii]; A.Val[MAX_DIM*k+i1] = V1[i].Val[MAX_DIM*k+i1] + ((i2<0)?0.0:V2[i].Val[MAX_DIM*k+i2]); } } Cal_CopyValue(&A,&R[i]); } } else if ((V1[0].Type == TENSOR_SYM && V2[0].Type == TENSOR) || (V1[0].Type == TENSOR_DIAG && V2[0].Type == TENSOR) || (V1[0].Type == TENSOR_DIAG && V2[0].Type == TENSOR_SYM)){ A.Type = V2[0].Type; for(i = 0 ; i < Nbr_Values; i++){ for (k = 0 ; k < Current.NbrHar ; k++) { for(ii=0 ; ii<9 ; ii++){ i1 = (V1[i].Type==TENSOR_SYM)?TENSOR_SYM_MAP[ii]:TENSOR_DIAG_MAP[ii]; i2 = (V2[i].Type==TENSOR)?ii:TENSOR_SYM_MAP[ii]; A.Val[MAX_DIM*k+i2] = ((i1<0)?0.0:V1[i].Val[MAX_DIM*k+i1]) + V2[i].Val[MAX_DIM*k+i2]; } } Cal_CopyValue(&A,&R[i]); } } else Message::Error("Addition of different quantities: %s + %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } #undef ADD #undef CADD /* ------------------------------------------------------------------------ R <- V1 * d , where d is a double ------------------------------------------------------------------------ */ void Cal_MultValue(struct Value * V1, double d, struct Value * R) { int k; R->Type = V1->Type ; switch(V1->Type){ case SCALAR : if (Current.NbrHar == 1) { R->Val[0] = V1->Val[0] * d; } else{ for (k = 0 ; k < Current.NbrHar ; k++) { R->Val[MAX_DIM*k] = V1->Val[MAX_DIM*k] * d; } } break; case VECTOR : case TENSOR_DIAG : if (Current.NbrHar == 1) { R->Val[0] = V1->Val[0] * d; R->Val[1] = V1->Val[1] * d; R->Val[2] = V1->Val[2] * d; } else{ for (k = 0 ; k < Current.NbrHar ; k++) { R->Val[MAX_DIM*k ] = V1->Val[MAX_DIM*k ] * d; R->Val[MAX_DIM*k+1] = V1->Val[MAX_DIM*k+1] * d; R->Val[MAX_DIM*k+2] = V1->Val[MAX_DIM*k+2] * d; } } break; case TENSOR_SYM : if (Current.NbrHar == 1) { R->Val[0] = V1->Val[0] * d; R->Val[1] = V1->Val[1] * d; R->Val[2] = V1->Val[2] * d; R->Val[3] = V1->Val[3] * d; R->Val[4] = V1->Val[4] * d; R->Val[5] = V1->Val[5] * d; } else{ for (k = 0 ; k < Current.NbrHar ; k++) { R->Val[MAX_DIM*k ] = V1->Val[MAX_DIM*k ] * d; R->Val[MAX_DIM*k+1] = V1->Val[MAX_DIM*k+1] * d; R->Val[MAX_DIM*k+2] = V1->Val[MAX_DIM*k+2] * d; R->Val[MAX_DIM*k+3] = V1->Val[MAX_DIM*k+3] * d; R->Val[MAX_DIM*k+4] = V1->Val[MAX_DIM*k+4] * d; R->Val[MAX_DIM*k+5] = V1->Val[MAX_DIM*k+5] * d; } } break; case TENSOR : if (Current.NbrHar == 1) { R->Val[0] = V1->Val[0] * d; R->Val[1] = V1->Val[1] * d; R->Val[2] = V1->Val[2] * d; R->Val[3] = V1->Val[3] * d; R->Val[4] = V1->Val[4] * d; R->Val[5] = V1->Val[5] * d; R->Val[6] = V1->Val[6] * d; R->Val[7] = V1->Val[7] * d; R->Val[8] = V1->Val[8] * d; } else{ for (k = 0 ; k < Current.NbrHar ; k++) { R->Val[MAX_DIM*k ] = V1->Val[MAX_DIM*k ] * d; R->Val[MAX_DIM*k+1] = V1->Val[MAX_DIM*k+1] * d; R->Val[MAX_DIM*k+2] = V1->Val[MAX_DIM*k+2] * d; R->Val[MAX_DIM*k+3] = V1->Val[MAX_DIM*k+3] * d; R->Val[MAX_DIM*k+4] = V1->Val[MAX_DIM*k+4] * d; R->Val[MAX_DIM*k+5] = V1->Val[MAX_DIM*k+5] * d; R->Val[MAX_DIM*k+6] = V1->Val[MAX_DIM*k+6] * d; R->Val[MAX_DIM*k+7] = V1->Val[MAX_DIM*k+7] * d; R->Val[MAX_DIM*k+8] = V1->Val[MAX_DIM*k+8] * d; } } break; default : Message::Error("Wrong argument type for 'Cal_MultValue'"); break; } } /* ------------------------------------------------------------------------ R <- V1 + V2 * d , where d is a double ------------------------------------------------------------------------ */ void Cal_AddMultValue(struct Value * V1, struct Value * V2, double d, struct Value * R) { int k; struct Value A ; A.Type = V2->Type ; switch(V2->Type){ case SCALAR : if (Current.NbrHar == 1) { A.Val[0] = V2->Val[0] * d; } else{ for (k = 0 ; k < Current.NbrHar ; k++) { A.Val[MAX_DIM*k] = V2->Val[MAX_DIM*k] * d; } } break; case VECTOR : case TENSOR_DIAG : if (Current.NbrHar == 1) { A.Val[0] = V2->Val[0] * d; A.Val[1] = V2->Val[1] * d; A.Val[2] = V2->Val[2] * d; } else{ for (k = 0 ; k < Current.NbrHar ; k++) { A.Val[MAX_DIM*k ] = V2->Val[MAX_DIM*k ] * d; A.Val[MAX_DIM*k+1] = V2->Val[MAX_DIM*k+1] * d; A.Val[MAX_DIM*k+2] = V2->Val[MAX_DIM*k+2] * d; } } break; case TENSOR_SYM : if (Current.NbrHar == 1) { A.Val[0] = V2->Val[0] * d; A.Val[1] = V2->Val[1] * d; A.Val[2] = V2->Val[2] * d; A.Val[3] = V2->Val[3] * d; A.Val[4] = V2->Val[4] * d; A.Val[5] = V2->Val[5] * d; } else{ for (k = 0 ; k < Current.NbrHar ; k++) { A.Val[MAX_DIM*k ] = V2->Val[MAX_DIM*k ] * d; A.Val[MAX_DIM*k+1] = V2->Val[MAX_DIM*k+1] * d; A.Val[MAX_DIM*k+2] = V2->Val[MAX_DIM*k+2] * d; A.Val[MAX_DIM*k+3] = V2->Val[MAX_DIM*k+3] * d; A.Val[MAX_DIM*k+4] = V2->Val[MAX_DIM*k+4] * d; A.Val[MAX_DIM*k+5] = V2->Val[MAX_DIM*k+5] * d; } } break; case TENSOR : if (Current.NbrHar == 1) { A.Val[0] = V2->Val[0] * d; A.Val[1] = V2->Val[1] * d; A.Val[2] = V2->Val[2] * d; A.Val[3] = V2->Val[3] * d; A.Val[4] = V2->Val[4] * d; A.Val[5] = V2->Val[5] * d; A.Val[6] = V2->Val[6] * d; A.Val[7] = V2->Val[7] * d; A.Val[8] = V2->Val[8] * d; } else{ for (k = 0 ; k < Current.NbrHar ; k++) { A.Val[MAX_DIM*k ] = V2->Val[MAX_DIM*k ] * d; A.Val[MAX_DIM*k+1] = V2->Val[MAX_DIM*k+1] * d; A.Val[MAX_DIM*k+2] = V2->Val[MAX_DIM*k+2] * d; A.Val[MAX_DIM*k+3] = V2->Val[MAX_DIM*k+3] * d; A.Val[MAX_DIM*k+4] = V2->Val[MAX_DIM*k+4] * d; A.Val[MAX_DIM*k+5] = V2->Val[MAX_DIM*k+5] * d; A.Val[MAX_DIM*k+6] = V2->Val[MAX_DIM*k+6] * d; A.Val[MAX_DIM*k+7] = V2->Val[MAX_DIM*k+7] * d; A.Val[MAX_DIM*k+8] = V2->Val[MAX_DIM*k+8] * d; } } break; default : Message::Error("Wrong argument type for 'Cal_AddMultValue'"); return; } Cal_AddValue(V1,&A,R); } /* ------------------------------------------------------------------------ R <- V1 + V2 * d , where d is a double ------------------------------------------------------------------------ */ void Cal_AddMultValueArray(struct Value * V1, struct Value * V2, double d, struct Value * R,int Nbr_Values) { int k,i; switch(V2[0].Type){ case SCALAR : if (Current.NbrHar == 1) { for(i = 0 ; i < Nbr_Values ; i++) V2[i].Val[0] = V2[i].Val[0] * d; } else{ for (k = 0 ; k < Current.NbrHar ; k++) { for(i = 0 ; i < Nbr_Values ; i++) V2[i].Val[MAX_DIM*k] = V2[i].Val[MAX_DIM*k] * d; } } break; case VECTOR : case TENSOR_DIAG : if (Current.NbrHar == 1) { for(i = 0 ; i < Nbr_Values ; i++){ V2[i].Val[0] = V2[i].Val[0] * d; V2[i].Val[1] = V2[i].Val[1] * d; V2[i].Val[2] = V2[i].Val[2] * d; } } else{ for (k = 0 ; k < Current.NbrHar ; k++) { for(i = 0 ; i < Nbr_Values ; i++){ V2[i].Val[MAX_DIM*k ] = V2[i].Val[MAX_DIM*k ] * d; V2[i].Val[MAX_DIM*k+1] = V2[i].Val[MAX_DIM*k+1] * d; V2[i].Val[MAX_DIM*k+2] = V2[i].Val[MAX_DIM*k+2] * d; } } } break; case TENSOR_SYM : if (Current.NbrHar == 1) { for(i = 0 ; i < Nbr_Values ; i++){ V2[i].Val[0] = V2[i].Val[0] * d; V2[i].Val[1] = V2[i].Val[1] * d; V2[i].Val[2] = V2[i].Val[2] * d; V2[i].Val[3] = V2[i].Val[3] * d; V2[i].Val[4] = V2[i].Val[4] * d; V2[i].Val[5] = V2[i].Val[5] * d; } } else{ for (k = 0 ; k < Current.NbrHar ; k++) { for(i = 0 ; i < Nbr_Values ; i++){ V2[i].Val[MAX_DIM*k ] = V2[i].Val[MAX_DIM*k ] * d; V2[i].Val[MAX_DIM*k+1] = V2[i].Val[MAX_DIM*k+1] * d; V2[i].Val[MAX_DIM*k+2] = V2[i].Val[MAX_DIM*k+2] * d; V2[i].Val[MAX_DIM*k+3] = V2[i].Val[MAX_DIM*k+3] * d; V2[i].Val[MAX_DIM*k+4] = V2[i].Val[MAX_DIM*k+4] * d; V2[i].Val[MAX_DIM*k+5] = V2[i].Val[MAX_DIM*k+5] * d; } } } break; case TENSOR : if (Current.NbrHar == 1) { for(i = 0 ; i < Nbr_Values ; i++){ V2[i].Val[0] = V2[i].Val[0] * d; V2[i].Val[1] = V2[i].Val[1] * d; V2[i].Val[2] = V2[i].Val[2] * d; V2[i].Val[3] = V2[i].Val[3] * d; V2[i].Val[4] = V2[i].Val[4] * d; V2[i].Val[5] = V2[i].Val[5] * d; V2[i].Val[6] = V2[i].Val[6] * d; V2[i].Val[7] = V2[i].Val[7] * d; V2[i].Val[8] = V2[i].Val[8] * d; } } else{ for (k = 0 ; k < Current.NbrHar ; k++) { for(i = 0 ; i < Nbr_Values ; i++){ V2[i].Val[MAX_DIM*k ] = V2[i].Val[MAX_DIM*k ] * d; V2[i].Val[MAX_DIM*k+1] = V2[i].Val[MAX_DIM*k+1] * d; V2[i].Val[MAX_DIM*k+2] = V2[i].Val[MAX_DIM*k+2] * d; V2[i].Val[MAX_DIM*k+3] = V2[i].Val[MAX_DIM*k+3] * d; V2[i].Val[MAX_DIM*k+4] = V2[i].Val[MAX_DIM*k+4] * d; V2[i].Val[MAX_DIM*k+5] = V2[i].Val[MAX_DIM*k+5] * d; V2[i].Val[MAX_DIM*k+6] = V2[i].Val[MAX_DIM*k+6] * d; V2[i].Val[MAX_DIM*k+7] = V2[i].Val[MAX_DIM*k+7] * d; V2[i].Val[MAX_DIM*k+8] = V2[i].Val[MAX_DIM*k+8] * d; } } } break; default : Message::Error("Wrong argument type for 'Cal_AddMultValueArray'"); return; } Cal_AddValueArray(V1, V2, R,Nbr_Values); } /* ------------------------------------------------------------------------ V1 <- V1 * d1 + V2 * d2 , where d1, d2 are doubles ------------------------------------------------------------------------ */ void Cal_AddMultValue2(struct Value * V1, double d1, struct Value * V2, double d2) { int k; switch(V1->Type){ case SCALAR : if (Current.NbrHar == 1) { V1->Val[0] = V1->Val[0] * d1 + V2->Val[0] * d2; } else{ for (k = 0 ; k < Current.NbrHar ; k++) { V1->Val[MAX_DIM*k] = V1->Val[MAX_DIM*k] * d1 + V2->Val[MAX_DIM*k] * d2; } } break; case VECTOR : case TENSOR_DIAG : if (Current.NbrHar == 1) { V1->Val[0] = V1->Val[0] * d1 + V2->Val[0] * d2; V1->Val[1] = V1->Val[1] * d1 + V2->Val[1] * d2; V1->Val[2] = V1->Val[2] * d1 + V2->Val[2] * d2; } else{ for (k = 0 ; k < Current.NbrHar ; k++) { V1->Val[MAX_DIM*k ] = V1->Val[MAX_DIM*k ] * d1 + V2->Val[MAX_DIM*k ] * d2; V1->Val[MAX_DIM*k+1] = V1->Val[MAX_DIM*k+1] * d1 + V2->Val[MAX_DIM*k+1] * d2; V1->Val[MAX_DIM*k+2] = V1->Val[MAX_DIM*k+2] * d1 + V2->Val[MAX_DIM*k+2] * d2; } } break; default : Message::Error("Wrong argument type for 'Cal_AddMultValue2'"); break; } } /* ------------------------------------------------------------------------ R <- V1 - V2 ------------------------------------------------------------------------ */ #define SUB(i) R->Val[i] = V1->Val[i] - V2->Val[i] #define CSUB(i) R->Val[MAX_DIM*k+i] = V1->Val[MAX_DIM*k+i] - V2->Val[MAX_DIM*k+i] void Cal_SubstractValue(struct Value * V1, struct Value * V2, struct Value * R) { int i, k; int i1, i2; struct Value A; if (V1->Type == SCALAR && V2->Type == SCALAR) { if (Current.NbrHar == 1) { SUB(0); } else { for (k = 0 ; k < Current.NbrHar ; k++) { CSUB(0); } } R->Type = SCALAR ; } else if ((V1->Type == VECTOR && V2->Type == VECTOR) || (V1->Type == TENSOR_DIAG && V2->Type == TENSOR_DIAG)) { if (Current.NbrHar == 1) { SUB(0); SUB(1); SUB(2); } else { for (k = 0 ; k < Current.NbrHar ; k++) { CSUB(0); CSUB(1); CSUB(2); } } R->Type = V1->Type ; } else if (V1->Type == TENSOR_SYM && V2->Type == TENSOR_SYM) { if (Current.NbrHar == 1) { SUB(0); SUB(1); SUB(2); SUB(3); SUB(4); SUB(5); } else { for (k = 0 ; k < Current.NbrHar ; k++) { CSUB(0); CSUB(1); CSUB(2); CSUB(3); CSUB(4); CSUB(5); } } R->Type = TENSOR_SYM; } else if (V1->Type == TENSOR && V2->Type == TENSOR) { if (Current.NbrHar == 1) { SUB(0); SUB(1); SUB(2); SUB(3); SUB(4); SUB(5); SUB(6); SUB(7); SUB(8); } else { for (k = 0 ; k < Current.NbrHar ; k++) { CSUB(0); CSUB(1); CSUB(2); CSUB(3); CSUB(4); CSUB(5); CSUB(6); CSUB(7); CSUB(8); } } R->Type = TENSOR; } else if ((V1->Type == TENSOR && V2->Type == TENSOR_SYM) || (V1->Type == TENSOR && V2->Type == TENSOR_DIAG)|| (V1->Type == TENSOR_SYM && V2->Type == TENSOR_DIAG)){ A.Type = V1->Type; for (k = 0 ; k < Current.NbrHar ; k++) { for(i=0 ; i<9 ; i++){ i1 = (V1->Type==TENSOR)?i:TENSOR_SYM_MAP[i]; i2 = (V2->Type==TENSOR_SYM)?TENSOR_SYM_MAP[i]:TENSOR_DIAG_MAP[i]; A.Val[MAX_DIM*k+i1] = V1->Val[MAX_DIM*k+i1] - ((i2<0)?0.0:V2->Val[MAX_DIM*k+i2]); } } Cal_CopyValue(&A,R); } else if ((V1->Type == TENSOR_SYM && V2->Type == TENSOR) || (V1->Type == TENSOR_DIAG && V2->Type == TENSOR) || (V1->Type == TENSOR_DIAG && V2->Type == TENSOR_SYM)){ A.Type = V2->Type; for (k = 0 ; k < Current.NbrHar ; k++) { for(i=0 ; i<9 ; i++){ i1 = (V1->Type==TENSOR_SYM)?TENSOR_SYM_MAP[i]:TENSOR_DIAG_MAP[i]; i2 = (V2->Type==TENSOR)?i:TENSOR_SYM_MAP[i]; A.Val[MAX_DIM*k+i2] = ((i1<0)?0.0:V1->Val[MAX_DIM*k+i1]) - V2->Val[MAX_DIM*k+i2]; } } Cal_CopyValue(&A,R); } else { Message::Error("Substraction of different quantities: %s - %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } } #undef SUB #undef CSUB /* ------------------------------------------------------------------------ R <- V1 * V2 ------------------------------------------------------------------------ */ #define CMULT(a,b,c) \ Cal_ComplexProduct(&(V1->Val[MAX_DIM*k+a]), &(V2->Val[MAX_DIM*k+b]), tmp[c]) #define CPUT(a) \ R->Val[MAX_DIM* k +a] = tmp[a][0] ; \ R->Val[MAX_DIM*(k+1)+a] = tmp[a][MAX_DIM] #define CPUT3(a,b,c,d) \ R->Val[MAX_DIM* k +d] = tmp[a][0] +tmp[b][0] +tmp[c][0] ; \ R->Val[MAX_DIM*(k+1)+d] = tmp[a][MAX_DIM]+tmp[b][MAX_DIM]+tmp[c][MAX_DIM] void Cal_ProductValue(struct Value * V1, struct Value * V2, struct Value * R) { int k; if (V1->Type == SCALAR && V2->Type == SCALAR) { if (Current.NbrHar == 1) { R->Val[0] = V1->Val[0]*V2->Val[0]; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CMULT(0,0,0); CPUT(0); } } R->Type = SCALAR ; } else if (V1->Type == SCALAR && (V2->Type == VECTOR || V2->Type == TENSOR_DIAG)) { if (Current.NbrHar == 1) { a0 = V1->Val[0] ; R->Val[0] = a0 * V2->Val[0] ; R->Val[1] = a0 * V2->Val[1] ; R->Val[2] = a0 * V2->Val[2] ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CMULT(0,0,0); CMULT(0,1,1); CMULT(0,2,2); CPUT(0); CPUT(1); CPUT(2); } } R->Type = V2->Type ; } else if (V1->Type == SCALAR && V2->Type == TENSOR_SYM) { if (Current.NbrHar == 1) { a0 = V1->Val[0] ; R->Val[0] = a0 * V2->Val[0] ; R->Val[1] = a0 * V2->Val[1] ; R->Val[2] = a0 * V2->Val[2] ; R->Val[3] = a0 * V2->Val[3] ; R->Val[4] = a0 * V2->Val[4] ; R->Val[5] = a0 * V2->Val[5] ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CMULT(0,0,0); CMULT(0,1,1); CMULT(0,2,2); CMULT(0,3,3); CMULT(0,4,4); CMULT(0,5,5); CPUT(0); CPUT(1); CPUT(2); CPUT(3); CPUT(4); CPUT(5); } } R->Type = TENSOR_SYM ; } else if (V1->Type == SCALAR && V2->Type == TENSOR) { if (Current.NbrHar == 1) { a0 = V1->Val[0] ; R->Val[0] = a0 * V2->Val[0] ; R->Val[1] = a0 * V2->Val[1] ; R->Val[2] = a0 * V2->Val[2] ; R->Val[3] = a0 * V2->Val[3] ; R->Val[4] = a0 * V2->Val[4] ; R->Val[5] = a0 * V2->Val[5] ; R->Val[6] = a0 * V2->Val[6] ; R->Val[7] = a0 * V2->Val[7] ; R->Val[8] = a0 * V2->Val[8] ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CMULT(0,0,0); CMULT(0,1,1); CMULT(0,2,2); CMULT(0,3,3); CMULT(0,4,4); CMULT(0,5,5); CMULT(0,6,6); CMULT(0,7,7); CMULT(0,8,8); CPUT(0); CPUT(1); CPUT(2); CPUT(3); CPUT(4); CPUT(5); CPUT(6); CPUT(7); CPUT(8); } } R->Type = TENSOR ; } else if ((V1->Type == VECTOR || V1->Type == TENSOR_DIAG) && V2->Type == SCALAR) { if (Current.NbrHar == 1) { a0 = V2->Val[0] ; R->Val[0] = V1->Val[0] * a0 ; R->Val[1] = V1->Val[1] * a0 ; R->Val[2] = V1->Val[2] * a0 ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CMULT(0,0,0); CMULT(1,0,1); CMULT(2,0,2); CPUT(0); CPUT(1); CPUT(2); } } R->Type = V1->Type ; } else if (V1->Type == TENSOR_SYM && V2->Type == SCALAR) { if (Current.NbrHar == 1) { a0 = V2->Val[0] ; R->Val[0] = V1->Val[0] * a0 ; R->Val[1] = V1->Val[1] * a0 ; R->Val[2] = V1->Val[2] * a0 ; R->Val[3] = V1->Val[3] * a0 ; R->Val[4] = V1->Val[4] * a0 ; R->Val[5] = V1->Val[5] * a0 ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CMULT(0,0,0); CMULT(1,0,1); CMULT(2,0,2); CMULT(3,0,3); CMULT(4,0,4); CMULT(5,0,5); CPUT(0); CPUT(1); CPUT(2); CPUT(3); CPUT(4); CPUT(5); } } R->Type = TENSOR_SYM ; } else if (V1->Type == TENSOR && V2->Type == SCALAR) { if (Current.NbrHar == 1) { a0 = V2->Val[0] ; R->Val[0] = V1->Val[0] * a0 ; R->Val[1] = V1->Val[1] * a0 ; R->Val[2] = V1->Val[2] * a0 ; R->Val[3] = V1->Val[3] * a0 ; R->Val[4] = V1->Val[4] * a0 ; R->Val[5] = V1->Val[5] * a0 ; R->Val[6] = V1->Val[6] * a0 ; R->Val[7] = V1->Val[7] * a0 ; R->Val[8] = V1->Val[8] * a0 ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CMULT(0,0,0); CMULT(1,0,1); CMULT(2,0,2); CMULT(3,0,3); CMULT(4,0,4); CMULT(5,0,5); CMULT(6,0,6); CMULT(7,0,7); CMULT(8,0,8); CPUT(0); CPUT(1); CPUT(2); CPUT(3); CPUT(4); CPUT(5); CPUT(6); CPUT(7); CPUT(8); } } R->Type = TENSOR ; } /* Scalar Product. See 'Cal_CrossProductValue' for the Vector Product */ else if (V1->Type == VECTOR && V2->Type == VECTOR) { if (Current.NbrHar == 1) { R->Val[0] = V1->Val[0] * V2->Val[0] + V1->Val[1] * V2->Val[1] + V1->Val[2] * V2->Val[2] ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CMULT(0,0,0); CMULT(1,1,1); CMULT(2,2,2); CPUT3(0,1,2,0); } } R->Type = SCALAR ; } else if ( (V1->Type == TENSOR_DIAG && V2->Type == VECTOR) || (V2->Type == TENSOR_DIAG && V1->Type == VECTOR) ) { /* WARNING WARNING! */ if (Current.NbrHar == 1) { R->Val[0] = V1->Val[0]*V2->Val[0]; R->Val[1] = V1->Val[1]*V2->Val[1]; R->Val[2] = V1->Val[2]*V2->Val[2]; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CMULT(0,0,0); CMULT(1,1,1); CMULT(2,2,2); CPUT(0); CPUT(1); CPUT(2); } } R->Type = VECTOR ; } else if (V1->Type == TENSOR_SYM && V2->Type == VECTOR) { if (Current.NbrHar == 1) { a1[0] = V1->Val[0]*V2->Val[0] + V1->Val[1]*V2->Val[1] + V1->Val[2]*V2->Val[2]; a1[1] = V1->Val[1]*V2->Val[0] + V1->Val[3]*V2->Val[1] + V1->Val[4]*V2->Val[2]; a1[2] = V1->Val[2]*V2->Val[0] + V1->Val[4]*V2->Val[1] + V1->Val[5]*V2->Val[2]; R->Val[0] = a1[0]; R->Val[1] = a1[1]; R->Val[2] = a1[2]; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CMULT(0,0,0); CMULT(1,1,1); CMULT(2,2,2); CMULT(1,0,3); CMULT(3,1,4); CMULT(4,2,5); CMULT(2,0,6); CMULT(4,1,7); CMULT(5,2,8); CPUT3(0,1,2,0); CPUT3(3,4,5,1); CPUT3(6,7,8,2); } } R->Type = VECTOR ; } else if (V1->Type == TENSOR && V2->Type == VECTOR) { if (Current.NbrHar == 1) { a1[0] = V1->Val[0]*V2->Val[0] + V1->Val[1]*V2->Val[1] + V1->Val[2]*V2->Val[2]; a1[1] = V1->Val[3]*V2->Val[0] + V1->Val[4]*V2->Val[1] + V1->Val[5]*V2->Val[2]; a1[2] = V1->Val[6]*V2->Val[0] + V1->Val[7]*V2->Val[1] + V1->Val[8]*V2->Val[2]; R->Val[0] = a1[0]; R->Val[1] = a1[1]; R->Val[2] = a1[2]; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CMULT(0,0,0); CMULT(1,1,1); CMULT(2,2,2); CMULT(3,0,3); CMULT(4,1,4); CMULT(5,2,5); CMULT(6,0,6); CMULT(7,1,7); CMULT(8,2,8); CPUT3(0,1,2,0); CPUT3(3,4,5,1); CPUT3(6,7,8,2); } } R->Type = VECTOR ; } else if (V1->Type == TENSOR_DIAG && V2->Type == TENSOR_DIAG) { if (Current.NbrHar == 1) { R->Val[0] = V1->Val[0]*V2->Val[0]; R->Val[1] = V1->Val[1]*V2->Val[1]; R->Val[2] = V1->Val[2]*V2->Val[2]; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CMULT(0,0,0); CMULT(1,1,1); CMULT(2,2,2); CPUT(0); CPUT(1); CPUT(2); } } R->Type = TENSOR_DIAG; } else if (V1->Type == TENSOR_SYM && V2->Type == TENSOR_SYM) { if (Current.NbrHar == 1) { a1[0] = V1->Val[0]*V2->Val[0] + V1->Val[1]*V2->Val[1] + V1->Val[2]*V2->Val[2]; a1[1] = V1->Val[0]*V2->Val[1] + V1->Val[1]*V2->Val[2] + V1->Val[2]*V2->Val[4]; a1[2] = V1->Val[0]*V2->Val[2] + V1->Val[1]*V2->Val[4] + V1->Val[2]*V2->Val[5]; a1[3] = V1->Val[1]*V2->Val[0] + V1->Val[3]*V2->Val[1] + V1->Val[4]*V2->Val[2]; a1[4] = V1->Val[1]*V2->Val[1] + V1->Val[3]*V2->Val[3] + V1->Val[4]*V2->Val[4]; a1[5] = V1->Val[1]*V2->Val[2] + V1->Val[3]*V2->Val[4] + V1->Val[4]*V2->Val[5]; a1[6] = V1->Val[2]*V2->Val[0] + V1->Val[4]*V2->Val[1] + V1->Val[5]*V2->Val[2]; a1[7] = V1->Val[2]*V2->Val[1] + V1->Val[4]*V2->Val[3] + V1->Val[5]*V2->Val[4]; a1[8] = V1->Val[2]*V2->Val[2] + V1->Val[4]*V2->Val[4] + V1->Val[5]*V2->Val[5]; R->Val[0] = a1[0]; R->Val[1] = a1[1]; R->Val[2] = a1[2]; R->Val[3] = a1[3]; R->Val[4] = a1[4]; R->Val[5] = a1[5]; R->Val[6] = a1[6]; R->Val[7] = a1[7]; R->Val[8] = a1[8]; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CMULT(0,0,0); CMULT(1,1,1); CMULT(2,2,2); CMULT(0,1,3); CMULT(1,2,4); CMULT(2,4,5); CMULT(0,2,6); CMULT(1,4,7); CMULT(2,5,8); CMULT(1,0,9); CMULT(3,1,10); CMULT(4,2,11); CMULT(1,1,12); CMULT(3,3,13); CMULT(4,4,14); CMULT(1,2,15); CMULT(3,4,16); CMULT(4,5,17); CMULT(2,0,18); CMULT(4,1,19); CMULT(5,2,20); CMULT(2,1,21); CMULT(4,3,22); CMULT(5,4,23); CMULT(2,2,24); CMULT(4,4,25); CMULT(5,5,26); CPUT3(0,1,2,0); CPUT3(3,4,5,1); CPUT3(6,7,8,2); CPUT3(9,10,11,3); CPUT3(12,13,14,4); CPUT3(15,16,17,5); CPUT3(18,19,20,6); CPUT3(21,22,23,7); CPUT3(24,25,26,8); } } R->Type = TENSOR; } else if (V1->Type == TENSOR && V2->Type == TENSOR) { if (Current.NbrHar == 1) { a1[0] = V1->Val[0]*V2->Val[0] + V1->Val[1]*V2->Val[3] + V1->Val[2]*V2->Val[6]; a1[1] = V1->Val[0]*V2->Val[1] + V1->Val[1]*V2->Val[4] + V1->Val[2]*V2->Val[7]; a1[2] = V1->Val[0]*V2->Val[2] + V1->Val[1]*V2->Val[5] + V1->Val[2]*V2->Val[8]; a1[3] = V1->Val[3]*V2->Val[0] + V1->Val[4]*V2->Val[3] + V1->Val[5]*V2->Val[6]; a1[4] = V1->Val[3]*V2->Val[1] + V1->Val[4]*V2->Val[4] + V1->Val[5]*V2->Val[7]; a1[5] = V1->Val[3]*V2->Val[2] + V1->Val[4]*V2->Val[5] + V1->Val[5]*V2->Val[8]; a1[6] = V1->Val[6]*V2->Val[0] + V1->Val[7]*V2->Val[3] + V1->Val[8]*V2->Val[6]; a1[7] = V1->Val[6]*V2->Val[1] + V1->Val[7]*V2->Val[4] + V1->Val[8]*V2->Val[7]; a1[8] = V1->Val[6]*V2->Val[2] + V1->Val[7]*V2->Val[5] + V1->Val[8]*V2->Val[8]; R->Val[0] = a1[0]; R->Val[1] = a1[1]; R->Val[2] = a1[2]; R->Val[3] = a1[3]; R->Val[4] = a1[4]; R->Val[5] = a1[5]; R->Val[6] = a1[6]; R->Val[7] = a1[7]; R->Val[8] = a1[8]; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CMULT(0,0,0); CMULT(1,3,1); CMULT(2,6,2); CMULT(0,1,3); CMULT(1,4,4); CMULT(2,7,5); CMULT(0,2,6); CMULT(1,5,7); CMULT(2,8,8); CMULT(3,0,9); CMULT(4,3,10); CMULT(5,6,11); CMULT(3,1,12); CMULT(4,4,13); CMULT(5,7,14); CMULT(3,2,15); CMULT(4,5,16); CMULT(5,8,17); CMULT(6,0,18); CMULT(7,3,19); CMULT(8,6,20); CMULT(6,1,21); CMULT(7,4,22); CMULT(8,7,23); CMULT(6,2,24); CMULT(7,5,25); CMULT(8,8,26); CPUT3(0,1,2,0); CPUT3(3,4,5,1); CPUT3(6,7,8,2); CPUT3(9,10,11,3); CPUT3(12,13,14,4); CPUT3(15,16,17,5); CPUT3(18,19,20,6); CPUT3(21,22,23,7); CPUT3(24,25,26,8); } } R->Type = TENSOR; } /* a faire: differents tenseurs entre eux */ else { Message::Error("Product of non adapted quantities: %s * %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } } #undef CMULT #undef CPUT #undef CPUT3 /* ------------------------------------------------------------------------ R <- V1 / V2 ------------------------------------------------------------------------ */ #define CDIVI(a,b,c) \ Cal_ComplexDivision(&(V1->Val[MAX_DIM*k+a]), &(V2->Val[MAX_DIM*k+b]), tmp[c]) #define CPUT(a) \ R->Val[MAX_DIM* k +a] = tmp[a][0] ; \ R->Val[MAX_DIM*(k+1)+a] = tmp[a][MAX_DIM] void Cal_DivideValue(struct Value * V1, struct Value * V2, struct Value * R) { int k ; struct Value V3 ; if ( (V1->Type == SCALAR) && (V2->Type == SCALAR) ) { if (Current.NbrHar == 1) { R->Val[0] = V1->Val[0]/V2->Val[0]; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { /* meaning in multi-harmonics ??? */ CDIVI(0,0,0); CPUT(0); } } R->Type = SCALAR ; } else if ( (V1->Type == VECTOR || V1->Type == TENSOR_DIAG) && (V2->Type == SCALAR) ) { if (Current.NbrHar == 1) { a0 = V2->Val[0] ; R->Val[0] = V1->Val[0] / a0 ; R->Val[1] = V1->Val[1] / a0 ; R->Val[2] = V1->Val[2] / a0 ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CDIVI(0,0,0); CDIVI(1,0,1); CDIVI(2,0,2); CPUT(0); CPUT(1); CPUT(2); } } R->Type = V1->Type ; } else if ( (V1->Type == TENSOR_SYM) && (V2->Type == SCALAR) ) { if (Current.NbrHar == 1) { a0 = V2->Val[0] ; R->Val[0] = V1->Val[0] / a0 ; R->Val[1] = V1->Val[1] / a0 ; R->Val[2] = V1->Val[2] / a0 ; R->Val[3] = V1->Val[3] / a0 ; R->Val[4] = V1->Val[4] / a0 ; R->Val[5] = V1->Val[5] / a0 ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CDIVI(0,0,0); CDIVI(1,0,1); CDIVI(2,0,2); CDIVI(3,0,3); CDIVI(4,0,4); CDIVI(5,0,5); CPUT(0); CPUT(1); CPUT(2); CPUT(3); CPUT(4); CPUT(5); } } R->Type = TENSOR_SYM ; } else if ( (V1->Type == TENSOR) && (V2->Type == SCALAR) ) { if (Current.NbrHar == 1) { a0 = V2->Val[0] ; R->Val[0] = V1->Val[0] / a0 ; R->Val[1] = V1->Val[1] / a0 ; R->Val[2] = V1->Val[2] / a0 ; R->Val[3] = V1->Val[3] / a0 ; R->Val[4] = V1->Val[4] / a0 ; R->Val[5] = V1->Val[5] / a0 ; R->Val[6] = V1->Val[6] / a0 ; R->Val[7] = V1->Val[7] / a0 ; R->Val[8] = V1->Val[8] / a0 ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { CDIVI(0,0,0); CDIVI(1,0,1); CDIVI(2,0,2); CDIVI(3,0,3); CDIVI(4,0,4); CDIVI(5,0,5); CDIVI(6,0,6); CDIVI(7,0,7); CDIVI(8,0,8); CPUT(0); CPUT(1); CPUT(2); CPUT(3); CPUT(4); CPUT(5); CPUT(6); CPUT(7); CPUT(8); } } R->Type = TENSOR ; } else if ( (V1->Type == SCALAR) && (V2->Type == TENSOR || V2->Type == TENSOR_SYM || V2->Type == TENSOR_DIAG) ) { Cal_InvertValue(V2,&V3); Cal_ProductValue(V1,&V3,R); } else { Message::Error("Division of non adapted quantities: %s / %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } } #undef CDIVI #undef CPUT /* ------------------------------------------------------------------------ R <- V1 % V2 ------------------------------------------------------------------------ */ void Cal_ModuloValue(struct Value * V1, struct Value * V2, struct Value * R) { int k ; if ( (V1->Type == SCALAR) && (V2->Type == SCALAR) ) { for (k = 0 ; k < Current.NbrHar ; k += 2) { R->Val[MAX_DIM* k ] = (int)V1->Val[MAX_DIM*k] % (int)V2->Val[MAX_DIM*k] ; R->Val[MAX_DIM*(k+1)] = 0. ; } R->Type = SCALAR ; } else if ( (V1->Type == VECTOR) && (V2->Type == SCALAR) ) { for (k = 0 ; k < Current.NbrHar ; k += 2) { R->Val[MAX_DIM* k ] = (int)V1->Val[MAX_DIM*k ] % (int)V2->Val[MAX_DIM*k ] ; R->Val[MAX_DIM* k +1] = (int)V1->Val[MAX_DIM*k+1] % (int)V2->Val[MAX_DIM*k+1] ; R->Val[MAX_DIM* k +2] = (int)V1->Val[MAX_DIM*k+2] % (int)V2->Val[MAX_DIM*k+2] ; R->Val[MAX_DIM*(k+1)] = 0. ; R->Val[MAX_DIM*(k+1)+1] = 0. ; R->Val[MAX_DIM*(k+1)+2] = 0. ; } R->Type = VECTOR ; } else { Message::Error("Modulo of non adapted quantities: %s %% %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } } /* ------------------------------------------------------------------------ R <- V1 X V2 ------------------------------------------------------------------------ */ void Cal_CrossProductValue (struct Value * V1, struct Value * V2, struct Value * R) { int k ; if ( (V1->Type == VECTOR) && (V2->Type == VECTOR) ) { if (Current.NbrHar == 1) { a1[0] = V1->Val[1] * V2->Val[2] - V1->Val[2] * V2->Val[1] ; a1[1] = V1->Val[2] * V2->Val[0] - V1->Val[0] * V2->Val[2] ; a1[2] = V1->Val[0] * V2->Val[1] - V1->Val[1] * V2->Val[0] ; R->Val[0] = a1[0] ; R->Val[1] = a1[1] ; R->Val[2] = a1[2] ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2) { Cal_ComplexProduct(&(V1->Val[MAX_DIM*k+1]), &(V2->Val[MAX_DIM*k+2]), a1) ; Cal_ComplexProduct(&(V1->Val[MAX_DIM*k+2]), &(V2->Val[MAX_DIM*k+1]), a2) ; b1[0] = a1[0] - a2[0] ; b1[MAX_DIM] = a1[MAX_DIM] - a2[MAX_DIM] ; Cal_ComplexProduct(&(V1->Val[MAX_DIM*k+2]), &(V2->Val[MAX_DIM*k ]), a1) ; Cal_ComplexProduct(&(V1->Val[MAX_DIM*k ]), &(V2->Val[MAX_DIM*k+2]), a2) ; b2[0] = a1[0] - a2[0] ; b2[MAX_DIM] = a1[MAX_DIM] - a2[MAX_DIM] ; Cal_ComplexProduct(&(V1->Val[MAX_DIM*k ]), &(V2->Val[MAX_DIM*k+1]), a1) ; Cal_ComplexProduct(&(V1->Val[MAX_DIM*k+1]), &(V2->Val[MAX_DIM*k ]), a2) ; b3[0] = a1[0] - a2[0] ; b3[MAX_DIM] = a1[MAX_DIM] - a2[MAX_DIM] ; R->Val[MAX_DIM*k ] = b1[0] ; R->Val[MAX_DIM*(k+1) ] = b1[MAX_DIM] ; R->Val[MAX_DIM*k+1] = b2[0] ; R->Val[MAX_DIM*(k+1)+1] = b2[MAX_DIM] ; R->Val[MAX_DIM*k+2] = b3[0] ; R->Val[MAX_DIM*(k+1)+2] = b3[MAX_DIM] ; } } R->Type = VECTOR ; } else { Message::Error("Cross product of non vector quantities: %s /\\ %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } } /* ------------------------------------------------------------------------ R <- SQRT(V1) ------------------------------------------------------------------------ */ void Cal_SqrtValue(struct Value *V1, struct Value *R) { if( V1->Type == SCALAR ){ struct Value P; P.Type = SCALAR; P.Val[0] = 0.5; Cal_PowerValue(V1, &P, R); } else { Message::Error("Square root of non scalar quantity: %s", Get_StringForDefine(Field_Type, V1->Type)); } } /* ------------------------------------------------------------------------ R <- V1 ^ V2 ------------------------------------------------------------------------ */ void Cal_PowerValue(struct Value * V1, struct Value * V2, struct Value * R) { int k; double arg, abs ; if ( V1->Type == SCALAR && V2->Type == SCALAR ){ if(V2->Val[0] == 1.){ Cal_CopyValue(V1,R) ; } if(V2->Val[0] == 2.){ if (Current.NbrHar == 1) { R->Val[0] = SQU(V1->Val[0]) ; } else{ for (k = 0 ; k < Current.NbrHar ; k+=2) { Cal_ComplexProduct(&(V1->Val[MAX_DIM*k]), &(V1->Val[MAX_DIM*k]), a1) ; R->Val[MAX_DIM* k ] = a1[0]; R->Val[MAX_DIM*(k+1)] = a1[MAX_DIM]; } } } else{ if (Current.NbrHar == 1) { R->Val[0] = pow(V1->Val[0],V2->Val[0]) ; } else{ for (k = 0 ; k < Current.NbrHar ; k+=2) { abs = pow(sqrt(SQU(V1->Val[MAX_DIM*k])+SQU(V1->Val[MAX_DIM*(k+1)])), V2->Val[0]) ; arg = atan2(V1->Val[MAX_DIM*(k+1)], V1->Val[MAX_DIM*k]) ; R->Val[MAX_DIM* k ] = abs * cos(V2->Val[0] * arg) ; R->Val[MAX_DIM*(k+1)] = abs * sin(V2->Val[0] * arg) ; } } } R->Type = SCALAR ; } else { Message::Error("Power of non scalar quantities: %s ^ %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } } /* ------------------------------------------------------------------------ R <- V1 < V2 ------------------------------------------------------------------------ */ void Cal_LessValue(struct Value * V1, struct Value * V2, struct Value * R) { if ( (V1->Type == SCALAR) && (V2->Type == SCALAR) ) { R->Val[0] = (V1->Val[0] < V2->Val[0]) ; R->Type = SCALAR ; } else { Message::Error("Comparison of non scalar quantities: %s < %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } } /* ------------------------------------------------------------------------ R <- V1 <= V2 ------------------------------------------------------------------------ */ void Cal_LessOrEqualValue(struct Value * V1, struct Value * V2, struct Value * R) { if ( (V1->Type == SCALAR) && (V2->Type == SCALAR) ) { R->Val[0] = (V1->Val[0] <= V2->Val[0]) ; R->Type = SCALAR ; } else { Message::Error("Comparison of non scalar quantities: %s <= %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } } /* ------------------------------------------------------------------------ R <- V1 > V2 ------------------------------------------------------------------------ */ void Cal_GreaterValue(struct Value * V1, struct Value * V2, struct Value * R) { if ( (V1->Type == SCALAR) && (V2->Type == SCALAR) ) { R->Val[0] = (V1->Val[0] > V2->Val[0]) ; R->Type = SCALAR ; } else { Message::Error("Comparison of non scalar quantities: %s > %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } } /* ------------------------------------------------------------------------ R <- V1 >= V2 ------------------------------------------------------------------------ */ void Cal_GreaterOrEqualValue(struct Value * V1, struct Value * V2, struct Value * R) { if ( (V1->Type == SCALAR) && (V2->Type == SCALAR) ) { R->Val[0] = (V1->Val[0] >= V2->Val[0]) ; R->Type = SCALAR ; } else { Message::Error("Comparison of non scalar quantities: %s >= %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } } /* ------------------------------------------------------------------------ R <- V1 == V2 ------------------------------------------------------------------------ */ void Cal_EqualValue(struct Value * V1, struct Value * V2, struct Value * R) { int k; if ( (V1->Type == SCALAR) && (V2->Type == SCALAR) ) { R->Val[0] = (V1->Val[0] == V2->Val[0]) ; for (k = 1 ; k < Current.NbrHar ; k++){ if(!R->Val[0]) break; R->Val[0] = (V1->Val[MAX_DIM*k] == V2->Val[MAX_DIM*k]) ; } R->Type = SCALAR ; } else if ( ( (V1->Type == VECTOR) && (V2->Type == VECTOR) ) || ( (V1->Type == TENSOR_DIAG) && (V2->Type == TENSOR_DIAG) ) ) { R->Val[0] = (V1->Val[0] == V2->Val[0] && V1->Val[1] == V2->Val[1] && V1->Val[2] == V2->Val[2]) ; for (k = 0 ; k < Current.NbrHar ; k++) { if(!R->Val[0]) break; R->Val[0] = (V1->Val[MAX_DIM*k ] == V2->Val[MAX_DIM*k ] && V1->Val[MAX_DIM*k+1] == V2->Val[MAX_DIM*k+1] && V1->Val[MAX_DIM*k+2] == V2->Val[MAX_DIM*k+2]) ; } R->Type = SCALAR ; } else if ( (V1->Type == TENSOR_SYM) && (V2->Type == TENSOR_SYM) ) { R->Val[0] = (V1->Val[0] == V2->Val[0] && V1->Val[1] == V2->Val[1] && V1->Val[2] == V2->Val[2] && V1->Val[3] == V2->Val[3] && V1->Val[4] == V2->Val[4] && V1->Val[5] == V2->Val[5]) ; for (k = 0 ; k < Current.NbrHar ; k++) { if(!R->Val[0]) break; R->Val[0] = (V1->Val[MAX_DIM*k ] == V2->Val[MAX_DIM*k ] && V1->Val[MAX_DIM*k+1] == V2->Val[MAX_DIM*k+1] && V1->Val[MAX_DIM*k+2] == V2->Val[MAX_DIM*k+2] && V1->Val[MAX_DIM*k+3] == V2->Val[MAX_DIM*k+3] && V1->Val[MAX_DIM*k+4] == V2->Val[MAX_DIM*k+4] && V1->Val[MAX_DIM*k+5] == V2->Val[MAX_DIM*k+5]) ; } R->Type = SCALAR ; } else if ( (V1->Type == TENSOR) && (V2->Type == TENSOR) ) { R->Val[0] = (V1->Val[0] == V2->Val[0] && V1->Val[1] == V2->Val[1] && V1->Val[2] == V2->Val[2] && V1->Val[3] == V2->Val[3] && V1->Val[4] == V2->Val[4] && V1->Val[5] == V2->Val[5] && V1->Val[6] == V2->Val[6] && V1->Val[7] == V2->Val[7] && V1->Val[8] == V2->Val[8]) ; for (k = 0 ; k < Current.NbrHar ; k++) { if(!R->Val[0]) break; R->Val[0] = (V1->Val[MAX_DIM*k ] == V2->Val[MAX_DIM*k ] && V1->Val[MAX_DIM*k+1] == V2->Val[MAX_DIM*k+1] && V1->Val[MAX_DIM*k+2] == V2->Val[MAX_DIM*k+2] && V1->Val[MAX_DIM*k+3] == V2->Val[MAX_DIM*k+3] && V1->Val[MAX_DIM*k+4] == V2->Val[MAX_DIM*k+4] && V1->Val[MAX_DIM*k+5] == V2->Val[MAX_DIM*k+5] && V1->Val[MAX_DIM*k+6] == V2->Val[MAX_DIM*k+6] && V1->Val[MAX_DIM*k+7] == V2->Val[MAX_DIM*k+7] && V1->Val[MAX_DIM*k+8] == V2->Val[MAX_DIM*k+8]) ; } R->Type = SCALAR ; } else { Message::Error("Comparison of different quantities: %s == %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } } /* ------------------------------------------------------------------------ R <- V1 != V2 ------------------------------------------------------------------------ */ void Cal_NotEqualValue(struct Value * V1, struct Value * V2, struct Value * R) { int k; if ( (V1->Type == SCALAR) && (V2->Type == SCALAR) ) { R->Val[0] = (V1->Val[0] != V2->Val[0]) ; for (k = 1 ; k < Current.NbrHar ; k++){ if(R->Val[0]) break; R->Val[0] = (V1->Val[MAX_DIM*k] != V2->Val[MAX_DIM*k]) ; } R->Type = SCALAR ; } else if ( ( (V1->Type == VECTOR) && (V2->Type == VECTOR) ) || ( (V1->Type == TENSOR_DIAG) && (V2->Type == TENSOR_DIAG) ) ) { R->Val[0] = (V1->Val[0] != V2->Val[0] || V1->Val[1] != V2->Val[1] || V1->Val[2] != V2->Val[2]) ; for (k = 0 ; k < Current.NbrHar ; k++) { if(R->Val[0]) break; R->Val[0] = (V1->Val[MAX_DIM*k ] != V2->Val[MAX_DIM*k ] || V1->Val[MAX_DIM*k+1] != V2->Val[MAX_DIM*k+1] || V1->Val[MAX_DIM*k+2] != V2->Val[MAX_DIM*k+2]) ; } R->Type = SCALAR ; } else if ( (V1->Type == TENSOR_SYM) && (V2->Type == TENSOR_SYM) ) { R->Val[0] = (V1->Val[0] != V2->Val[0] || V1->Val[1] != V2->Val[1] || V1->Val[2] != V2->Val[2] || V1->Val[3] != V2->Val[3] || V1->Val[4] != V2->Val[4] || V1->Val[5] != V2->Val[5]) ; for (k = 0 ; k < Current.NbrHar ; k++) { if(R->Val[0]) break; R->Val[0] = (V1->Val[MAX_DIM*k ] != V2->Val[MAX_DIM*k ] || V1->Val[MAX_DIM*k+1] != V2->Val[MAX_DIM*k+1] || V1->Val[MAX_DIM*k+2] != V2->Val[MAX_DIM*k+2] || V1->Val[MAX_DIM*k+3] != V2->Val[MAX_DIM*k+3] || V1->Val[MAX_DIM*k+4] != V2->Val[MAX_DIM*k+4] || V1->Val[MAX_DIM*k+5] != V2->Val[MAX_DIM*k+5]) ; } R->Type = SCALAR ; } else if ( (V1->Type == TENSOR) && (V2->Type == TENSOR) ) { R->Val[0] = (V1->Val[0] != V2->Val[0] || V1->Val[1] != V2->Val[1] || V1->Val[2] != V2->Val[2] || V1->Val[3] != V2->Val[3] || V1->Val[4] != V2->Val[4] || V1->Val[5] != V2->Val[5] || V1->Val[6] != V2->Val[6] || V1->Val[7] != V2->Val[7] || V1->Val[8] != V2->Val[8]) ; for (k = 0 ; k < Current.NbrHar ; k++) { if(R->Val[0]) break; R->Val[0] = (V1->Val[MAX_DIM*k ] != V2->Val[MAX_DIM*k ] || V1->Val[MAX_DIM*k+1] != V2->Val[MAX_DIM*k+1] || V1->Val[MAX_DIM*k+2] != V2->Val[MAX_DIM*k+2] || V1->Val[MAX_DIM*k+3] != V2->Val[MAX_DIM*k+3] || V1->Val[MAX_DIM*k+4] != V2->Val[MAX_DIM*k+4] || V1->Val[MAX_DIM*k+5] != V2->Val[MAX_DIM*k+5] || V1->Val[MAX_DIM*k+6] != V2->Val[MAX_DIM*k+6] || V1->Val[MAX_DIM*k+7] != V2->Val[MAX_DIM*k+7] || V1->Val[MAX_DIM*k+8] != V2->Val[MAX_DIM*k+8]) ; } R->Type = SCALAR ; } else { Message::Error("Comparison of different quantities: %s != %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } } /* ------------------------------------------------------------------------ R <- V1 ~= V2 ------------------------------------------------------------------------ */ void Cal_ApproxEqualValue(struct Value * V1, struct Value * V2, struct Value * R) { if ( (V1->Type == SCALAR) && (V2->Type == SCALAR) ) { R->Val[0] = (fabs(V1->Val[0] - V2->Val[0]) < 1.e-10) ; R->Type = SCALAR ; } else { Message::Error("Comparison of non scalar quantities: %s ~= %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } } /* ------------------------------------------------------------------------ R <- V1 && V2 ------------------------------------------------------------------------ */ void Cal_AndValue(struct Value * V1, struct Value * V2, struct Value * R) { if ( (V1->Type == SCALAR) && (V2->Type == SCALAR) ) { R->Val[0] = (V1->Val[0] && V2->Val[0]) ; R->Type = SCALAR ; } else { Message::Error("And of non scalar quantities: %s && %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } } /* ------------------------------------------------------------------------ R <- V1 || V2 ------------------------------------------------------------------------ */ void Cal_OrValue(struct Value * V1, struct Value * V2, struct Value * R) { if ( (V1->Type == SCALAR) && (V2->Type == SCALAR) ) { R->Val[0] = (V1->Val[0] || V2->Val[0]) ; R->Type = SCALAR ; } else { Message::Error("Or of non scalar quantities: %s || %s", Get_StringForDefine(Field_Type, V1->Type), Get_StringForDefine(Field_Type, V2->Type)); } } /* ------------------------------------------------------------------------ R <- -R ------------------------------------------------------------------------ */ void Cal_NegValue(struct Value * R) { int k ; switch(R->Type) { case SCALAR : for (k = 0 ; k < Current.NbrHar ; k++){ R->Val[MAX_DIM*k] = -R->Val[MAX_DIM*k] ; } break; case VECTOR : case TENSOR_DIAG : for (k = 0 ; k < Current.NbrHar ; k++){ R->Val[MAX_DIM*k ] = -R->Val[MAX_DIM*k ] ; R->Val[MAX_DIM*k+1] = -R->Val[MAX_DIM*k+1] ; R->Val[MAX_DIM*k+2] = -R->Val[MAX_DIM*k+2] ; } break; case TENSOR_SYM : for (k = 0 ; k < Current.NbrHar ; k++){ R->Val[MAX_DIM*k ] = -R->Val[MAX_DIM*k ] ; R->Val[MAX_DIM*k+1] = -R->Val[MAX_DIM*k+1] ; R->Val[MAX_DIM*k+2] = -R->Val[MAX_DIM*k+2] ; R->Val[MAX_DIM*k+3] = -R->Val[MAX_DIM*k+3] ; R->Val[MAX_DIM*k+4] = -R->Val[MAX_DIM*k+4] ; R->Val[MAX_DIM*k+5] = -R->Val[MAX_DIM*k+5] ; } break; case TENSOR : for (k = 0 ; k < Current.NbrHar ; k++){ R->Val[MAX_DIM*k ] = -R->Val[MAX_DIM*k ] ; R->Val[MAX_DIM*k+1] = -R->Val[MAX_DIM*k+1] ; R->Val[MAX_DIM*k+2] = -R->Val[MAX_DIM*k+2] ; R->Val[MAX_DIM*k+3] = -R->Val[MAX_DIM*k+3] ; R->Val[MAX_DIM*k+4] = -R->Val[MAX_DIM*k+4] ; R->Val[MAX_DIM*k+5] = -R->Val[MAX_DIM*k+5] ; R->Val[MAX_DIM*k+6] = -R->Val[MAX_DIM*k+6] ; R->Val[MAX_DIM*k+7] = -R->Val[MAX_DIM*k+7] ; R->Val[MAX_DIM*k+8] = -R->Val[MAX_DIM*k+8] ; } break; default : Message::Error("Wrong argument type for Operator (-)"); break; } } /* ------------------------------------------------------------------------ R <- !R ------------------------------------------------------------------------ */ void Cal_NotValue(struct Value * R) { if (R->Type == SCALAR){ R->Val[0] = !R->Val[0] ; } else { Message::Error("Negation of non scalar quantity: ! %s", Get_StringForDefine(Field_Type, R->Type)); } } /* ------------------------------------------------------------------------ R <- V1^T ------------------------------------------------------------------------ */ void Cal_TransposeValue(struct Value *V1, struct Value *R) { int k; switch(V1->Type){ case TENSOR_DIAG : case TENSOR_SYM : Cal_CopyValue(V1,R); break; case TENSOR : R->Type = TENSOR; if(Current.NbrHar==1){ R->Val[0] = V1->Val[0]; R->Val[4] = V1->Val[4]; R->Val[8] = V1->Val[8]; a1[0] = V1->Val[1]; a1[1] = V1->Val[2]; a1[2] = V1->Val[5]; R->Val[1] = V1->Val[3]; R->Val[2] = V1->Val[6]; R->Val[5] = V1->Val[7]; R->Val[3] = a1[0]; R->Val[6] = a1[1]; R->Val[7] = a1[2]; } else{ for(k=0 ; kVal[MAX_DIM*k+0] = V1->Val[MAX_DIM*k+0]; R->Val[MAX_DIM*k+4] = V1->Val[MAX_DIM*k+4]; R->Val[MAX_DIM*k+8] = V1->Val[MAX_DIM*k+8]; a1[0] = V1->Val[MAX_DIM*k+1]; a1[1] = V1->Val[MAX_DIM*k+2]; a1[2] = V1->Val[MAX_DIM*k+5]; R->Val[MAX_DIM*k+1] = V1->Val[MAX_DIM*k+3]; R->Val[MAX_DIM*k+2] = V1->Val[MAX_DIM*k+6]; R->Val[MAX_DIM*k+5] = V1->Val[MAX_DIM*k+7]; R->Val[MAX_DIM*k+3] = a1[0]; R->Val[MAX_DIM*k+6] = a1[1]; R->Val[MAX_DIM*k+7] = a1[2]; } } break; default: Message::Error("Wrong argument in 'Cal_TransposeValue'"); break; } } /* ------------------------------------------------------------------------ R <- Trace(V1) ------------------------------------------------------------------------ */ void Cal_TraceValue(struct Value *V1, struct Value *R) { int k; switch(V1->Type){ case TENSOR_DIAG : if (Current.NbrHar == 1) { R->Val[0] = V1->Val[0]+V1->Val[1]+V1->Val[2]; } else { for (k = 0 ; k < Current.NbrHar ; k++) { R->Val[MAX_DIM*k] = V1->Val[MAX_DIM*k ]+ V1->Val[MAX_DIM*k+1]+ V1->Val[MAX_DIM*k+2]; } } R->Type = SCALAR ; break; case TENSOR_SYM : if (Current.NbrHar == 1) { R->Val[0] = V1->Val[0]+V1->Val[3]+V1->Val[5]; } else { for (k = 0 ; k < Current.NbrHar ; k++) { R->Val[MAX_DIM*k] = V1->Val[MAX_DIM*k ]+ V1->Val[MAX_DIM*k+3]+ V1->Val[MAX_DIM*k+5]; } } R->Type = SCALAR ; break; case TENSOR : if (Current.NbrHar == 1) { R->Val[0] = V1->Val[0]+V1->Val[4]+V1->Val[8]; } else { for (k = 0 ; k < Current.NbrHar ; k++) { R->Val[MAX_DIM*k] = V1->Val[MAX_DIM*k ]+ V1->Val[MAX_DIM*k+4]+ V1->Val[MAX_DIM*k+8]; } } R->Type = SCALAR ; break; default: Message::Error("Wrong argument type in 'Cal_TraceValue'"); break; } } /* ------------------------------------------------------------------------ R <- V1^T * V2 * V1 , V1 real ------------------------------------------------------------------------ */ #define A0 V1->Val[0] #define A1 V1->Val[1] #define A2 V1->Val[2] #define A3 V1->Val[3] #define A4 V1->Val[4] #define A5 V1->Val[5] #define A6 V1->Val[6] #define A7 V1->Val[7] #define A8 V1->Val[8] void Cal_RotateValue(struct Value *V1, struct Value *V2, struct Value *R) { int k; double t0,t1,t2,t3,t4,t5,t6,t7,t8; struct Value A; switch(V2->Type){ case VECTOR : if(Current.NbrHar == 1){ #define B0 V2->Val[0] #define B1 V2->Val[1] #define B2 V2->Val[2] A.Val[0]= A0*B0+A1*B1+A2*B2; A.Val[1]= A3*B0+A4*B1+A5*B2; A.Val[2]= A6*B0+A7*B1+A8*B2; A.Type = VECTOR; Cal_CopyValue(&A,R); #undef B0 #undef B1 #undef B2 } else{ /* Attention: a modifier */ #define B0 V2->Val[0] #define B1 V2->Val[1] #define B2 V2->Val[2] A.Val[0]= A0*B0+A1*B1+A2*B2; A.Val[1]= A3*B0+A4*B1+A5*B2; A.Val[2]= A6*B0+A7*B1+A8*B2; A.Type = VECTOR; Cal_CopyValue(&A,R); #undef B0 #undef B1 #undef B2 } break ; case TENSOR_DIAG : if(Current.NbrHar == 1){ #define B0 V2->Val[0] #define B1 V2->Val[1] #define B2 V2->Val[2] A.Val[0]= A0*A0*B0+A3*A3*B1+A6*A6*B2; A.Val[1]= A1*A0*B0+A3*A4*B1+A6*A7*B2; A.Val[2]= A2*A0*B0+A3*A5*B1+A6*A8*B2; A.Val[3]= A1*A0*B0+A3*A4*B1+A6*A7*B2; A.Val[4]= A1*A1*B0+A4*A4*B1+A7*A7*B2; A.Val[5]= A2*A1*B0+A4*A5*B1+A7*A8*B2; A.Val[6]= A2*A0*B0+A3*A5*B1+A6*A8*B2; A.Val[7]= A2*A1*B0+A4*A5*B1+A7*A8*B2; A.Val[8]= A2*A2*B0+A5*A5*B1+A8*A8*B2; A.Type = TENSOR; Cal_CopyValue(&A,R); #undef B0 #undef B1 #undef B2 } else{ #define B0r V2->Val[MAX_DIM* k +0] #define B1r V2->Val[MAX_DIM* k +1] #define B2r V2->Val[MAX_DIM* k +2] #define B0i V2->Val[MAX_DIM*(k+1)+0] #define B1i V2->Val[MAX_DIM*(k+1)+1] #define B2i V2->Val[MAX_DIM*(k+1)+2] #define AFFECT(i) \ A.Val[MAX_DIM* k +i] = t0*B0r+t1*B1r+t2*B2r; \ A.Val[MAX_DIM*(k+1)+i] = t0*B0i+t1*B1i+t2*B2i for(k=0 ; kVal[0] #define B1 V2->Val[1] #define B2 V2->Val[2] #define B3 V2->Val[1] #define B4 V2->Val[3] #define B5 V2->Val[4] #define B6 V2->Val[2] #define B7 V2->Val[4] #define B8 V2->Val[5] COMPUTE_A; A.Type = TENSOR; Cal_CopyValue(&A,R); #undef B0 #undef B1 #undef B2 #undef B3 #undef B4 #undef B5 #undef B6 #undef B7 #undef B8 } else{ #define B0r V2->Val[MAX_DIM* k +0] #define B1r V2->Val[MAX_DIM* k +1] #define B2r V2->Val[MAX_DIM* k +2] #define B3r V2->Val[MAX_DIM* k +3] #define B4r V2->Val[MAX_DIM* k +4] #define B5r V2->Val[MAX_DIM* k +5] #define B6r V2->Val[MAX_DIM* k +6] #define B7r V2->Val[MAX_DIM* k +7] #define B8r V2->Val[MAX_DIM* k +8] #define B0i V2->Val[MAX_DIM*(k+1)+0] #define B1i V2->Val[MAX_DIM*(k+1)+1] #define B2i V2->Val[MAX_DIM*(k+1)+2] #define B3i V2->Val[MAX_DIM*(k+1)+3] #define B4i V2->Val[MAX_DIM*(k+1)+4] #define B5i V2->Val[MAX_DIM*(k+1)+5] #define B6i V2->Val[MAX_DIM*(k+1)+6] #define B7i V2->Val[MAX_DIM*(k+1)+7] #define B8i V2->Val[MAX_DIM*(k+1)+8] #define AFFECT(i) \ A.Val[MAX_DIM* k +i] = t0*B0r+t1*B3r+t2*B6r+t3*B1r+t4*B4r+t5*B7r+t6*B2r+t7*B5r+t8*B8r; \ A.Val[MAX_DIM*(k+1)+i] = t0*B0i+t1*B3i+t2*B6i+t3*B1i+t4*B4i+t5*B7i+t6*B2i+t7*B5i+t8*B8i for(k=0 ; kVal[0] #define B1 V2->Val[1] #define B2 V2->Val[2] #define B3 V2->Val[3] #define B4 V2->Val[4] #define B5 V2->Val[5] #define B6 V2->Val[6] #define B7 V2->Val[7] #define B8 V2->Val[8] COMPUTE_A; A.Type = TENSOR; Cal_CopyValue(&A,R); #undef B0 #undef B1 #undef B2 #undef B3 #undef B4 #undef B5 #undef B6 #undef B7 #undef B8 } else{ #define B0r V2->Val[MAX_DIM* k +0] #define B1r V2->Val[MAX_DIM* k +1] #define B2r V2->Val[MAX_DIM* k +2] #define B3r V2->Val[MAX_DIM* k +3] #define B4r V2->Val[MAX_DIM* k +4] #define B5r V2->Val[MAX_DIM* k +5] #define B6r V2->Val[MAX_DIM* k +6] #define B7r V2->Val[MAX_DIM* k +7] #define B8r V2->Val[MAX_DIM* k +8] #define B0i V2->Val[MAX_DIM*(k+1)+0] #define B1i V2->Val[MAX_DIM*(k+1)+1] #define B2i V2->Val[MAX_DIM*(k+1)+2] #define B3i V2->Val[MAX_DIM*(k+1)+3] #define B4i V2->Val[MAX_DIM*(k+1)+4] #define B5i V2->Val[MAX_DIM*(k+1)+5] #define B6i V2->Val[MAX_DIM*(k+1)+6] #define B7i V2->Val[MAX_DIM*(k+1)+7] #define B8i V2->Val[MAX_DIM*(k+1)+8] #define AFFECT(i) \ A.Val[MAX_DIM* k +i] = t0*B0r+t1*B3r+t2*B6r+t3*B1r+t4*B4r+t5*B7r+t6*B2r+t7*B5r+t8*B8r; \ A.Val[MAX_DIM*(k+1)+i] = t0*B0i+t1*B3i+t2*B6i+t3*B1i+t4*B4i+t5*B7i+t6*B2i+t7*B5i+t8*B8i for(k=0 ; kType; R->Type = SCALAR; switch(V1Type){ case TENSOR_DIAG : if(Current.NbrHar==1){ R->Val[0] = V1->Val[0]*V1->Val[1]*V1->Val[2]; } else{ for(k=0 ; kVal[MAX_DIM*k+0], &V1->Val[MAX_DIM*k+1], a1); Cal_ComplexProduct(&V1->Val[MAX_DIM*k+2], a1, a2); R->Val[MAX_DIM* k ] = a2[0]; R->Val[MAX_DIM*(k+1)] = a2[MAX_DIM]; } } break; case TENSOR_SYM : if(Current.NbrHar==1){ R->Val[0] = V1->Val[0]*(V1->Val[3]*V1->Val[5]-V1->Val[4]*V1->Val[4]) - V1->Val[1]*(V1->Val[1]*V1->Val[5]-V1->Val[2]*V1->Val[4]) + V1->Val[2]*(V1->Val[1]*V1->Val[4]-V1->Val[2]*V1->Val[3]); } else{ for(k=0 ; kVal[MAX_DIM*k+3], &V1->Val[MAX_DIM*k+5], a1); Cal_ComplexProduct(&V1->Val[MAX_DIM*k+4], &V1->Val[MAX_DIM*k+4], a2); b1[0] = a1[0] - a2[0] ; b1[MAX_DIM] = a1[MAX_DIM] - a2[MAX_DIM] ; Cal_ComplexProduct(&V1->Val[MAX_DIM*k+0], b1, c1); Cal_ComplexProduct(&V1->Val[MAX_DIM*k+1], &V1->Val[MAX_DIM*k+5], a1); Cal_ComplexProduct(&V1->Val[MAX_DIM*k+2], &V1->Val[MAX_DIM*k+4], a2); b1[0] = a1[0] - a2[0] ; b1[MAX_DIM] = a1[MAX_DIM] - a2[MAX_DIM] ; Cal_ComplexProduct(&V1->Val[MAX_DIM*k+1], b1, c2); Cal_ComplexProduct(&V1->Val[MAX_DIM*k+1], &V1->Val[MAX_DIM*k+4], a1); Cal_ComplexProduct(&V1->Val[MAX_DIM*k+2], &V1->Val[MAX_DIM*k+3], a2); b1[0] = a1[0] - a2[0] ; b1[MAX_DIM] = a1[MAX_DIM] - a2[MAX_DIM] ; Cal_ComplexProduct(&V1->Val[MAX_DIM*k+2], b1, c3); R->Val[MAX_DIM* k ] = c1[0] -c2[0] +c3[0]; R->Val[MAX_DIM*(k+1)] = c1[MAX_DIM]-c2[MAX_DIM]+c3[MAX_DIM]; } } break; case TENSOR : if(Current.NbrHar==1){ R->Val[0] = V1->Val[0]*(V1->Val[4]*V1->Val[8]-V1->Val[7]*V1->Val[5]) - V1->Val[1]*(V1->Val[3]*V1->Val[8]-V1->Val[6]*V1->Val[5]) + V1->Val[2]*(V1->Val[3]*V1->Val[7]-V1->Val[6]*V1->Val[4]); } else{ for(k=0 ; kVal[MAX_DIM*k+4], &V1->Val[MAX_DIM*k+8], a1); Cal_ComplexProduct(&V1->Val[MAX_DIM*k+7], &V1->Val[MAX_DIM*k+5], a2); b1[0] = a1[0] - a2[0] ; b1[MAX_DIM] = a1[MAX_DIM] - a2[MAX_DIM] ; Cal_ComplexProduct(&V1->Val[MAX_DIM*k+0], b1, c1); Cal_ComplexProduct(&V1->Val[MAX_DIM*k+3], &V1->Val[MAX_DIM*k+8], a1); Cal_ComplexProduct(&V1->Val[MAX_DIM*k+6], &V1->Val[MAX_DIM*k+5], a2); b1[0] = a1[0] - a2[0] ; b1[MAX_DIM] = a1[MAX_DIM] - a2[MAX_DIM] ; Cal_ComplexProduct(&V1->Val[MAX_DIM*k+1], b1, c2); Cal_ComplexProduct(&V1->Val[MAX_DIM*k+3], &V1->Val[MAX_DIM*k+7], a1); Cal_ComplexProduct(&V1->Val[MAX_DIM*k+6], &V1->Val[MAX_DIM*k+4], a2); b1[0] = a1[0] - a2[0] ; b1[MAX_DIM] = a1[MAX_DIM] - a2[MAX_DIM] ; Cal_ComplexProduct(&V1->Val[MAX_DIM*k+2], b1, c3); R->Val[MAX_DIM* k ] = c1[0] -c2[0] +c3[0]; R->Val[MAX_DIM*(k+1)] = c1[MAX_DIM]-c2[MAX_DIM]+c3[MAX_DIM]; } } break; default: Message::Error("Wrong argument type in 'Cal_DetValue'"); break; } } /* ------------------------------------------------------------------------ R <- 1/V1 ------------------------------------------------------------------------ */ void Cal_InvertValue(struct Value *V1, struct Value *R) { int k; struct Value Det,A; switch(V1->Type){ case SCALAR : R->Type = SCALAR; if(Current.NbrHar==1){ if(!V1->Val[0]){ Message::Error("Division by zero in 'Cal_InvertValue'"); return; } R->Val[0] = 1./V1->Val[0]; } else{ for(k=0 ; kVal[MAX_DIM*k], &R->Val[MAX_DIM*k]); } } break; case TENSOR_DIAG : R->Type = TENSOR_DIAG; if(Current.NbrHar==1){ if(V1->Val[0] && V1->Val[1] && V1->Val[2]){ R->Val[0] = 1./V1->Val[0]; R->Val[1] = 1./V1->Val[1]; R->Val[2] = 1./V1->Val[2]; } else{ Message::Error("Null determinant in 'Cal_InvertValue'"); return; } } else{ for(k=0 ; kVal[MAX_DIM*k ], &R->Val[MAX_DIM*k ]); Cal_ComplexInvert(&V1->Val[MAX_DIM*k+1], &R->Val[MAX_DIM*k+1]); Cal_ComplexInvert(&V1->Val[MAX_DIM*k+2], &R->Val[MAX_DIM*k+2]); } } break; case TENSOR_SYM : Cal_DetValue(V1,&Det); if(!Det.Val[0]){ Message::Error("Null determinant in 'Cal_InvertValue'"); return; } if(Current.NbrHar==1){ A.Val[0] = (V1->Val[3]*V1->Val[5]-V1->Val[4]*V1->Val[4])/Det.Val[0]; A.Val[1] = -(V1->Val[1]*V1->Val[5]-V1->Val[4]*V1->Val[2])/Det.Val[0]; A.Val[2] = (V1->Val[1]*V1->Val[4]-V1->Val[3]*V1->Val[2])/Det.Val[0]; A.Val[3] = -(V1->Val[1]*V1->Val[5]-V1->Val[2]*V1->Val[4])/Det.Val[0]; A.Val[4] = (V1->Val[0]*V1->Val[5]-V1->Val[2]*V1->Val[2])/Det.Val[0]; A.Val[5] = -(V1->Val[0]*V1->Val[4]-V1->Val[2]*V1->Val[1])/Det.Val[0]; A.Val[6] = (V1->Val[1]*V1->Val[4]-V1->Val[2]*V1->Val[3])/Det.Val[0]; A.Val[7] = -(V1->Val[0]*V1->Val[4]-V1->Val[1]*V1->Val[2])/Det.Val[0]; A.Val[8] = (V1->Val[0]*V1->Val[3]-V1->Val[1]*V1->Val[1])/Det.Val[0]; A.Type = TENSOR; Cal_CopyValue(&A,R); } else{ #define PRODSUBDIV(a,b,c,d,e) \ Cal_ComplexProduct(&V1->Val[MAX_DIM*k+a], &V1->Val[MAX_DIM*k+b], a1); \ Cal_ComplexProduct(&V1->Val[MAX_DIM*k+c], &V1->Val[MAX_DIM*k+d], a2); \ b1[0] = a1[0] - a2[0] ; b1[MAX_DIM] = a1[MAX_DIM] - a2[MAX_DIM]; \ Cal_ComplexDivision(b1, &Det.Val[MAX_DIM*k], &A.Val[e]) #define ASSIGN1(i) \ R->Val[MAX_DIM* k +i] = A.Val[MAX_DIM* k +i]; \ R->Val[MAX_DIM*(k+1)+i] = A.Val[MAX_DIM*(k+1)+i] #define ASSIGN2(i) \ R->Val[MAX_DIM* k +i] = -A.Val[MAX_DIM* k +i]; \ R->Val[MAX_DIM*(k+1)+i] = -A.Val[MAX_DIM*(k+1)+i] for(k=0 ; kType = TENSOR; #undef PRODSUBDIV #undef ASSIGN1 #undef ASSIGN2 } break; case TENSOR : Cal_DetValue(V1,&Det); if(!Det.Val[0]){ Message::Error("Null determinant in 'Cal_InvertValue'"); return; } if(Current.NbrHar==1){ A.Val[0] = (V1->Val[4]*V1->Val[8]-V1->Val[5]*V1->Val[7])/Det.Val[0]; A.Val[1] = -(V1->Val[1]*V1->Val[8]-V1->Val[7]*V1->Val[2])/Det.Val[0]; A.Val[2] = (V1->Val[1]*V1->Val[5]-V1->Val[4]*V1->Val[2])/Det.Val[0]; A.Val[3] = -(V1->Val[3]*V1->Val[8]-V1->Val[6]*V1->Val[5])/Det.Val[0]; A.Val[4] = (V1->Val[0]*V1->Val[8]-V1->Val[2]*V1->Val[6])/Det.Val[0]; A.Val[5] = -(V1->Val[0]*V1->Val[5]-V1->Val[2]*V1->Val[3])/Det.Val[0]; A.Val[6] = (V1->Val[3]*V1->Val[7]-V1->Val[6]*V1->Val[4])/Det.Val[0]; A.Val[7] = -(V1->Val[0]*V1->Val[7]-V1->Val[1]*V1->Val[6])/Det.Val[0]; A.Val[8] = (V1->Val[0]*V1->Val[4]-V1->Val[1]*V1->Val[3])/Det.Val[0]; A.Type = TENSOR; Cal_CopyValue(&A,R); } else{ #define PRODSUBDIV(a,b,c,d,e) \ Cal_ComplexProduct(&V1->Val[MAX_DIM*k+a], &V1->Val[MAX_DIM*k+b], a1); \ Cal_ComplexProduct(&V1->Val[MAX_DIM*k+c], &V1->Val[MAX_DIM*k+d], a2); \ b1[0] = a1[0] - a2[0] ; b1[MAX_DIM] = a1[MAX_DIM] - a2[MAX_DIM]; \ Cal_ComplexDivision(b1, &Det.Val[MAX_DIM*k], &A.Val[e]) #define ASSIGN1(i) \ R->Val[MAX_DIM* k +i] = A.Val[MAX_DIM* k +i]; \ R->Val[MAX_DIM*(k+1)+i] = A.Val[MAX_DIM*(k+1)+i] #define ASSIGN2(i) \ R->Val[MAX_DIM* k +i] = -A.Val[MAX_DIM* k +i]; \ R->Val[MAX_DIM*(k+1)+i] = -A.Val[MAX_DIM*(k+1)+i] for(k=0 ; kType = TENSOR; #undef PRODSUBDIV #undef ASSIGN1 #undef ASSIGN2 } break; default : Message::Error("Wrong type of argument in 'Cal_InvertValue'"); break; } } /* ------------------------------------------------------- */ /* --> P r i n t _ V a l u e */ /* ------------------------------------------------------- */ std::string Print_Value_ToString(struct Value *A) { int i, j, k, index = 0; std::ostringstream sstream; sstream.precision(16); switch(A->Type){ case SCALAR ://***Ruth: Provisional: incompatibility with gnuplot //if(Current.NbrHar>1) sstream << "("; for (k = 0 ; k < Current.NbrHar ; k++) { if(k) sstream << ","; sstream << A->Val[MAX_DIM*k]; } if(Current.NbrHar>1) sstream << ")"; break; case VECTOR ://***Ruth //sstream << "["; for (i = 0 ; i < 3 ; i++) { if(i) sstream << " "; //if(Current.NbrHar>1) sstream << "("; for (k = 0 ; k < Current.NbrHar ; k++) { if(k) sstream << ","; sstream << A->Val[MAX_DIM*k+i]; } //if(Current.NbrHar>1) sstream << ")"; } //sstream << "]"; break; case TENSOR_DIAG : case TENSOR_SYM : case TENSOR : sstream << "[["; for (i = 0 ; i < 3 ; i++) { if(i) sstream << "]["; for (j = 0 ; j < 3 ; j++) { if(j) sstream << " "; if(Current.NbrHar>1) sstream << "("; switch(A->Type){ case TENSOR_DIAG : index = TENSOR_DIAG_MAP[3*i+j]; break; case TENSOR_SYM : index = TENSOR_SYM_MAP[3*i+j]; break; case TENSOR : index = 3*i+j; break; } for (k = 0 ; k < Current.NbrHar ; k++) { if(k) sstream << ","; if(index<0) sstream << "0"; else sstream << A->Val[MAX_DIM*k+index]; } if(Current.NbrHar>1) sstream << ")"; } } sstream << "]]"; break; default : Message::Error("Unknown type of argument in function 'Printf'"); break; } std::string ret(sstream.str()); return ret; } void Print_Value(struct Value *A) { Message::Direct("%s", Print_Value_ToString(A).c_str()); } /* ------------------------------------------------------------------------ Complete harmonics ------------------------------------------------------------------------ */ void Cal_SetHarmonicValue(struct Value *R) { int k ; switch(R->Type){ case SCALAR : R->Val[MAX_DIM] = 0. ; for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) { R->Val[MAX_DIM*k ] = R->Val[0] ; R->Val[MAX_DIM*(k+1)] = 0. ; } break; case VECTOR : R->Val[MAX_DIM] = R->Val[MAX_DIM+1] = R->Val[MAX_DIM+2] = 0. ; for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) { R->Val[MAX_DIM*k ] = R->Val[0] ; R->Val[MAX_DIM*k+1] = R->Val[1] ; R->Val[MAX_DIM*k+2] = R->Val[2] ; R->Val[MAX_DIM*(k+1) ] = 0. ; R->Val[MAX_DIM*(k+1)+1] = 0. ; R->Val[MAX_DIM*(k+1)+2] = 0. ; } break; default : Message::Error("Unknown type of argument in function 'Cal_SetHarmonicValue'"); } } /* ------------------------------------------------------------------------ Set superfluous harmonics to zero (in case of CASTing) ------------------------------------------------------------------------ */ void Cal_SetZeroHarmonicValue(struct Value *R, int Save_NbrHar) { int k ; switch(R->Type) { case SCALAR : for (k = Current.NbrHar ; k < Save_NbrHar ; k++) { R->Val[k*MAX_DIM ] = 0. ; } break ; case VECTOR : case TENSOR_DIAG : for (k = Current.NbrHar ; k < Save_NbrHar ; k++) { R->Val[k*MAX_DIM ] = 0. ; R->Val[k*MAX_DIM+1] = 0. ; R->Val[k*MAX_DIM+2] = 0. ; } break ; case TENSOR_SYM : for (k = Current.NbrHar ; k < Save_NbrHar ; k++) { R->Val[k*MAX_DIM ] = 0. ; R->Val[k*MAX_DIM+1] = 0. ; R->Val[k*MAX_DIM+2] = 0. ; R->Val[k*MAX_DIM+3] = 0. ; R->Val[k*MAX_DIM+4] = 0. ; R->Val[k*MAX_DIM+5] = 0. ; } break ; case TENSOR : for (k = Current.NbrHar ; k < Save_NbrHar ; k++) { R->Val[k*MAX_DIM ] = 0. ; R->Val[k*MAX_DIM+1] = 0. ; R->Val[k*MAX_DIM+2] = 0. ; R->Val[k*MAX_DIM+3] = 0. ; R->Val[k*MAX_DIM+4] = 0. ; R->Val[k*MAX_DIM+5] = 0. ; R->Val[k*MAX_DIM+6] = 0. ; R->Val[k*MAX_DIM+7] = 0. ; R->Val[k*MAX_DIM+8] = 0. ; } break ; default : Message::Error("Unknown type of argument in function 'Cal_SetZeroHarmonicValue'"); } } /* ------------------------------------------------------- */ /* --> S h o w _ V a l u e */ /* ------------------------------------------------------- */ #define W(i,j) A->Val[MAX_DIM*(i)+j] int NonZeroHar(int NbrComp, double Val[]) { int iComp, nz, nh; nh=Current.NbrHar-1; while( nh >= 0 ){ nz=0; for (iComp=0 ; iCompType){ case SCALAR : if((nzh=NonZeroHar(1,A->Val)) == 0){ fprintf(stderr, "zero scalar \n") ; } else if(nzh == 1){ fprintf(stderr, "real scalar %e \n", W(0,0) ) ; } else if (nzh == 2){ fprintf(stderr, "complex scalar %e +j %e \n", W(0,0), W(1,0) ) ; } else { fprintf(stderr, "multi-freq scalar "); for (k = 0 ; k < Current.NbrHar ; k += 2) fprintf(stderr, " Freq %d : %e + j %e",k/2+1, W(k,0), W(k+1,0) ) ; fprintf(stderr, "\n"); } break; case VECTOR : if((nzh=NonZeroHar(3,A->Val)) == 0){ fprintf(stderr, "zero vector \n") ; } else if (nzh == 1){ fprintf(stderr, "real vector x %e y %e z %e \n", W(0,0), W(0,1), W(0,2)); } else if (nzh == 2){ fprintf(stderr, "complex vector x %e +j %e y %e +j %e z %e +j %e \n", W(0,0), W(1,0), W(0,1), W(1,1), W(0,2), W(1,2) ); } else{ fprintf(stderr, "multi-freq vector "); for (k = 0 ; k < Current.NbrHar ; k += 2) fprintf(stderr, " Freq %d : x %e +j %e y %e +j %e z %e +j %e", k/2+1, W(k,0), W(k+1,0), W(k,1), W(k+1,1), W(k,2), W(k+1,2) ); fprintf(stderr, "\n"); } break; case TENSOR : if((nzh=NonZeroHar(9,A->Val)) == 0){ fprintf(stderr, "zero tensor \n") ; } else if (nzh == 1){ fprintf(stderr, "real tensor " " xx %e xy %e xz %e " " yx %e yy %e yz %e " " zx %e zy %e zz %e \n", W(0,0), W(0,1), W(0,2), W(0,3), W(0,4), W(0,5), W(0,6), W(0,7), W(0,8)); } else if (nzh == 2){ fprintf(stderr, "complex tensor " " xx %e +j %e xy %e +j %e xz %e +j %e " " yx %e +j %e yy %e +j %e yz %e +j %e " " zx %e +j %e zy %e +j %e zz %e +j %e\n", W(0,0), W(1,0), W(0,1), W(1,1), W(0,2), W(1,2), W(0,3), W(1,3), W(0,4), W(1,4), W(0,5), W(1,5), W(0,6), W(1,6), W(0,7), W(1,7), W(0,8), W(1,8)); } else { fprintf(stderr, "multi-freq tensor "); for (k = 0 ; k < Current.NbrHar ; k += 2) fprintf(stderr, " Freq %d : " " xx %e +j %e xy %e +j %e xz %e +j %e " " yx %e +j %e yy %e +j %e yz %e +j %e " " zx %e +j %e zy %e +j %e zz %e +j %e", k/2+1, W(k,0), W(k+1,0), W(k,1), W(k+1,1), W(k,2), W(k+1,2), W(k,3), W(k+1,3), W(k,4), W(k+1,4), W(k,5), W(k+1,5), W(k,6), W(k+1,6), W(k,7), W(k+1,7), W(k,8), W(k+1,8)); fprintf(stderr, "\n"); } break; case TENSOR_SYM : if((nzh=NonZeroHar(6,A->Val)) == 0){ fprintf(stderr, "zero sym tensor \n") ; } else if (nzh == 1){ fprintf(stderr, "real sym tensor " " xx %e xy %e xz %e " " yy %e yz %e zz %e \n", W(0,0), W(0,1), W(0,2), W(0,3), W(0,4), W(0,5)); } else if (nzh == 2){ fprintf(stderr, "complex sym tensor " " xx %e +j %e xy %e +j %e xz %e +j %e " " yy %e +j %e yz %e +j %e zz %e +j %e\n", W(0,0), W(1,0), W(0,1), W(1,1), W(0,2), W(1,2), W(0,3), W(1,3), W(0,4), W(1,4), W(0,5), W(1,5)); } else { fprintf(stderr, "multi-freq sym tensor "); for (k = 0 ; k < Current.NbrHar ; k += 2) fprintf(stderr, " Freq %d : " " xx %e +j %e xy %e +j %e xz %e +j %e " " yy %e +j %e yz %e +j %e zz %e +j %e", k/2+1, W(k,0), W(k+1,0), W(k,1), W(k+1,1), W(k,2), W(k+1,2), W(k,3), W(k+1,3), W(k,4), W(k+1,4), W(k,5), W(k+1,5)); fprintf(stderr, "\n"); } break; case TENSOR_DIAG : if((nzh=NonZeroHar(3,A->Val)) == 0){ fprintf(stderr, "zero sym tensor \n") ; } else if (nzh == 1){ fprintf(stderr, "real diag tensor xx %e yy %e zz %e \n", W(0,0), W(0,1), W(0,2)); } else if (nzh == 2){ fprintf(stderr, "complex diag tensor xx %e +j %e yy %e +j %e zz %e +j %e", W(0,0), W(1,0), W(0,1), W(1,1), W(0,2), W(1,2)); } else { fprintf(stderr, "multi-freq diag tensor "); for (k = 0 ; k < Current.NbrHar ; k += 2) fprintf(stderr, " Freq %d : xx %e +j %e yy %e +j %e zz %e +j %e", k/2+1, W(k,0), W(k+1,0), W(k,1), W(k+1,1), W(k,2), W(k+1,2)); fprintf(stderr, "\n"); } break; default : Message::Error("Unknown value type in Show_Value"); } } #undef W getdp-2.4.2-source/Legacy/Pos_FemInterpolation.h000644 001750 001750 00000001244 12116424202 023250 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _POS_FEM_INTERPOLATION_H_ #define _POS_FEM_INTERPOLATION_H_ #include "ProData.h" void Pos_FemInterpolation(struct Element * Element, struct QuantityStorage * QuantityStorage_P0, struct QuantityStorage * QuantityStorage_P, int Type_Quantity, int Type_Operator, int Type_Dimension, int UseXYZ, double u, double v, double w, double x, double y, double z, double Val[], int * Type_Value, int Flag_ChangeOfCoordinates); #endif getdp-2.4.2-source/Legacy/Operation_IterativeTimeReduction.cpp000644 001750 001750 00000046347 12116424202 026170 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include #include "ProData.h" #include "DofData.h" #include "SolvingOperations.h" #include "Message.h" #include "MallocUtils.h" #include "Cal_Quantity.h" #include "Get_DofOfElement.h" #define TWO_PI 6.2831853071795865 extern struct Problem Problem_S ; extern struct CurrentData Current ; extern int Flag_NextThetaFixed ; /* ------------------------------------------------------------------------ */ /* C a l _ S o l u t i o n E r r o r X */ /* ------------------------------------------------------------------------ */ void Cal_SolutionErrorX(int Nbr, double * xNew, double * x, double * MeanError) { int i; double errsqr = 0., xmoy = 0., dxmoy = 0., tol ; if(gSCALAR_SIZE == 2) Message::Error("FIXME: Cal_SolutionErrorX might return strange results" " in complex arithmetic"); for (i = 0 ; i < Nbr ; i++) { xmoy += fabs( x[i])/(double)Nbr ; dxmoy += fabs(xNew[i]-x[i])/(double)Nbr ; } if (xmoy > 1.e-30) { tol = xmoy*1.e-10 ; for (i = 0 ; i < Nbr ; i++) if ( fabs(x[i]) > tol ) errsqr += fabs((xNew[i]-x[i]) / x[i]) ; else errsqr += fabs(xNew[i]-x[i]) ; *MeanError = errsqr / (double)Nbr ; } else if (dxmoy > 1.e-30) *MeanError = 1. ; else *MeanError = 0. ; } /* ------------------------------------------------------------------------ */ /* C a l _ C o m p a r e G l o b a l Q u a n t i t y */ /* ------------------------------------------------------------------------ */ #define COMPARE_CHANGE 1 #define COMPARE_CONVERGENCE 2 void Cal_CompareGlobalQuantity(struct Operation * Operation_P, int Type_Analyse, int * Type_ChangeOfState, int * FlagIndex, int Flag_First) { List_T *Region_L = NULL ; int i, Nbr_Region = 0, Num_Region ; int Nbr_ChangeOfState, i_COS ; struct ChangeOfState *ChangeOfState_P = NULL; struct Formulation *Formulation_P ; struct FunctionSpace *FunctionSpace_P ; struct GlobalQuantity *GlobalQuantity_P ; struct DefineQuantity *DefineQuantity_P ; struct QuantityStorage QuantityStorage_S ; double Val0_Dof, Val1_Dof ; double *val0 = NULL, *val1 = NULL, MeanError, v0, v1 ; struct Value Value ; double Val1_E, Val0_E, Val_S, Val0_Ref, Val1_Ref, v_fz, v_k, v_ke, v_sat ; double Save_Time ; if(gSCALAR_SIZE == 2) Message::Error("FIXME: Cal_CompareGlobalQuantity might return strange results" " in complex arithmetic"); /* test */ v_k = 1./27.2836 ; v_ke = 18.518519 ; v_fz = 1. / (5.e3 * 1.5e-9) ; v_sat = 6. ; *Type_ChangeOfState = CHANGEOFSTATE_NOCHANGE ; Nbr_ChangeOfState = List_Nbr(Operation_P->Case.IterativeTimeReduction.ChangeOfState) ; for (i_COS = 0 ; i_COS < Nbr_ChangeOfState ; i_COS++) { ChangeOfState_P = (struct ChangeOfState *) List_Pointer(Operation_P->Case.IterativeTimeReduction.ChangeOfState, i_COS) ; Region_L = ((struct Group *)List_Pointer(Problem_S.Group, ChangeOfState_P->InIndex)) ->InitialList ; List_Sort(Region_L, fcmp_int) ; Nbr_Region = List_Nbr(Region_L) ; if (Nbr_Region > 0) { Formulation_P = (struct Formulation *) List_Pointer(Problem_S.Formulation, ChangeOfState_P->FormulationIndex) ; DefineQuantity_P = (struct DefineQuantity *) List_Pointer(Formulation_P->DefineQuantity, ChangeOfState_P->QuantityIndex) ; QuantityStorage_S.FunctionSpace = FunctionSpace_P = (struct FunctionSpace*)List_Pointer(Problem_S.FunctionSpace, DefineQuantity_P->FunctionSpaceIndex) ; GlobalQuantity_P = (struct GlobalQuantity*) List_Pointer(FunctionSpace_P->GlobalQuantity, *(int *)List_Pointer(DefineQuantity_P->IndexInFunctionSpace, 0)) ; if (!ChangeOfState_P->ActiveList[0]) { ChangeOfState_P->ActiveList[0] =(double *)Malloc(Nbr_Region * sizeof(double)) ; ChangeOfState_P->ActiveList[1] =(double *)Malloc(Nbr_Region * sizeof(double)) ; } val0 = ChangeOfState_P->ActiveList[0] ; val1 = ChangeOfState_P->ActiveList[1] ; /* debug */ if (Type_Analyse == 999 && i_COS == 0 && ChangeOfState_P->Type == CHANGEOFSTATE_CHANGEREFERENCE2) { List_Read(Region_L, 0, &Num_Region) ; Current.Region = Num_Region ; Get_DofOfRegion(Current.Region, GlobalQuantity_P, FunctionSpace_P, &QuantityStorage_S) ; QuantityStorage_S.FunctionSpace->DofData->CurrentSolution -- ; Save_Time = Current.Time ; Current.Time = QuantityStorage_S.FunctionSpace->DofData->CurrentSolution->Time ; Dof_GetRealDofValue(QuantityStorage_S.FunctionSpace->DofData, QuantityStorage_S.BasisFunction[0].Dof, &Val0_Dof) ; Get_ValueOfExpressionByIndex(ChangeOfState_P->ExpressionIndex, NULL, 0., 0., 0., &Value) ; Val0_Ref = Value.Val[0] ; Current.Time = Save_Time ; QuantityStorage_S.FunctionSpace->DofData->CurrentSolution ++ ; Dof_GetRealDofValue(QuantityStorage_S.FunctionSpace->DofData, QuantityStorage_S.BasisFunction[0].Dof, &Val1_Dof) ; Get_ValueOfExpressionByIndex(ChangeOfState_P->ExpressionIndex, NULL, 0., 0., 0., &Value) ; Val1_Ref = Value.Val[0] ; Val1_E = (Val1_Ref - v_k * Val1_Dof) * v_ke ; Val0_E = (Val0_Ref - v_k * Val0_Dof) * v_ke ; Val_S = Val1_E + (Val1_E-Val0_E)/Current.DTime / (TWO_PI*v_fz) ; /* fprintf(FilePWM, "%.16g %g %g", Current.Time, Val1_E, Val_S) ; */ Val_S += Val1_Ref ; if (Val_S > v_sat) Val_S = v_sat ; else if (Val_S < -v_sat) Val_S = -v_sat ; /* fprintf(FilePWM, " %g %g\n", Val_S, ((struct Expression *) List_Pointer(Problem_S.Expression, ChangeOfState_P->FlagIndex)) ->Case.Constant ) ; fflush(FilePWM) ; */ break ; } /* else if (Type_Analyse == 999 && i_COS > 0) break ; */ /* ----- */ /* C a l c u l v a l e u r s . . . */ for (i = 0 ; i < Nbr_Region ; i++) { List_Read(Region_L, i, &Num_Region) ; Current.Region = Num_Region ; if (DefineQuantity_P->Type == GLOBALQUANTITY) { Get_DofOfRegion(Current.Region, GlobalQuantity_P, FunctionSpace_P, &QuantityStorage_S) ; switch (Type_Analyse) { case COMPARE_CHANGE : /* Compare values at times t-dt and t */ Dof_GetRealDofValue(QuantityStorage_S.FunctionSpace->DofData, QuantityStorage_S.BasisFunction[0].Dof, &Val1_Dof) ; switch (ChangeOfState_P->Type) { case CHANGEOFSTATE_CHANGESIGN : case CHANGEOFSTATE_CHANGELEVEL : QuantityStorage_S.FunctionSpace->DofData->CurrentSolution -- ; Dof_GetRealDofValue(QuantityStorage_S.FunctionSpace->DofData, QuantityStorage_S.BasisFunction[0].Dof, &Val0_Dof) ; QuantityStorage_S.FunctionSpace->DofData->CurrentSolution ++ ; break ; case CHANGEOFSTATE_CHANGEREFERENCE : Get_ValueOfExpressionByIndex(ChangeOfState_P->ExpressionIndex, NULL, 0., 0., 0., &Value) ; Val0_Dof = Value.Val[0] ; break ; case CHANGEOFSTATE_CHANGEREFERENCE2 : QuantityStorage_S.FunctionSpace->DofData->CurrentSolution -- ; Save_Time = Current.Time ; Current.Time = QuantityStorage_S.FunctionSpace->DofData->CurrentSolution->Time ; Dof_GetRealDofValue(QuantityStorage_S.FunctionSpace->DofData, QuantityStorage_S.BasisFunction[0].Dof, &Val0_Dof) ; Get_ValueOfExpressionByIndex(ChangeOfState_P->ExpressionIndex, NULL, 0., 0., 0., &Value) ; Val0_Ref = Value.Val[0] ; Current.Time = Save_Time ; QuantityStorage_S.FunctionSpace->DofData->CurrentSolution ++ ; Get_ValueOfExpressionByIndex(ChangeOfState_P->ExpressionIndex, NULL, 0., 0., 0., &Value) ; Val1_Ref = Value.Val[0] ; Val1_E = (Val1_Ref - v_k * Val1_Dof) * v_ke ; Val0_E = (Val0_Ref - v_k * Val0_Dof) * v_ke ; Val_S = Val1_E + (Val1_E-Val0_E)/Current.DTime / (TWO_PI*v_fz) ; Val_S += Val1_Ref ; if (Val_S > v_sat) Val_S = v_sat ; else if (Val_S < -v_sat) Val_S = -v_sat ; Val1_Dof = Val_S ; Get_ValueOfExpressionByIndex(ChangeOfState_P->ExpressionIndex2, NULL, 0., 0., 0., &Value) ; Val0_Dof = Value.Val[0] ; break ; } break ; case COMPARE_CONVERGENCE : /* Compare values at time t, for 2 iterations */ Val0_Dof = val1[i] ; Dof_GetRealDofValue(QuantityStorage_S.FunctionSpace->DofData, QuantityStorage_S.BasisFunction[0].Dof, &Val1_Dof) ; break ; } } else Val0_Dof = Val1_Dof = 0. ; val0[i] = Val0_Dof ; val1[i] = Val1_Dof ; } /* for i -> Nbr_Region ... */ /* A n a l y s e v a l e u r s . . . */ switch (Type_Analyse) { case COMPARE_CHANGE : switch (ChangeOfState_P->Type) { case CHANGEOFSTATE_CHANGESIGN : for (i = 0 ; i < Nbr_Region ; i++) { if (val0[i] * val1[i] <= 0.) { *Type_ChangeOfState = CHANGEOFSTATE_CHANGESIGN ; break ; } } break ; case CHANGEOFSTATE_CHANGELEVEL : for (i = 0 ; i < Nbr_Region ; i++) { if (ChangeOfState_P->Criterion > 0) { v0 = fabs(val0[i]) ; v1 = fabs(val1[i]) ; if (((v0 < v1) && (v0*ChangeOfState_P->Criterion < v1)) || ((v0 > v1) && (v1*ChangeOfState_P->Criterion < v0))) { *Type_ChangeOfState = CHANGEOFSTATE_CHANGELEVEL ; break ; } } else { /* New: Absolute change (Criterion < 0) */ v0 = (val0[i]) ; v1 = (val1[i]) ; if ( fabs(v1-v0) > fabs(ChangeOfState_P->Criterion) ) { *Type_ChangeOfState = CHANGEOFSTATE_CHANGELEVEL ; break ; } } } /* Attention: test a affiner ... choix du Criterion ... */ break ; case CHANGEOFSTATE_CHANGEREFERENCE : if (Nbr_Region != 1) Message::Error("More than 1 Region for ChangeReference not done yet") ; for (i = 0 ; i < Nbr_Region ; i++) { if (fabs(val1[i] - val0[i]) > fabs(ChangeOfState_P->Criterion) * ((ChangeOfState_P->Criterion > 0.)? fabs(val0[i]) : 1.)) { *Type_ChangeOfState = ChangeOfState_P->Type ; *FlagIndex = ChangeOfState_P->FlagIndex ; if (val1[i] > val0[i]) *FlagIndex *= -1 ; break ; } } break ; case CHANGEOFSTATE_CHANGEREFERENCE2 : if (Nbr_Region != 1) Message::Error("More than 1 Region for ChangeReference2 not done yet") ; for (i = 0 ; i < Nbr_Region ; i++) { *FlagIndex = ChangeOfState_P->FlagIndex ; if (val1[i] > val0[i]) *FlagIndex *= -1 ; if (((struct Expression *) List_Pointer(Problem_S.Expression, abs(*FlagIndex))) ->Case.Constant != (*FlagIndex > 0)? 1. : 0. ) { *Type_ChangeOfState = ChangeOfState_P->Type ; break ; } } break ; } break ; case COMPARE_CONVERGENCE : Cal_SolutionErrorX(Nbr_Region, val1, val0, &MeanError) ; if (MeanError > 1.e-8) *Type_ChangeOfState = !CHANGEOFSTATE_NOCHANGE ; break ; /* critere a revoir, avant 1.e-14 */ } if (*Type_ChangeOfState != CHANGEOFSTATE_NOCHANGE) break ; } /* if Nbr_Region > 0 ... */ } /* for i_COS ... */ /* Attention: d e b u g (fprintf)*/ if ((Type_Analyse == COMPARE_CHANGE && (*Type_ChangeOfState != CHANGEOFSTATE_NOCHANGE || !Flag_First)) || (Type_Analyse == COMPARE_CONVERGENCE)) { if (Flag_First) { for (i = 0 ; i < Nbr_Region ; i++) { List_Read(Region_L, i, &Num_Region) ; Message::Debug(" %10d",Num_Region) ; } for (i = 0 ; i < Nbr_Region ; i++) Message::Debug(" %.8g", val0[i]) ; } for (i = 0 ; i < Nbr_Region ; i++) Message::Debug(" %.8g", val1[i]) ; Message::Debug(" t = %.16g, dt = %.16g", Current.Time, Current.DTime) ; if (*Type_ChangeOfState == CHANGEOFSTATE_CHANGESIGN) Message::Debug(" *Sign") ; else if (*Type_ChangeOfState == CHANGEOFSTATE_CHANGELEVEL) Message::Debug(" *Level") ; else if (*Type_ChangeOfState == CHANGEOFSTATE_CHANGEREFERENCE) Message::Debug(" *Ref (%g %g)", val0[0]-fabs(ChangeOfState_P->Criterion), val0[0]+fabs(ChangeOfState_P->Criterion)) ; else if (*Type_ChangeOfState == CHANGEOFSTATE_CHANGEREFERENCE2) Message::Debug(" *Ref2 (%g)", val0[0]) ; } } /* ------------------------------------------------------------------------ */ /* O p e r a t i o n _ I t e r a t i v e T i m e R e d u c t i o n */ /* ------------------------------------------------------------------------ */ void Operation_IterativeTimeReduction(struct Resolution * Resolution_P, struct Operation * Operation_P, struct DofData * DofData_P0, struct GeoData * GeoData_P0) { int Num_Iteration, i ; int Type_ChangeOfState, Flag_TimeLimLo, Type_LimitHi, FlagIndex ; double Time_Previous, DTime0, DTime1 ; double Time_LimitLo, DTime_LimitLo, Time_LimitHi ; struct Solution * Solution_P ; struct Expression * Expression_P ; #define TIMELO_OLD 0 #define TIMELO_NEW 1 Time_Previous = Current.Time - Current.DTime ; DTime0 = 0. ; DTime1 = Current.DTime ; Flag_TimeLimLo = TIMELO_OLD ; Time_LimitLo = Time_Previous ; DTime_LimitLo = Current.DTime ; Message::Debug("T I M E %g (TS #%d, DT %g, Theta %g)", Current.Time, (int)Current.TimeStep, Current.DTime, Current.Theta) ; Current.SubTimeStep = 0 ; Treatment_Operation(Resolution_P, Operation_P->Case.IterativeTimeReduction.Operation, DofData_P0, GeoData_P0, NULL, NULL) ; Cal_CompareGlobalQuantity(Operation_P, COMPARE_CHANGE, &Type_ChangeOfState, &FlagIndex, 1) ; if (Type_ChangeOfState == CHANGEOFSTATE_NOCHANGE) { Treatment_Operation(Resolution_P, Operation_P->Case.IterativeTimeReduction.OperationEnd, DofData_P0, GeoData_P0, NULL, NULL) ; /* debug */ Cal_CompareGlobalQuantity (Operation_P, 999, &Type_ChangeOfState, &FlagIndex, 1) ; return ; } Time_LimitHi = Current.Time ; /* Sera initialise correctement par apres. */ Type_LimitHi = Type_ChangeOfState ; /* Mais boin, c'est pour la rigueur */ /* Recherche de l'intervalle de temps [Time_LimitLo, Time_LimitHi] < Criterion sur lequel un changement d'etat de grandeurs globales specifiees a lieu (e.g. utilisation pour les circuits avec diodes et thyristors) */ for (Num_Iteration = 1 ; Num_Iteration <= Operation_P->Case.IterativeTimeReduction.NbrMaxIteration ; Num_Iteration++) { if (Type_ChangeOfState == CHANGEOFSTATE_NOCHANGE) { Flag_TimeLimLo = TIMELO_NEW ; Time_LimitLo = Current.Time ; DTime_LimitLo = Current.DTime ; } else { Time_LimitHi = Current.Time ; Type_LimitHi = Type_ChangeOfState ; } if (Time_LimitHi - Time_LimitLo < Operation_P->Case.IterativeTimeReduction.Criterion) { if (Type_ChangeOfState != CHANGEOFSTATE_NOCHANGE) { if (!(Flag_TimeLimLo == TIMELO_OLD && Type_ChangeOfState == CHANGEOFSTATE_CHANGELEVEL) && !(Flag_TimeLimLo == TIMELO_OLD)) { Solution_P = (struct Solution *) List_Pointer(Current.DofData->Solutions, List_Nbr(Current.DofData->Solutions)-1) ; LinAlg_DestroyVector(&Solution_P->x) ; Free(Solution_P->TimeFunctionValues) ; Solution_P->SolutionExist = 0 ; List_Pop(Current.DofData->Solutions) ; /* Attention: a changer ! */ } if (Flag_TimeLimLo == TIMELO_NEW) { /* Recalcul en Time_LimitLo */ /* Attention: a changer... plutot recuperer solution en Time_LimitLo... */ Message::Debug("==> Re-calculation at Time_LimitLo ... (%.16g)", Time_LimitLo) ; Current.Time = Time_LimitLo ; Current.DTime = DTime_LimitLo ; Current.SubTimeStep++ ; Treatment_Operation(Resolution_P, Operation_P->Case.IterativeTimeReduction.Operation, DofData_P0, GeoData_P0, NULL, NULL) ; } } if (Flag_TimeLimLo == TIMELO_NEW || (Flag_TimeLimLo == TIMELO_OLD && Type_ChangeOfState == CHANGEOFSTATE_CHANGELEVEL)) { Treatment_Operation(Resolution_P, Operation_P->Case.IterativeTimeReduction.OperationEnd, DofData_P0, GeoData_P0, NULL, NULL) ; /* debug */ Cal_CompareGlobalQuantity (Operation_P, 999, &Type_ChangeOfState, &FlagIndex, 1) ; } if (Type_LimitHi == CHANGEOFSTATE_CHANGESIGN || Type_LimitHi == CHANGEOFSTATE_CHANGEREFERENCE || Type_LimitHi == CHANGEOFSTATE_CHANGEREFERENCE2) { if (Flag_TimeLimLo == TIMELO_NEW) Current.TimeStep += 1. ; if (Type_LimitHi == CHANGEOFSTATE_CHANGEREFERENCE || Type_LimitHi == CHANGEOFSTATE_CHANGEREFERENCE2) { Expression_P = (struct Expression *) List_Pointer(Problem_S.Expression, abs(FlagIndex)) ; Expression_P->Case.Constant = (FlagIndex > 0)? 1. : 0. ; /* Expression_P->Case.Constant = (double)(!((int)Expression_P->Case.Constant)) ; */ Message::Debug("===> Flag -> %g", Expression_P->Case.Constant) ; } if (Operation_P->Case.IterativeTimeReduction.Flag) Current.Theta = 1. ; /* New: Theta is also changed for this time ! OK because dt is then very small also in this case ! */ Current.Time = Time_LimitHi ; Current.DTime = Time_LimitHi - Time_LimitLo ; Current.SubTimeStep++ ; Message::Debug("==> iterations for TimeHi ...") ; i = 0 ; do { i ++ ; Treatment_Operation(Resolution_P, Operation_P->Case.IterativeTimeReduction.Operation, DofData_P0, GeoData_P0, NULL, NULL) ; Cal_CompareGlobalQuantity (Operation_P, COMPARE_CONVERGENCE, &Type_ChangeOfState, &FlagIndex, 0) ; } while ((Flag_TimeLimLo == TIMELO_NEW && i == 1) || (Type_ChangeOfState != CHANGEOFSTATE_NOCHANGE && i < 9)) ; /* Attention: critere (NbrMax 9) a revoir */ Treatment_Operation(Resolution_P, Operation_P->Case.IterativeTimeReduction.OperationEnd, DofData_P0, GeoData_P0, NULL, NULL) ; /* debug */ Cal_CompareGlobalQuantity (Operation_P, 999, &Type_ChangeOfState, &FlagIndex, 1) ; if (Operation_P->Case.IterativeTimeReduction.Flag) { /* Attention: Test */ Message::Debug("=====> Theta = %g -> 1.", Current.Theta) ; Flag_NextThetaFixed = 1 ; Current.Theta = 1. ; if (Operation_P->Case.IterativeTimeReduction.Flag > 0) { Current.DTime *= (double)Operation_P->Case.IterativeTimeReduction.Flag ; Flag_NextThetaFixed = 2 ; /* Theta is fixed, DTime is also fixed */ } } } break ; /* Out of loop 'for Num_Iteration' */ } /* if Time_LimitHi - Time_LimitLo << ... */ if (Operation_P->Case.IterativeTimeReduction.DivisionCoefficient > 0.) { if (Type_ChangeOfState == CHANGEOFSTATE_NOCHANGE) DTime0 += DTime1 ; DTime1 /= Operation_P->Case.IterativeTimeReduction.DivisionCoefficient ; } else { /* Technique de Pkp ... "un peu trop prudente" */ if (Type_ChangeOfState == CHANGEOFSTATE_NOCHANGE) DTime0 += DTime1 ; else DTime1 /= fabs(Operation_P->Case.IterativeTimeReduction.DivisionCoefficient) ; } Current.DTime = DTime0 + DTime1 ; Current.Time = Time_Previous + Current.DTime ; Current.SubTimeStep++ ; Solution_P = (struct Solution *) List_Pointer(Current.DofData->Solutions, List_Nbr(Current.DofData->Solutions)-1) ; LinAlg_DestroyVector(&Solution_P->x) ; Free(Solution_P->TimeFunctionValues) ; Solution_P->SolutionExist = 0 ; List_Pop(Current.DofData->Solutions) ; /* Attention: a changer ! */ Treatment_Operation(Resolution_P, Operation_P->Case.IterativeTimeReduction.Operation, DofData_P0, GeoData_P0, NULL, NULL) ; Cal_CompareGlobalQuantity(Operation_P, COMPARE_CHANGE, &Type_ChangeOfState, &FlagIndex, 0) ; } /* for Num_Iteration ... */ } getdp-2.4.2-source/Legacy/Gauss_Quadrangle.cpp000644 001750 001750 00000005356 12116424202 022740 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "Gauss.h" #include "Gauss_Quadrangle.h" #include "Message.h" #include "MallocUtils.h" /* Classic Gauss Integration over a quadrangle */ void Gauss_Quadrangle (int Nbr_Points, int Num, double *u, double *v, double *w, double *wght) { switch (Nbr_Points) { case 3 : *u= xq3 [Num] ; *v= yq3 [Num] ; *w= 0. ; *wght= pq3 [Num] ; break ; case 4 : *u= xq4 [Num] ; *v= yq4 [Num] ; *w= 0. ; *wght= pq4 [Num] ; break ; case 7 : *u= xq7 [Num] ; *v= yq7 [Num] ; *w= 0. ; *wght= pq7 [Num] ; break ; default : Message::Error("Wrong number of Gauss points for Quadrangle: " "valid choices: 3, 4, 7"); break; } } /* Gauss-Legendre scheme to integrate over a quadrangle */ static int glq[MAX_LINE_POINTS] = {-1}; static double *glxq[MAX_LINE_POINTS], *glyq[MAX_LINE_POINTS], *glpq[MAX_LINE_POINTS]; void GaussLegendre_Quadrangle(int Nbr_Points, int Num, double *u, double *v, double *w, double *wght) { int i, j, index = 0, nb; double pt1, pt2, wt1, wt2, dum; nb = (int)sqrt((double)Nbr_Points); if(nb * nb != Nbr_Points || nb > MAX_LINE_POINTS){ Message::Error("Number of points should be n^2 with n in [1,%d]", MAX_LINE_POINTS) ; return; } if(glq[0] < 0) for(i = 0; i < MAX_LINE_POINTS; i++) glq[i] = 0; if(!glq[nb - 1]){ Message::Info("Computing GaussLegendre %dX%d for Quadrangle", nb, nb); glxq[nb - 1] = (double*)Malloc(Nbr_Points * sizeof(double)); glyq[nb - 1] = (double*)Malloc(Nbr_Points * sizeof(double)); glpq[nb - 1] = (double*)Malloc(Nbr_Points * sizeof(double)); for(i = 0; i < nb; i++) { Gauss_Line(nb, i, &pt1, &dum, &dum, &wt1); for(j = 0; j < nb; j++) { Gauss_Line(nb, j, &pt2, &dum, &dum, &wt2); glxq[nb - 1][index] = pt1; glyq[nb - 1][index] = pt2; glpq[nb - 1][index++] = wt1*wt2; } } glq[nb - 1] = 1; } *u = glxq[nb - 1][Num] ; *v = glyq[nb - 1][Num] ; *w = 0. ; *wght = glpq[nb - 1][Num] ; } /* Gauss Integration over a quadrangle with a 1/R singularity over node (-1,-1,0) */ void GaussSingularR_Quadrangle(int Nbr_Points, int Num, double *u, double *v, double *w, double *wght) { switch (Nbr_Points) { case 1 : *u= xqs1 [Num] ; *v= yqs1 [Num] ; *w= 0. ; *wght= pqs1 [Num] ; break ; case 3 : *u= xqs3 [Num] ; *v= yqs3 [Num] ; *w= 0. ; *wght= pqs3 [Num] ; break ; case 4 : *u= xqs4 [Num] ; *v= yqs4 [Num] ; *w= 0. ; *wght= pqs4 [Num] ; break ; default : Message::Error("Wrong number of (modified) Gauss Points for Quadrangle: " "valid choices: 1, 3, 4"); break; } } getdp-2.4.2-source/Legacy/BF_Volume.cpp000644 001750 001750 00000004435 12116424202 021326 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "ProData.h" #include "Message.h" /* ------------------------------------------------------------------------ */ /* B F _ V o l u m e */ /* ------------------------------------------------------------------------ */ #define WrongNumVolume Message::Error("Wrong Volume number in 'BF_Volume'") void BF_Volume(struct Element * Element, int NumVolume, double u, double v, double w, double *s) { switch (Element->Type) { case POINT : switch(NumVolume) { case 1 : *s = 1. ; break ; default : WrongNumVolume ; } break ; case LINE : switch(NumVolume) { case 1 : *s = 0.5 ; break ; default : WrongNumVolume ; } break ; case TRIANGLE : switch(NumVolume) { case 1 : *s = 2. ; break ; default : WrongNumVolume ; } break ; case QUADRANGLE : switch(NumVolume) { case 1 : *s = 0.25 ; break ; default : WrongNumVolume ; } break ; case TETRAHEDRON : switch(NumVolume) { case 1 : *s = 6. ; break ; default : WrongNumVolume ; } break ; case HEXAHEDRON : switch(NumVolume) { case 1 : *s = 0.125 ; break ; default : WrongNumVolume ; } break ; case PRISM : switch(NumVolume) { case 1 : *s = 1. ; break ; default : WrongNumVolume ; } break ; case PYRAMID : switch(NumVolume) { case 1 : *s = 3./4. ; break ; default : WrongNumVolume ; } break ; default : Message::Error("Unkown type of Element in BF_Volume"); break ; } } #undef WrongNumVolume void BF_VolumeX(struct Element * Element, int NumVolume, double u, double v, double w, double *s) { s[1] = s[2] = 0.; BF_Volume (Element, NumVolume, u, v, w, &s[0]) ; } void BF_VolumeY(struct Element * Element, int NumVolume, double u, double v, double w, double *s) { s[0] = s[2] = 0.; BF_Volume (Element, NumVolume, u, v, w, &s[1]) ; } void BF_VolumeZ(struct Element * Element, int NumVolume, double u, double v, double w, double *s) { s[0] = s[1] = 0.; BF_Volume (Element, NumVolume, u, v, w, &s[2]) ; } getdp-2.4.2-source/Legacy/Cal_AnalyticIntegration.h000644 001750 001750 00000000701 12116424202 023674 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _CAL_ANALYTIC_INTEGRATION_H_ #define _CAL_ANALYTIC_INTEGRATION_H_ #include "ProData.h" double Cal_AnalyticIntegration(struct Element * E, void (*BFEqu)(), void (*BFDof)(), int i, int j, double (*Cal_Productx)()); #endif getdp-2.4.2-source/Legacy/F_Interpolation.cpp000644 001750 001750 00000041576 12221300353 022610 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "ProData.h" #include "F.h" #include "MallocUtils.h" #include "Message.h" extern struct CurrentData Current ; /* ------------------------------------------------------------------------ */ /* Interpolation */ /* ------------------------------------------------------------------------ */ void F_InterpolationLinear(F_ARG) { int N, up, lo ; double xp, yp = 0., *x, *y, a ; struct FunctionActive * D ; if (!Fct->Active) Fi_InitListXY (Fct, A, V) ; D = Fct->Active ; N = D->Case.Interpolation.NbrPoint ; x = D->Case.Interpolation.x ; y = D->Case.Interpolation.y ; xp = A->Val[0] ; if (xp < x[0]) { Message::Error("Bad argument for linear interpolation (%g < %g)", xp, x[0]) ; } else if (xp > x[N-1]) { a = (y[N-1] - y[N-2]) / (x[N-1] - x[N-2]) ; yp = y[N-1] + ( xp - x[N-1] ) * a ; } else { up = 0 ; while (x[++up] < xp){} ; lo = up - 1 ; a = (y[up] - y[lo]) / (x[up] - x[lo]) ; yp = y[up] + ( xp - x[up] ) * a ; } if (Current.NbrHar == 1) V->Val[0] = yp ; else if (Current.NbrHar == 2) { V->Val[0] = yp ; V->Val[1] = 0. ; } else { Message::Error("Function 'Interpolation' not valid for Complex"); } V->Type = SCALAR ; } void F_dInterpolationLinear(F_ARG) { int N, up, lo ; double xp, dyp = 0., *x, *y ; struct FunctionActive * D ; if (!Fct->Active) Fi_InitListXY (Fct, A, V) ; D = Fct->Active ; N = D->Case.Interpolation.NbrPoint ; x = D->Case.Interpolation.x ; y = D->Case.Interpolation.y ; xp = A->Val[0] ; if (xp < x[0]) { Message::Error("Bad argument for linear Interpolation (%g < %g)", xp, x[0]) ; } else if (xp > x[N-1]) { dyp = (y[N-1] - y[N-2]) / (x[N-1] - x[N-2]) ; } else { up = 0 ; while (x[++up] < xp){} ; lo = up - 1 ; dyp = (y[up] - y[lo]) / (x[up] - x[lo]) ; } if (Current.NbrHar == 1) V->Val[0] = dyp ; else if (Current.NbrHar == 2) { V->Val[0] = dyp ; V->Val[1] = 0. ; } else { Message::Error("Function 'dInterpolation' not valid for Complex"); } V->Type = SCALAR ; } void F_dInterpolationLinear2(F_ARG) { int N, up, lo ; double xp, yp = 0., *x, *y, a ; struct FunctionActive * D ; if (!Fct->Active) { Fi_InitListXY (Fct, A, V) ; Fi_InitListXY2 (Fct, A, V) ; } D = Fct->Active ; N = D->Case.Interpolation.NbrPoint ; x = D->Case.Interpolation.xc ; y = D->Case.Interpolation.yc ; xp = A->Val[0] ; if (xp < x[0]) { Message::Error("Bad argument for linear interpolation (%g < %g)", xp, x[0]) ; } else if (xp > x[N-1]) { a = (y[N-1] - y[N-2]) / (x[N-1] - x[N-2]) ; yp = y[N-1] + ( xp - x[N-1] ) * a ; } else { up = 0 ; while (x[++up] < xp){} ; lo = up - 1 ; a = (y[up] - y[lo]) / (x[up] - x[lo]) ; yp = y[up] + ( xp - x[up] ) * a ; } if (Current.NbrHar == 1) V->Val[0] = yp ; else if (Current.NbrHar == 2) { V->Val[0] = yp ; V->Val[1] = 0. ; } else { Message::Error("Function 'dInterpolation' not valid for Complex"); } V->Type = SCALAR ; } void F_InterpolationAkima(F_ARG) { // Third order interpolation with slope control int N, up, lo ; double xp, yp = 0., *x, *y, a, a2, a3 ; struct FunctionActive * D ; if (!Fct->Active) { Fi_InitListXY (Fct, A, V) ; Fi_InitAkima (Fct, A, V) ; } D = Fct->Active ; N = D->Case.Interpolation.NbrPoint ; x = D->Case.Interpolation.x ; y = D->Case.Interpolation.y ; xp = A->Val[0] ; if (xp < x[0]) { Message::Error("Bad argument for linear interpolation (%g < %g)", xp, x[0]) ; } else if (xp > x[N-1]) { a = (y[N-1] - y[N-2]) / (x[N-1] - x[N-2]) ; yp = y[N-1] + ( xp - x[N-1] ) * a ; } else { up = 0 ; while (x[++up] < xp){} ; lo = up - 1 ; a = xp - x[lo] ; a2 = a*a ; a3 = a2*a ; yp = y[lo] + D->Case.Interpolation.bi[lo] * a + D->Case.Interpolation.ci[lo] * a2 + D->Case.Interpolation.di[lo] * a3 ; } if (Current.NbrHar == 1) V->Val[0] = yp ; else if (Current.NbrHar == 2) { V->Val[0] = yp ; V->Val[1] = 0. ; } else { Message::Error("Function 'Interpolation' not valid for Complex"); } V->Type = SCALAR ; } void F_dInterpolationAkima(F_ARG) { int N, up, lo ; double xp, dyp = 0., *x, *y, a, a2 ; struct FunctionActive * D ; if (!Fct->Active) { Fi_InitListXY (Fct, A, V) ; Fi_InitAkima (Fct, A, V) ; } D = Fct->Active ; N = D->Case.Interpolation.NbrPoint ; x = D->Case.Interpolation.x ; y = D->Case.Interpolation.y ; xp = A->Val[0] ; if (xp < x[0]) { Message::Error("Bad argument for linear interpolation (%g < %g)", xp, x[0]) ; } else if (xp > x[N-1]) { dyp = (y[N-1] - y[N-2]) / (x[N-1] - x[N-2]) ; } else { up = 0 ; while (x[++up] < xp){} ; lo = up - 1 ; a = xp - x[lo] ; a2 = a*a ; dyp = D->Case.Interpolation.bi[lo] + D->Case.Interpolation.ci[lo] * 2. * a + D->Case.Interpolation.di[lo] * 3. * a2 ; } if (Current.NbrHar == 1) V->Val[0] = dyp ; else if (Current.NbrHar == 2) { V->Val[0] = dyp ; V->Val[1] = 0. ; } else { Message::Error("Function 'dInterpolation' not valid for Complex"); } V->Type = SCALAR ; } bool Fi_InterpolationBilinear(double *x, double *y, double *M, int NL, int NC, double xp, double yp, double *zp) { double a11, a12, a21, a22; int i, j; // Interpolate point (xp,yp) in a regular grid // x[i] <= xp < x[i+1] // y[j] <= yp < y[j+1] *zp = 0.0 ; // When (xp,yp) lays outside the boundaries of the table: // the nearest border is taken if (xp < x[0]) xp = x[0]; else if (xp > x[NL-1]) xp = x[NL-1]; for (i=0 ; i= xp && xp >= x[i]) break; i = (i >= NL) ? NL-1 : i; if (yp < y[0]) yp = y[0]; else if (yp > y[NC-1]) yp = y[NC-1]; for (j=0 ; j= yp && yp >= y[j]) break; j = (j >= NC) ? NC-1 : j; a11 = M[ i + NL * j ]; a21 = M[(i+1) + NL * j ]; a12 = M[ i + NL * (j+1)]; a22 = M[(i+1) + NL * (j+1)]; *zp = 1/((x[i+1]-x[i])*(y[j+1]-y[j])) * ( a11 * ( x[i+1]-xp) * ( y[j+1]-yp) + a21 * (-x[i ]+xp) * ( y[j+1]-yp) + a12 * ( x[i+1]-xp) * (-y[j ]+yp) + a22 * (-x[i ]+xp) * (-y[j ]+yp) ); return true ; } bool Fi_dInterpolationBilinear(double *x, double *y, double *M, int NL, int NC, double xp, double yp, double *dzp_dx, double *dzp_dy) { double a11, a12, a21, a22; int i, j; // When (xp,yp) lays outside the boundaries of the table: // the nearest border is taken if (xp < x[0]) xp = x[0]; else if (xp > x[NL-1]) xp = x[NL-1]; for (i=0 ; i= xp && xp >= x[i]) break; i = (i >= NL) ? NL-1 : i; if (yp < y[0]) yp = y[0]; else if (yp > y[NC-1]) yp = y[NC-1]; for (j=0 ; j= yp && yp >= y[j]) break; j = (j >= NC) ? NC-1 : j; a11 = M[ i + NL * j ]; a21 = M[(i+1) + NL * j ]; a12 = M[ i + NL * (j+1)]; a22 = M[(i+1) + NL * (j+1)]; *dzp_dx = 1/((x[i+1]-x[i])*(y[j+1]-y[j])) * ( (a21-a11) * ( y[j+1]-yp) + (a22-a12) * (-y[j ]+yp) ); *dzp_dy = 1/((x[i+1]-x[i])*(y[j+1]-y[j])) * ( (a12-a11) * ( x[i+1]-xp) + (a22-a21) * (-x[i ]+xp) ); return true ; } void F_InterpolationBilinear(F_ARG) { /* It performs a bilinear interpolation at point (xp,yp) based on a two-dimensional table (sorted grid). Input parameters: NL Number of lines NC Number of columns x values (ascending order) linked to the NL lines of the table y values (ascending order) linked to the NC columns of the table M Matrix M(x,y) = M[x+NL*y] xp x coordinate of interpolation point yp y coordinate of interpolation point R. Scorretti */ int NL, NC; double xp, yp, zp = 0., *x, *y, *M; struct FunctionActive * D; if( (A+0)->Type != SCALAR || (A+1)->Type != SCALAR) Message::Error("Two Scalar arguments required!"); if (!Fct->Active) Fi_InitListMatrix (Fct, A, V) ; D = Fct->Active ; NL = D->Case.ListMatrix.NbrLines ; NC = D->Case.ListMatrix.NbrColumns ; x = D->Case.ListMatrix.x ; y = D->Case.ListMatrix.y ; M = D->Case.ListMatrix.data ; xp = (A+0)->Val[0] ; yp = (A+1)->Val[0] ; bool IsInGrid = Fi_InterpolationBilinear (x, y, M, NL, NC, xp, yp, &zp); if (!IsInGrid) Message::Error("Extrapolation not allowed (xp=%g ; yp=%g)", xp, yp) ; V->Type = SCALAR ; V->Val[0] = zp ; } void F_dInterpolationBilinear(F_ARG) { /* It delivers the derivative of the bilinear interpolation at point (xp, yp) based on a two-dimensional table (sorted grid). Input parameters: NL Number of lines NC Number of columns x values (ascending order) linked to the NL lines of the table y values (ascending order) linked to the NC columns of the table M Matrix M(x,y) = M[x+NL*y] xp x coordinate of interpolation point yp y coordinate of interpolation point */ int NL, NC; double xp, yp, dzp_dx = 0., dzp_dy = 0., *x, *y, *M; struct FunctionActive * D; if( (A+0)->Type != SCALAR || (A+1)->Type != SCALAR) Message::Error("Two Scalar arguments required!"); if (!Fct->Active) Fi_InitListMatrix (Fct, A, V) ; D = Fct->Active ; NL = D->Case.ListMatrix.NbrLines ; NC = D->Case.ListMatrix.NbrColumns ; x = D->Case.ListMatrix.x ; y = D->Case.ListMatrix.y ; M = D->Case.ListMatrix.data ; xp = (A+0)->Val[0] ; yp = (A+1)->Val[0] ; bool IsInGrid = Fi_dInterpolationBilinear (x, y, M, NL, NC, xp, yp, &dzp_dx, &dzp_dy); if (!IsInGrid) Message::Error("Extrapolation not allowed (xp=%g ; yp=%g)", xp, yp) ; V->Type = VECTOR ; V->Val[0] = dzp_dx ; V->Val[1] = dzp_dy ; V->Val[2] = 0. ; } void Fi_InitListMatrix(F_ARG) { int i=0, k, NL, NC, sz ; struct FunctionActive * D ; /* The original table structure: | y(1) y(2) ... y(NC) ------+-------------------------------------------- x(1) | data(1) data(NL+1) ... . x(2) | data(2) data(NL+2) . . . . . . . . x(NL) | data(NL) data(2*NL) ... data(NL*NC) is furnished with the following format: [ NL, NC, x(1..NL), y(1..NC), data(1..NL*NC) ] R. Scorretti */ D = Fct->Active = (struct FunctionActive *)Malloc(sizeof(struct FunctionActive)) ; NL = Fct->Para[i++]; NC = Fct->Para[i++]; sz = 2 + NL + NC + NL*NC ; // expected size of list matrix if (Fct->NbrParameters != sz) Message::Error("Bad size of input data (expected = %d ; found = %d). " "List with format: x(NbrLines=%d), y(NbrColumns=%d), " "matrix(NbrLines*NbrColumns=%d)", sz, Fct->NbrParameters, NL, NC, NL*NC); // Initialize structure and allocate memory D->Case.ListMatrix.NbrLines = NL; D->Case.ListMatrix.NbrColumns = NC; D->Case.ListMatrix.x = (double *) malloc (sizeof(double)*NL); D->Case.ListMatrix.y = (double *) malloc (sizeof(double)*NC); D->Case.ListMatrix.data = (double *) malloc (sizeof(double)*NL*NC); // Assign values for (k=0 ; kCase.ListMatrix.x[k] = Fct->Para[i++]; for (k=0 ; kCase.ListMatrix.y[k] = Fct->Para[i++]; for (k=0 ; kCase.ListMatrix.data[k] = Fct->Para[i++]; } void Fi_InitListX(F_ARG) { int i, N ; double *x ; struct FunctionActive * D ; D = Fct->Active = (struct FunctionActive *)Malloc(sizeof(struct FunctionActive)) ; N = D->Case.Interpolation.NbrPoint = Fct->NbrParameters ; x = D->Case.Interpolation.x = (double *)Malloc(sizeof(double)*N) ; for (i = 0 ; i < N ; i++) x[i] = Fct->Para[i] ; } void Fi_InitListXY(F_ARG) { int i, N ; double *x, *y ; struct FunctionActive * D ; D = Fct->Active = (struct FunctionActive *)Malloc(sizeof(struct FunctionActive)) ; N = D->Case.Interpolation.NbrPoint = Fct->NbrParameters / 2 ; x = D->Case.Interpolation.x = (double *)Malloc(sizeof(double)*N) ; y = D->Case.Interpolation.y = (double *)Malloc(sizeof(double)*N) ; for (i = 0 ; i < N ; i++) { x[i] = Fct->Para[i*2 ] ; y[i] = Fct->Para[i*2+1] ; } } void Fi_InitListXY2(F_ARG) { int i, N ; double *x, *y, *xc, *yc ; struct FunctionActive * D ; D = Fct->Active ; N = D->Case.Interpolation.NbrPoint ; x = D->Case.Interpolation.x ; y = D->Case.Interpolation.y ; xc = D->Case.Interpolation.xc = (double *)Malloc(sizeof(double)*N) ; yc = D->Case.Interpolation.yc = (double *)Malloc(sizeof(double)*N) ; xc[0] = 0. ; yc[0] = (x[1]*y[1]-x[0]*y[0]) / (x[1]*x[1]-x[0]*x[0]) ; for (i = 1 ; i < N ; i++) { xc[i] = 0.5 * (x[i]+x[i-1]) ; yc[i] = (x[i]*y[i]-x[i-1]*y[i-1]) / (x[i]*x[i]-x[i-1]*x[i-1]) ; /* xc[i] = x[i] ; yc[i] = (y[i]-y[i-1]) / (x[i]-x[i-1]) ; */ } } void Fi_InitAkima(F_ARG) { int i, N ; double *x, *y, *mi, *bi, *ci, *di, a ; struct FunctionActive * D ; D = Fct->Active ; N = D->Case.Interpolation.NbrPoint ; x = D->Case.Interpolation.x ; y = D->Case.Interpolation.y ; mi = D->Case.Interpolation.mi = (double *)Malloc(sizeof(double)*(N+4)) ; mi += 2 ; bi = D->Case.Interpolation.bi = (double *)Malloc(sizeof(double)*N) ; ci = D->Case.Interpolation.ci = (double *)Malloc(sizeof(double)*N) ; di = D->Case.Interpolation.di = (double *)Malloc(sizeof(double)*N) ; for (i = 0 ; i < N-1 ; i++) mi[i] = (y[i+1]-y[i]) / (x[i+1]-x[i]) ; mi[N-1] = 2.*mi[N-2] - mi[N-3] ; mi[N ] = 2.*mi[N-1] - mi[N-2] ; mi[ -1] = 2.*mi[ 0] - mi[ 1] ; mi[ -2] = 2.*mi[ -1] - mi[ 0] ; for (i = 0 ; i < N ; i++) if ( (a = fabs(mi[i+1]-mi[i]) + fabs(mi[i-1]-mi[i-2])) > 1.e-30 ) bi[i] = ( fabs(mi[i+1]-mi[i]) * mi[i-1] + fabs(mi[i-1]-mi[i-2]) * mi[i] ) / a ; else bi[i] = (mi[i] + mi[i-1]) / 2. ; for (i = 0 ; i < N-1 ; i++) { a = (x[i+1]-x[i]) ; ci[i] = ( 3.*mi[i] - 2.*bi[i] - bi[i+1] ) / a ; di[i] = ( bi[i] + bi[i+1] - 2.*mi[i] ) / (a*a) ; } } struct IntDouble { int Int; double Double; } ; struct IntVector { int Int; double Double[3]; } ; void F_ValueFromIndex (F_ARG) { struct FunctionActive * D ; struct IntDouble * IntDouble_P; if (!Fct->Active) Fi_InitValueFromIndex (Fct, A, V) ; D = Fct->Active ; IntDouble_P = (struct IntDouble *) List_PQuery(D->Case.ValueFromIndex.Table, &Current.NumEntity, fcmp_int); if (!IntDouble_P) Message::Error("Unknown Entity Index (%d) in ValueFromIndex Table", Current.NumEntity); /* printf("==> search %d --> found %g\n", Current.NumEntity, IntDouble_P->Double); */ V->Val[0] = IntDouble_P->Double ; V->Type = SCALAR ; } void F_VectorFromIndex(F_ARG) { struct FunctionActive * D ; struct IntVector * IntVector_P; if (!Fct->Active) Fi_InitVectorFromIndex (Fct, A, V) ; D = Fct->Active ; /* printf("%d \n", List_Nbr(D->Case.ValueFromIndex.Table)); */ if (List_Nbr(D->Case.ValueFromIndex.Table)){ IntVector_P = (struct IntVector *) List_PQuery(D->Case.ValueFromIndex.Table, &Current.NumEntity, fcmp_int); /* if (!IntVector_P) Message::Error("Unknown Entity Index in VectorFromIndex Table"); printf("==> search %d --> found %g\n", Current.NumEntity, IntVector_P->Double); */ V->Val[0] = IntVector_P->Double[0] ; V->Val[1] = IntVector_P->Double[1] ; V->Val[2] = IntVector_P->Double[2] ; V->Type = VECTOR; } else{ V->Val[0] = 0.; V->Val[1] = 0.; V->Val[2] = 0.; V->Type = VECTOR; /* WARNING, "Table empty: Uninitialized data or Unknown Entity Index in VectorFromIndex Table */ } } void Fi_InitValueFromIndex(F_ARG) { int i, N ; struct IntDouble IntDouble_s; struct FunctionActive * D ; N = (int)Fct->Para[0]; D = Fct->Active = (struct FunctionActive *)Malloc(sizeof(struct FunctionActive)) ; D->Case.ValueFromIndex.Table = List_Create(N, 1, sizeof(struct IntDouble)); for (i = 0 ; i < N ; i++) { IntDouble_s.Int = (int)(Fct->Para[i*2+1]+0.1); IntDouble_s.Double = Fct->Para[i*2+2]; List_Add(D->Case.ValueFromIndex.Table, &IntDouble_s); } } void Fi_InitVectorFromIndex(F_ARG) { int i, N ; struct IntVector IntVector_s; struct FunctionActive * D ; if ((Fct->NbrParameters)){ N = (int)Fct->Para[0]; D = Fct->Active = (struct FunctionActive *)Malloc(sizeof(struct FunctionActive)) ; D->Case.ValueFromIndex.Table = List_Create(N, 1, sizeof(struct IntVector[3])); for (i = 0 ; i < N ; i++) { IntVector_s.Int = (int)(Fct->Para[i*4+1]+0.1); IntVector_s.Double[0] = Fct->Para[i*4+2]; IntVector_s.Double[1] = Fct->Para[i*4+3]; IntVector_s.Double[2] = Fct->Para[i*4+4]; List_Add(D->Case.ValueFromIndex.Table, &IntVector_s); } } else{ D = Fct->Active = (struct FunctionActive *)Malloc(sizeof(struct FunctionActive)) ; D->Case.ValueFromIndex.Table = NULL; } } getdp-2.4.2-source/Legacy/Gauss_Pyramid.cpp000644 001750 001750 00000001205 12116424202 022247 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "Gauss_Pyramid.h" #include "Message.h" /* Gauss integration over a pyramid */ void Gauss_Pyramid(int Nbr_Points, int Num, double *u, double *v, double *w, double *wght) { switch (Nbr_Points) { case 8 : *u = upyr8[Num]; *v = vpyr8[Num]; *w = wpyr8[Num]; *wght = ppyr8[Num]; break ; default : Message::Error("Wrong number of Gauss points for Pyramid: " "valid choice: 8"); break; } } getdp-2.4.2-source/Legacy/Pos_Search.cpp000644 001750 001750 00000040265 12116424202 021537 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Jean-Francois Remacle // #include "ProData.h" #include "GeoData.h" #include "Get_Geometry.h" #include "Pos_Search.h" #include "Get_DofOfElement.h" #include "Message.h" #define SQU(a) ((a)*(a)) extern struct CurrentData Current ; static struct Geo_Element * LastGeoElement; /* ------------------------------------------------------------------------ */ /* C o m p u t e E l e m e n t B o x */ /* ------------------------------------------------------------------------ */ void ComputeElementBox(struct Element * Element, struct ElementBox * ElementBox) { int i; ElementBox->Xmin = ElementBox->Xmax = Element->x[0]; ElementBox->Ymin = ElementBox->Ymax = Element->y[0]; ElementBox->Zmin = ElementBox->Zmax = Element->z[0]; for (i = 1 ; i < Element->GeoElement->NbrNodes ; i++) { ElementBox->Xmin = std::min(ElementBox->Xmin, Element->x[i]); ElementBox->Xmax = std::max(ElementBox->Xmax, Element->x[i]); ElementBox->Ymin = std::min(ElementBox->Ymin, Element->y[i]); ElementBox->Ymax = std::max(ElementBox->Ymax, Element->y[i]); ElementBox->Zmin = std::min(ElementBox->Zmin, Element->z[i]); ElementBox->Zmax = std::max(ElementBox->Zmax, Element->z[i]); } } /* ------------------------------------------------------------------------ */ /* P o i n t I n X X X */ /* ------------------------------------------------------------------------ */ int PointInElementBox(struct ElementBox ElementBox, double x, double y, double z, double tol) { if (x > ElementBox.Xmax + tol || x < ElementBox.Xmin - tol || y > ElementBox.Ymax + tol || y < ElementBox.Ymin - tol || z > ElementBox.Zmax + tol || z < ElementBox.Zmin - tol){ return(0); } else{ return(1); } } int PointInRefElement (struct Element * Element, double u, double v, double w) { double ONE = 1. + 1.e-12; double ZERO = 1.e-12; switch(Element->Type) { case LINE : case LINE_2 : if (u<-ONE || u>ONE){ return(0); } return(1); case TRIANGLE : case TRIANGLE_2 : if (u<-ZERO || v<-ZERO || u>(ONE-v)){ return(0); } return(1); case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N : if (u<-ONE || v<-ONE || u>ONE || v>ONE){ return (0); } return(1); case TETRAHEDRON : case TETRAHEDRON_2 : if (u<-ZERO || v<-ZERO || w<-ZERO || u>(ONE-v-w)){ return(0); } return(1); case HEXAHEDRON : case HEXAHEDRON_2 : if (u<-ONE || v<-ONE || w<-ONE || u>ONE || v>ONE || w>ONE){ return(0); } return(1); case PRISM : case PRISM_2 : if (w>ONE || w<-ONE || u<-ZERO || v<-ZERO || u>(ONE-v)){ return(0); } return(1); case PYRAMID : case PYRAMID_2 : if (u<(w-ONE) || u>(ONE-w) || v<(w-ONE) || v>(ONE-w) || w<-ZERO || w>ONE){ return(0); } return(1); default : return(0); } } int PointInElement (struct Element * Element, List_T *ExcludeRegion_L, double x, double y, double z, double *u, double *v, double *w, double tol) { struct ElementBox ElementBox ; if(ExcludeRegion_L) if(List_Search(ExcludeRegion_L, &Element->GeoElement->Region, fcmp_int)){ return(0); } Element->Num = Element->GeoElement->Num ; Element->Type = Element->GeoElement->Type ; Element->Region = Element->GeoElement->Region ; Get_NodesCoordinatesOfElement(Element) ; ComputeElementBox(Element, &ElementBox); if (!PointInElementBox(ElementBox, x, y, z, tol)){ return(0); } xyz2uvwInAnElement(Element, x, y, z, u, v, w); if(!PointInRefElement(Element, *u, *v, *w)){ /* Message::Info("Point was in box, but not in actual element"); */ return(0); } return(1); } /* ------------------------------------------------------------------------ */ /* I n i t _ S e a r c h G r i d */ /* ------------------------------------------------------------------------ */ void Init_SearchGrid(struct Grid * Grid) { struct Element Element; struct ElementBox ElementBox; struct Brick Brick, *Brick_P; double Xc, Yc, Zc ; int NbrGeoElements, iElm; int Ix1, Ix2, Iy1, Iy2, Iz1, Iz2; int i, j, k, index; LastGeoElement = NULL; if(Grid->Init){ return; } Grid->Xmin = Current.GeoData->Xmin; Grid->Xmax = Current.GeoData->Xmax; Grid->Ymin = Current.GeoData->Ymin; Grid->Ymax = Current.GeoData->Ymax; Grid->Zmin = Current.GeoData->Zmin; Grid->Zmax = Current.GeoData->Zmax; #define NBB 20 #define FACT 0.1 if(Grid->Xmin != Grid->Xmax && Grid->Ymin != Grid->Ymax && Grid->Zmin != Grid->Zmax){ Grid->Nx = Grid->Ny = Grid->Nz = NBB; Xc = Grid->Xmax-Grid->Xmin; Yc = Grid->Ymax-Grid->Ymin; Zc = Grid->Zmax-Grid->Zmin; Grid->Xmin -= FACT * Xc ; Grid->Ymin -= FACT * Yc ; Grid->Zmin -= FACT * Zc ; Grid->Xmax += FACT * Xc ; Grid->Ymax += FACT * Yc ; Grid->Zmax += FACT * Zc ; } else if(Grid->Xmin != Grid->Xmax && Grid->Ymin != Grid->Ymax){ Grid->Nx = Grid->Ny = NBB ; Grid->Nz = 1 ; Xc = Grid->Xmax-Grid->Xmin; Yc = Grid->Ymax-Grid->Ymin; Grid->Xmin -= FACT * Xc ; Grid->Ymin -= FACT * Xc ; Grid->Zmin -= 1. ; Grid->Xmax += FACT * Xc ; Grid->Ymax += FACT * Xc ; Grid->Zmax += 1. ; } else if(Grid->Xmin != Grid->Xmax && Grid->Zmin != Grid->Zmax){ Grid->Nx = Grid->Nz = NBB ; Grid->Ny = 1 ; Xc = Grid->Xmax-Grid->Xmin; Zc = Grid->Zmax-Grid->Zmin; Grid->Xmin -= FACT * Xc ; Grid->Ymin -= 1. ; Grid->Zmin -= FACT * Zc ; Grid->Xmax += FACT * Xc ; Grid->Ymax += 1. ; Grid->Zmax += FACT * Zc ; } else if(Grid->Ymin != Grid->Ymax && Grid->Zmin != Grid->Zmax){ Grid->Nx = 1 ; Grid->Ny = Grid->Nz = NBB ; Yc = Grid->Ymax-Grid->Ymin; Zc = Grid->Zmax-Grid->Zmin; Grid->Xmin -= 1. ; Grid->Ymin -= FACT * Yc ; Grid->Zmin -= FACT * Zc ; Grid->Xmax += 1. ; Grid->Ymax += FACT * Yc ; Grid->Zmax += FACT * Zc ; } else if(Grid->Xmin != Grid->Xmax){ Grid->Nx = NBB ; Grid->Ny = Grid->Nz = 1 ; Xc = Grid->Xmax-Grid->Xmin; Grid->Xmin -= FACT * Xc ; Grid->Ymin -= 1. ; Grid->Zmin -= 1. ; Grid->Xmax += FACT * Xc ; Grid->Ymax += 1. ; Grid->Zmax += 1. ; } else if(Grid->Ymin != Grid->Ymax){ Grid->Nx = Grid->Nz = 1 ; Grid->Ny = NBB ; Yc = Grid->Ymax-Grid->Ymin; Grid->Xmin -= 1. ; Grid->Ymin -= FACT * Yc ; Grid->Zmin -= 1. ; Grid->Xmax += 1. ; Grid->Ymax += FACT * Yc ; Grid->Zmax += 1. ; } else if(Grid->Zmin != Grid->Zmax){ Grid->Nx = Grid->Ny = 1 ; Grid->Nz = NBB ; Zc = Grid->Zmax-Grid->Zmin; Grid->Xmin -= 1. ; Grid->Ymin -= 1. ; Grid->Zmin -= FACT * Zc ; Grid->Xmax += 1. ; Grid->Ymax += 1. ; Grid->Zmax += FACT * Zc ; } else{ Grid->Nx = Grid->Ny = Grid->Nz = 1; Grid->Xmin -= 1. ; Grid->Ymin -= 1. ; Grid->Zmin -= 1. ; Grid->Xmax += 1. ; Grid->Ymax += 1. ; Grid->Zmax += 1. ; } Message::Info("Initializing rapid search grid..."); Grid->Bricks = List_Create(Grid->Nx * Grid->Ny * Grid->Nz, 10, sizeof(Brick)); for(i = 0; i < Grid->Nx * Grid->Ny * Grid->Nz ; i++){ for(j = 0 ; j < 3 ; j++) Brick.p[j] = List_Create(2, 2, sizeof(struct Geo_Element*)); List_Add(Grid->Bricks, &Brick); } NbrGeoElements = Geo_GetNbrGeoElements(); Get_InitDofOfElement(&Element) ; for (iElm=0 ; iElm < NbrGeoElements ; iElm++ ){ Element.GeoElement = Geo_GetGeoElement(iElm) ; Element.Num = Element.GeoElement->Num ; Element.Type = Element.GeoElement->Type ; Current.Region = Element.Region = Element.GeoElement->Region ; if (Element.Region && Element.Type != POINT) { Get_NodesCoordinatesOfElement(&Element) ; ComputeElementBox(&Element, &ElementBox); Ix1 = (int)((double)Grid->Nx*(ElementBox.Xmin-Grid->Xmin)/(Grid->Xmax-Grid->Xmin)); Ix2 = (int)((double)Grid->Nx*(ElementBox.Xmax-Grid->Xmin)/(Grid->Xmax-Grid->Xmin)); Iy1 = (int)((double)Grid->Ny*(ElementBox.Ymin-Grid->Ymin)/(Grid->Ymax-Grid->Ymin)); Iy2 = (int)((double)Grid->Ny*(ElementBox.Ymax-Grid->Ymin)/(Grid->Ymax-Grid->Ymin)); Iz1 = (int)((double)Grid->Nz*(ElementBox.Zmin-Grid->Zmin)/(Grid->Zmax-Grid->Zmin)); Iz2 = (int)((double)Grid->Nz*(ElementBox.Zmax-Grid->Zmin)/(Grid->Zmax-Grid->Zmin)); Ix1 = std::max(Ix1, 0); Ix2 = std::min(Ix2, Grid->Nx-1); Iy1 = std::max(Iy1, 0); Iy2 = std::min(Iy2, Grid->Ny-1); Iz1 = std::max(Iz1, 0); Iz2 = std::min(Iz2, Grid->Nz-1); for(i = Ix1 ; i <= Ix2 ; i++){ for(j = Iy1 ; j <= Iy2 ; j++){ for(k = Iz1 ; k <= Iz2 ; k++){ index = i + j * Grid->Nx + k * Grid->Nx * Grid->Ny; Brick_P = (struct Brick*)List_Pointer(Grid->Bricks, index); switch(Element.GeoElement->Type){ case LINE : case LINE_2 : List_Add(Brick_P->p[0], &Element.GeoElement); break; case TRIANGLE : case TRIANGLE_2 : case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N : List_Add(Brick_P->p[1], &Element.GeoElement); break; case TETRAHEDRON : case TETRAHEDRON_2 : case HEXAHEDRON : case HEXAHEDRON_2 : case PRISM : case PRISM_2 : case PYRAMID : case PYRAMID_2 : List_Add(Brick_P->p[2], &Element.GeoElement); break; } } } } } } Grid->Init = 1; #if 0 for (i=0 ; iBricks) ; i++) { Brick_P = (struct Brick *)List_Pointer(Grid->Bricks, i) ; printf("BRICK %d : ", i) ; for (j=0 ; jp[2]) ; j++) { Element.GeoElement = *(struct Geo_Element **)List_Pointer(Brick_P->p[2], j) ; printf("%d ", Element.GeoElement->Num) ; } printf("\n"); } #endif Message::Info("...done: %dx%dx%d", Grid->Nx, Grid->Ny, Grid->Nz); } void Free_SearchGrid(struct Grid * Grid) { if(!Grid->Init) return; for(int i = 0; i < List_Nbr(Grid->Bricks); i++){ Brick *Brick_P = (struct Brick *)List_Pointer(Grid->Bricks, i) ; for(int j = 0 ; j < 3 ; j++) List_Delete(Brick_P->p[j]); } List_Delete(Grid->Bricks); Grid->Init = 0; } /* ------------------------------------------------------------------------ */ /* I n W h i c h X X X */ /* ------------------------------------------------------------------------ */ int InWhichBrick (struct Grid *pGrid, double X, double Y, double Z) { int Ix, Iy, Iz; if(X > pGrid->Xmax || X < pGrid->Xmin || Y > pGrid->Ymax || Y < pGrid->Ymin || Z > pGrid->Zmax || Z < pGrid->Zmin){ return(NO_BRICK); } Ix = (int)((double)pGrid->Nx * (X-pGrid->Xmin) / (pGrid->Xmax-pGrid->Xmin)); Iy = (int)((double)pGrid->Ny * (Y-pGrid->Ymin) / (pGrid->Ymax-pGrid->Ymin)); Iz = (int)((double)pGrid->Nz * (Z-pGrid->Zmin) / (pGrid->Zmax-pGrid->Zmin)); Ix = std::min(Ix,pGrid->Nx-1); Iy = std::min(Iy,pGrid->Ny-1); Iz = std::min(Iz,pGrid->Nz-1); if(Ix < 0) Ix = 0; if(Iy < 0) Iy = 0; if(Iz < 0) Iz = 0; return(Ix + Iy * pGrid->Nx + Iz * pGrid->Nx * pGrid->Ny) ; } void InWhichElement (struct Grid Grid, List_T *ExcludeRegion_L, struct Element * Element, int Dim, double x, double y, double z, double *u, double *v, double *w) { /* Note: Il est garanti en sortie que les fcts de forme geometriques sont initialisees en u,v,w */ struct Brick * Brick_P ; int i, dim, lowdim = 0, highdim = 0; double tol; /* Allow for some extra matches by increasing the size of the bounding box, and even more if we search for elements of dimension smaller than the current dimension. This way we can for example also find 1D elements with points not exactly on them. */ if ((Dim == _1D && Current.GeoData->Dimension == _3D) || (Dim == _1D && Current.GeoData->Dimension == _2D) || (Dim == _2D && Current.GeoData->Dimension == _3D)) tol = Current.GeoData->CharacteristicLength * 1.e-4; /* instead of 5.e-3 */ else tol = Current.GeoData->CharacteristicLength * 1.e-8; if(LastGeoElement){ Element->GeoElement = LastGeoElement ; if (PointInElement(Element, ExcludeRegion_L, x, y, z, u, v, w, tol)){ return; } } if ((i = InWhichBrick(&Grid, x, y, z)) == NO_BRICK) { Element->Num = NO_ELEMENT ; Element->Region = NO_REGION ; return; } if (!(Brick_P = (struct Brick *)List_Pointer(Grid.Bricks, i))){ Message::Error("Brick %d not found in Grid", i) ; Element->Num = NO_ELEMENT ; Element->Region = NO_REGION ; return; } switch(Dim){ case _1D : lowdim = 0 ; highdim = 0 ; break; case _2D : lowdim = 1 ; highdim = 1 ; break; case _3D : lowdim = 2 ; highdim = 2 ; break; case _ALL : default : lowdim = 0 ; highdim = 2 ; break; } for(dim = highdim ; dim >= lowdim ; dim--) { for (i=0 ; i < List_Nbr(Brick_P->p[dim]) ; i++) { Element->GeoElement = *(struct Geo_Element**)List_Pointer(Brick_P->p[dim], i) ; if (PointInElement(Element, ExcludeRegion_L, x, y, z, u, v, w, tol)) { /* Message::Info("xyz(%g,%g,%g) -> Selected Element %d uvw(%g,%g,%g) (%g,%g,%g)->(%g,%g,%g)", x, y, z, Element->Num, *u, *v, *w, Element->x[0], Element->y[0], Element->z[0], Element->x[1], Element->y[1], Element->z[1]); */ LastGeoElement = Element->GeoElement; return; } } } Element->Num = NO_ELEMENT ; Element->Region = NO_REGION ; } /* ------------------------------------------------------------------------ */ /* x y z 2 u v w I n A n E l e m e n t */ /* ------------------------------------------------------------------------ */ #define NR_PRECISION 1.e-6 /* a comparer a l'intervalle de variation de uvw */ #define NR_MAX_ITER 50 void xyz2uvwInAnElement (struct Element *Element, double x, double y, double z, double *u, double *v, double *w) { double x_est, y_est, z_est; double u_new, v_new, w_new; double Error = 1.0 ; int i, iter = 1 ; int ChainDim = _3D, Type_Dimension, Type_Jacobian ; double (*Get_Jacobian)(struct Element*, MATRIX3x3*) ; *u = *v = *w = 0.0; if(Element->Type & (TETRAHEDRON|HEXAHEDRON|PRISM|PYRAMID)) ChainDim = _3D; else if(Element->Type & (TRIANGLE|QUADRANGLE|TRIANGLE_2|QUADRANGLE_2)) ChainDim = _2D; else if(Element->Type & (LINE|LINE_2)) ChainDim = _1D; else if(Element->Type & POINT) ChainDim = _0D; else{ Message::Error("Unknown type of element in xyz2uvwInAnElement"); return; } if (ChainDim == _1D && Current.GeoData->Dimension == _3D) Type_Jacobian = JACOBIAN_LIN; else if((ChainDim == _1D && Current.GeoData->Dimension == _2D) || (ChainDim == _2D && Current.GeoData->Dimension == _3D)) Type_Jacobian = JACOBIAN_SUR; else Type_Jacobian = JACOBIAN_VOL; while (Error > NR_PRECISION && iter < NR_MAX_ITER){ iter++ ; Get_BFGeoElement(Element, *u, *v, *w) ; Get_Jacobian = (double (*)(struct Element*, MATRIX3x3*)) Get_JacobianFunction(Type_Jacobian, Element->Type, &Type_Dimension) ; Element->DetJac = Get_Jacobian(Element, &Element->Jac) ; if (Element->DetJac != 0) { Get_InverseMatrix(Type_Dimension, Element->Type, Element->DetJac, &Element->Jac, &Element->InvJac) ; x_est = y_est = z_est = 0. ; for (i = 0 ; i < Element->GeoElement->NbrNodes ; i++) { x_est += Element->x[i] * Element->n[i] ; y_est += Element->y[i] * Element->n[i] ; z_est += Element->z[i] * Element->n[i] ; } u_new = *u + Element->InvJac.c11 * (x-x_est) + Element->InvJac.c21 * (y-y_est) + Element->InvJac.c31 * (z-z_est) ; v_new = *v + Element->InvJac.c12 * (x-x_est) + Element->InvJac.c22 * (y-y_est) + Element->InvJac.c32 * (z-z_est) ; w_new = *w + Element->InvJac.c13 * (x-x_est) + Element->InvJac.c23 * (y-y_est) + Element->InvJac.c33 * (z-z_est) ; Error = SQU(u_new - *u) + SQU(v_new - *v) + SQU(w_new - *w); *u = u_new; *v = v_new; *w = w_new; } else{ Message::Warning("Zero determinant in 'xyz2uvwInAnElement'") ; break; } } if(iter == NR_MAX_ITER) Message::Warning("Maximum number of iterations exceeded in xyz2uvwInAnElement") ; #if 0 Message::Info("%d iterations in xyz2uvw", iter); #endif } getdp-2.4.2-source/Legacy/F_Analytic.cpp000644 001750 001750 00000162531 12166744450 021542 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Ruth Sabariego // Xavier Antoine // #include #include "ProData.h" #include "F.h" #include "Legendre.h" #include "Bessel.h" #include "MallocUtils.h" #include "Message.h" #define SQU(a) ((a)*(a)) /* some utility functions to deal with complex numbers */ typedef struct { double r; double i; } cplx; static cplx Csum(cplx a, cplx b) { cplx s; s.r = a.r + b.r; s.i = a.i + b.i; return(s); } static cplx Csub(cplx a, cplx b) { cplx s; s.r = a.r - b.r; s.i = a.i - b.i; return(s); } static cplx Csubr(double a, cplx b) { cplx s; s.r = a - b.r; s.i = - b.i; return(s); } static cplx Cprod(cplx a, cplx b) { cplx s; s.r = a.r * b.r - a.i * b.i; s.i = a.r * b.i + a.i * b.r; return(s); } static cplx Cdiv(cplx a, cplx b) { cplx s; double den; den = b.r * b.r + b.i * b.i; s.r = (a.r * b.r + a.i * b.i) / den; s.i = (a.i * b.r - a.r * b.i) / den; return(s); } static cplx Cdivr(double a, cplx b) { cplx s; double den; den = b.r * b.r + b.i * b.i; s.r = (a * b.r) / den; s.i = (- a * b.i) / den; return(s); } static cplx Cconj(cplx a) { cplx s; s.r = a.r; s.i = -a.i; return(s); } static cplx Cneg(cplx a) { cplx s; s.r = -a.r; s.i = -a.i; return(s); } static double Cmodu(cplx a) { return(sqrt(a.r * a.r + a.i * a.i)); } static cplx Cpow(cplx a, double b) { cplx s; double mod, arg; mod = a.r * a.r + a.i * a.i; arg = atan2(a.i,a.r); mod = pow(mod,0.5*b); arg *= b; s.r = mod * cos(arg); s.i = mod * sin(arg); return(s); } static cplx Cprodr(double a, cplx b) { cplx s; s.r = a * b.r; s.i = a * b.i; return(s); } /* ------------------------------------------------------------------------ */ /* Exact solutions for spheres */ /* ------------------------------------------------------------------------ */ /* Scattering by solid PEC sphere. Returns theta-component of surface current */ void F_JFIE_SphTheta(F_ARG) { double k0, r, kr, e0, eta, theta, phi, a1, b1, c1, d1, den1, P, P0, dP ; double ctheta, stheta, cteRe1, cteRe2, a2, b2, c2, d2, den2 ; int i, n ; theta = atan2(sqrt( A->Val[0]* A->Val[0] + A->Val[1]*A->Val[1] ), A->Val[2]); phi = atan2( A->Val[1], A->Val[0] ) ; k0 = Fct->Para[0] ; eta = Fct->Para[1] ; e0 = Fct->Para[2] ; r = Fct->Para[3] ; kr = k0*r ; n = 50 ; V->Val[0] = 0.; V->Val[MAX_DIM] = 0. ; if ( theta == 0. ) theta += 1e-7; /* Warning! This is an approximation. */ if ( theta == M_PI || theta == -M_PI ) theta -= 1e-7; for (i = 1 ; i <= n ; i++ ){ ctheta = cos(theta); stheta = sin(theta); P = Legendre(i,1,ctheta); P0 = Legendre(i,0,ctheta); dP = (i+1)*i* P0/stheta-(ctheta/(ctheta*ctheta-1))* P; cteRe1 = (2*i+1) * stheta * dP/i/(i+1); cteRe2 = (2*i+1) * P/stheta/i/(i+1); a1 = cos((1-i)*M_PI/2) ; b1 = sin((1-i)*M_PI/2) ; c1 = -AltSpherical_j_n(i+1, kr) + (i+1) * AltSpherical_j_n(i, kr)/kr ; /* Derivative */ d1 = -(-AltSpherical_y_n(i+1, kr) + (i+1) * AltSpherical_y_n(i, kr)/kr) ; a2 = cos((2-i)*M_PI/2) ; b2 = sin((2-i)*M_PI/2) ; c2 = AltSpherical_j_n(i, kr) ; d2 = -AltSpherical_y_n(i, kr) ; den1 = c1*c1+d1*d1 ; den2 = c2*c2+d2*d2 ; V->Val[0] += cteRe1*(a1*c1+b1*d1)/den1 + cteRe2*(a2*c2+b2*d2)/den2 ; V->Val[MAX_DIM] += cteRe1*(b1*c1-a1*d1)/den1 + cteRe2*(b2*c2-a2*d2)/den2 ; } V->Val[0] *= e0*cos(phi)/eta/kr ; V->Val[MAX_DIM] *= e0*cos(phi)/eta/kr ; V->Type = SCALAR ; } /* Scattering by solid PEC sphere. Returns theta-component of RCS */ void F_RCS_SphTheta(F_ARG) { double k0, r, kr, e0, rinf, krinf, theta, phi, a1 =0., b1=0., d1, den1, P, P0, dP ; double J, J_1, dJ, ctheta, stheta, cteRe1, cteRe2, a2, b2, d2, den2, lambda ; int i, n ; theta = atan2(sqrt( A->Val[0]* A->Val[0] + A->Val[1]*A->Val[1] ), A->Val[2]); phi = atan2( A->Val[1], A->Val[0] ) ; k0 = Fct->Para[0] ; e0 = Fct->Para[1] ; r = Fct->Para[2] ; rinf = Fct->Para[3] ; kr = k0*r ; krinf = k0*rinf ; lambda = 2*M_PI/k0 ; n = 50 ; if ( theta == 0. ) theta += 1e-7; /* Warning! This is an approximation. */ if ( theta == M_PI || theta == -M_PI ) theta -= 1e-7; for (i = 1 ; i <= n ; i++ ){ ctheta = cos(theta); stheta = sin(theta); P = Legendre(i,1,ctheta); P0 = Legendre(i,0,ctheta); dP = (i+1)*i* P0/stheta-(ctheta/(ctheta*ctheta-1))* P; J = AltSpherical_j_n(i, kr) ; J_1 = AltSpherical_j_n(i+1, kr) ; dJ = -J_1 + (i + 1) * J/kr ; cteRe1 = -(2*i+1) * stheta * dP * dJ /i/(i+1); cteRe2 = (2*i+1) * P * J /stheta/i/(i+1); d1 = -(-AltSpherical_y_n(i+1, kr) + (i+1) * AltSpherical_y_n(i, kr)/kr) ; d2 = -AltSpherical_y_n(i, kr) ; den1 = dJ*dJ+d1*d1 ; den2 = J*J+d2*d2 ; a1 += cteRe1 * dJ /den1 + cteRe2 * J /den2 ; b1 += cteRe1*(-d1) /den1 + cteRe2*(-d2) /den2 ; } a2 = e0*cos(phi)*sin(krinf)/krinf ; b2 = e0*cos(phi)*cos(krinf)/krinf ; V->Val[0] = 10*log10( 4*M_PI*SQU(rinf/lambda)*(SQU(a1*a2-b1*b2) + SQU(a1*b2+a2*b1)) ); V->Val[MAX_DIM] = 0. ; V->Type = SCALAR ; } /* Scattering by solid PEC sphere. Returns phi-component of surface current */ void F_JFIE_SphPhi(F_ARG) { double k0, r, kr, e0, eta, theta, phi, a1, b1, c1, d1, den1, P, P0, dP ; double ctheta, stheta, cteRe1, cteRe2, a2, b2, c2, d2, den2 ; int i, n ; theta = atan2( sqrt( A->Val[0]*A->Val[0] + A->Val[1]*A->Val[1] ), A->Val[2]); phi = atan2( A->Val[1], A->Val[0] ) ; k0 = Fct->Para[0] ; eta = Fct->Para[1] ; e0 = Fct->Para[2] ; r = Fct->Para[3] ; kr = k0*r ; n = 50 ; V->Val[0] = 0.; V->Val[MAX_DIM] = 0. ; if ( theta == 0. ) theta += 1e-7; /* Warning! This is an approximation. */ if ( theta == M_PI || theta == -M_PI ) theta -= 1e-7; for (i = 1 ; i <= n ; i++ ){ ctheta = cos(theta); stheta = sin(theta); P = Legendre(i,1,ctheta); P0 = Legendre(i,0,ctheta); dP = (i+1)*i* P0/stheta - ctheta/(ctheta*ctheta-1)*P; /* Derivative */ cteRe1 = (2*i+1) * P /i/(i+1)/stheta; cteRe2 = (2*i+1) * stheta * dP/i/(i+1); a1 = cos((1-i)*M_PI/2) ; b1 = sin((1-i)*M_PI/2) ; c1 = -AltSpherical_j_n(i+1, kr) + (i+1)*AltSpherical_j_n(i, kr)/kr ; /* Derivative */ d1 = -(-AltSpherical_y_n(i+1, kr) + (i+1)*AltSpherical_y_n(i, kr)/kr) ; a2 = cos((2-i)*M_PI/2) ; b2 = sin((2-i)*M_PI/2) ; c2 = AltSpherical_j_n(i, kr) ; d2 = -AltSpherical_y_n(i, kr) ; den1 = c1*c1+d1*d1 ; den2 = c2*c2+d2*d2 ; V->Val[0] += cteRe1*(a1*c1+b1*d1)/den1 + cteRe2*(a2*c2+b2*d2)/den2 ; V->Val[MAX_DIM] += cteRe1*(b1*c1-a1*d1)/den1 + cteRe2*(b2*c2-a2*d2)/den2 ; } V->Val[0] *= e0*sin(phi)/eta/kr ; V->Val[MAX_DIM] *= e0*sin(phi)/eta/kr ; V->Type = SCALAR ; } /* Scattering by solid PEC sphere. Returns phi-component of RCS */ void F_RCS_SphPhi(F_ARG) { double k0, r, kr, e0, rinf, krinf, theta, phi, a1 =0., b1=0., d1, den1, P, P0, dP ; double J, J_1, dJ, ctheta, stheta, cteRe1, cteRe2, a2, b2, d2, den2, lambda ; int i, n ; theta = atan2(sqrt( A->Val[0]* A->Val[0] + A->Val[1]*A->Val[1] ), A->Val[2]); phi = M_PI/2 ; k0 = Fct->Para[0] ; e0 = Fct->Para[1] ; r = Fct->Para[2] ; rinf = Fct->Para[3] ; kr = k0*r ; krinf = k0*rinf ; lambda = 2*M_PI/k0 ; n = 50 ; if ( theta == 0. ) theta += 1e-7; /* Warning! This is an approximation. */ if ( theta == M_PI || theta == -M_PI ) theta -= 1e-7; for (i = 1 ; i <= n ; i++ ){ ctheta = cos(theta); stheta = sin(theta); P = Legendre(i,1,ctheta); P0 = Legendre(i,0,ctheta); dP = (i+1)*i* P0/stheta-(ctheta/(ctheta*ctheta-1))* P; J = AltSpherical_j_n(i, kr) ; J_1 = AltSpherical_j_n(i+1, kr) ; dJ = -J_1 + (i + 1) * J/kr ; cteRe1 = -(2*i+1) * P * dJ /stheta/i/(i+1); cteRe2 = (2*i+1) * stheta * dP * J/i/(i+1); d1 = -(-AltSpherical_y_n(i+1, kr) + (i+1) * AltSpherical_y_n(i, kr)/kr) ; d2 = -AltSpherical_y_n(i, kr) ; den1 = dJ*dJ+d1*d1 ; den2 = J*J+d2*d2 ; a1 += cteRe1 * dJ /den1 + cteRe2 * J /den2 ; b1 += cteRe1*(-d1) /den1 + cteRe2*(-d2) /den2 ; } a2 = e0*sin(phi)*sin(krinf)/krinf ; b2 = e0*sin(phi)*cos(krinf)/krinf ; V->Val[0] = 10*log10( 4*M_PI*SQU(rinf/lambda)*(SQU(a1*a2-b1*b2) + SQU(a1*b2+a2*b1)) ); V->Val[MAX_DIM] = 0. ; V->Type = SCALAR ; } /* Scattering by a perfectly conducting sphere of radius a, under plane wave incidence pol*e^{ik \alpha\dot\r}, with alpha = (0,0,-1) and pol = (1,0,0). Returns the scattered electric field anywhere outside the sphere (From Balanis, Advanced Engineering Electromagnetics, sec 11.8, p. 660) Warning This is probably wring :-) */ // diffraction onde plane par une sphere diectrique en -iwt void F_ElectricFieldDielectricSphereMwt(F_ARG) { double x = A->Val[0]; double y = A->Val[1]; double z = A->Val[2]; double r = sqrt(x * x + y * y + z * z); double theta = atan2(sqrt(x * x + y * y), z); double phi = atan2(y, x); double k = Fct->Para[0] ; double a = Fct->Para[1] ; double kr = k * r; double ka = k * a; double epsi = 2.25; double ki = k*sqrt(epsi); double Zi = 1.0 / sqrt(epsi); double kia = ki * a; double kir = ki * r; int ns = (int)k + 12; std::vector > Hnkr(ns + 1), Hnka(ns + 1), Hnkir(ns + 1), Hnkia(ns + 1); for (int n = 1 ; n <= ns ; n++){ Hnkr[n] = std::complex(AltSpherical_j_n(n, kr), AltSpherical_y_n(n, kr)); Hnka[n] = std::complex(AltSpherical_j_n(n, ka), AltSpherical_y_n(n, ka)); Hnkia[n] = std::complex(AltSpherical_j_n(n, kia), AltSpherical_y_n(n, kia)); Hnkir[n] = std::complex(AltSpherical_j_n(n, kir), AltSpherical_y_n(n, kir)); } double ctheta = cos(theta); double stheta = sin(theta); std::complex Er(0.,0), Etheta(0.,0), Ephi(0.,0), I(0, 1.); if( theta == 0.) { if (r >= a ) { for (int n = 1 ; n < ns ; n++){ std::complex an = pow(-I, n) * (2. * n + 1.) / (n * (n + 1.)); double A1 = -n * (n + 1.) / 2.; std::complex dHnka = - Hnka[n + 1] + (n + 1.) * Hnka[n] / ka; std::complex dHnkia = - Hnkia[n + 1] + (n + 1.) * Hnkia[n] / kia; std::complex aln = (dHnka.real() * Hnkia[n].real() - Zi * dHnkia.real() * Hnka[n].real() ) / (Zi*dHnkia.real() * Hnka[n] - dHnka * Hnkia[n].real()) ; std::complex ben = (dHnkia.real() * Hnka[n].real() - Zi * dHnka.real() * Hnkia[n].real() ) / (Zi*Hnkia[n].real() * dHnka - dHnkia.real() * Hnka[n]) ; std::complex dn = aln*an; std::complex dHnkr = - Hnkr[n + 1] + (n + 1.) * Hnkr[n] / kr; std::complex d2Hnkr = Hnkr[n] / kr; std::complex jnkr = Hnkr[n].real() / kr; double Pn1 = Legendre(n, 1, ctheta); Er += (n * (n + 1.) * d2Hnkr * dn + n * (n + 1.) * jnkr * an ) * Pn1; Etheta += an * (I * aln * dHnkr * A1 + ben * Hnkr[n] * A1 + I * dHnkr.real() * A1 + Hnkr[n].real() * A1 ); Ephi += an * (I * aln * dHnkr * A1 + ben * Hnkr[n] * A1 + I * dHnkr.real() * A1 + Hnkr[n].real() * A1 ); } Er *= I * cos(phi) / kr; Etheta *= (1. / kr) * (cos(phi)); Ephi *= (-1. / kr) * (sin(phi)); } else { for (int n = 1 ; n < ns ; n++){ std::complex an = pow(-I, n) * (2. * n + 1.) / (n * (n + 1.)); double A1 = -n * (n + 1.) / 2.; std::complex dHnka = - Hnka[n + 1] + (n + 1.) * Hnka[n] / ka; std::complex dHnkia = - Hnkia[n + 1] + (n + 1.) * Hnkia[n] / kia; std::complex dHnkir = - Hnkir[n + 1] + (n + 1.) * Hnkir[n] / kir; std::complex den = (ki * Zi / k) * (dHnka * Hnka[n].real() - dHnka.real() * Hnka[n] ) / (Zi*Hnkia[n].real() * dHnka - dHnkia.real() * Hnka[n]) ; std::complex gan = (ki * Zi / k) * (dHnka.real() * Hnka[n] - dHnka * Hnka[n].real() ) / (Zi*dHnkia.real() * Hnka[n] - dHnka * Hnkia[n].real()) ; std::complex dn = gan*an; std::complex jnkir = Hnkir[n].real() / kir; double Pn1 = Legendre(n, 1, ctheta); Er += (n * (n + 1.) * jnkir * dn ) * Pn1; Etheta += an * (I * gan * dHnkir.real() * A1 + den * Hnkir[n].real() * A1 ); Ephi += an * (I * gan * dHnkir.real() * A1 + den * Hnkir[n].real() * A1 ); } Er *= I * cos(phi) / kir; Etheta *= (1. / kir) * (cos(phi)); Ephi *= (-1. / kir) * (sin(phi)); } } else if( theta == M_PI ) { if (r >= a ) { for (int n = 1 ; n < ns ; n++){ std::complex an = pow(-I, n) * (2. * n + 1.) / (n * (n + 1.)); double A2 = -pow(-1, n + 1) * n * (n + 1.) / 2.; double A3 = -pow(-1, n ) * n * (n + 1.) / 2.; std::complex dHnka = - Hnka[n + 1] + (n + 1.) * Hnka[n] / ka; std::complex dHnkia = - Hnkia[n + 1] + (n + 1.) * Hnkia[n] / kia; std::complex aln = (dHnka.real() * Hnkia[n].real() - Zi * dHnkia.real() * Hnka[n].real() ) / (Zi*dHnkia.real() * Hnka[n] - dHnka * Hnkia[n].real()) ; std::complex ben = (dHnkia.real() * Hnka[n].real() - Zi * dHnka.real() * Hnkia[n].real() ) / (Zi*Hnkia[n].real() * dHnka - dHnkia.real() * Hnka[n]) ; std::complex dn = aln*an; std::complex dHnkr = - Hnkr[n + 1] + (n + 1.) * Hnkr[n] / kr; std::complex d2Hnkr = Hnkr[n] / kr; std::complex jnkr = Hnkr[n].real() / kr; double Pn1 = Legendre(n, 1, ctheta); Er += (n * (n + 1.) * d2Hnkr * dn + n * (n + 1.) * jnkr * an ) * Pn1; Etheta += an * (I * aln * dHnkr * A3 + ben * Hnkr[n] * A2 + I * dHnkr.real() * A3 + Hnkr[n].real() * A2 ); Ephi += an * (I * aln * dHnkr * A2 + ben * Hnkr[n] * A3 + I * dHnkr.real() * A2 + Hnkr[n].real() * A3 ); } Er *= I * cos(phi) / kr; Etheta *= (1. / kr) * (cos(phi)); Ephi *= (-1. / kr) * (sin(phi)); } else { for (int n = 1 ; n < ns ; n++){ std::complex an = pow(-I, n) * (2. * n + 1.) / (n * (n + 1.)); double A2 = -pow(-1, n + 1) * n * (n + 1.) / 2.; double A3 = -pow(-1, n ) * n * (n + 1.) / 2.; std::complex dHnka = - Hnka[n + 1] + (n + 1.) * Hnka[n] / ka; std::complex dHnkia = - Hnkia[n + 1] + (n + 1.) * Hnkia[n] / kia; std::complex dHnkir = - Hnkir[n + 1] + (n + 1.) * Hnkir[n] / kir; std::complex den = (ki * Zi / k) * (dHnka * Hnka[n].real() - dHnka.real() * Hnka[n] ) / (Zi*Hnkia[n].real() * dHnka - dHnkia.real() * Hnka[n]) ; std::complex gan = (ki * Zi / k) * (dHnka.real() * Hnka[n] - dHnka * Hnka[n].real() ) / (Zi*dHnkia.real() * Hnka[n] - dHnka * Hnkia[n].real()) ; std::complex dn = gan*an; std::complex jnkir = Hnkir[n].real() / kir; double Pn1 = Legendre(n, 1, ctheta); Er += (n * (n + 1.) * jnkir * dn ) * Pn1; Etheta += an * (I * gan * dHnkir.real() * A3 + den * Hnkir[n].real() * A2 ); Ephi += an * (I * gan * dHnkir.real() * A2 + den * Hnkir[n].real() * A3 ); } Er *= I * cos(phi) / kir; Etheta *= (1. / kir) * (cos(phi)); Ephi *= (-1. / kir) * (sin(phi)); } } else { if (r >= a ) { for (int n = 1 ; n < ns ; n++){ std::complex an = pow(-I, n) * (2. * n + 1.) / (n * (n + 1.)); std::complex dHnka = - Hnka[n + 1] + (n + 1.) * Hnka[n] / ka; std::complex dHnkia = - Hnkia[n + 1] + (n + 1.) * Hnkia[n] / kia; std::complex aln = (dHnka.real() * Hnkia[n].real() - Zi * dHnkia.real() * Hnka[n].real() ) / (Zi*dHnkia.real() * Hnka[n] - dHnka * Hnkia[n].real()) ; std::complex ben = (dHnkia.real() * Hnka[n].real() - Zi * dHnka.real() * Hnkia[n].real() ) / (Zi*Hnkia[n].real() * dHnka - dHnkia.real() * Hnka[n]) ; std::complex dn = aln*an; std::complex dHnkr = - Hnkr[n + 1] + (n + 1.) * Hnkr[n] / kr; std::complex d2Hnkr = Hnkr[n] / kr; std::complex jnkr = Hnkr[n].real() / kr; double Pn1 = Legendre(n, 1, ctheta); double Pn11 = Legendre(n+1, 1, ctheta); double dPn1 = n * Pn11 - (n + 1) * ctheta * Pn1 ; Er += (n * (n + 1.) * d2Hnkr * dn + n * (n + 1.) * jnkr * an ) * Pn1; Etheta += an * (I * aln * dHnkr * dPn1 + ben * Hnkr[n] * Pn1 + I * dHnkr.real() * dPn1 + Hnkr[n].real() * Pn1 ); Ephi += an * (I * aln * dHnkr * Pn1 + ben * Hnkr[n] * dPn1 + I * dHnkr.real() * Pn1 + Hnkr[n].real() * dPn1 ); } Er *= I * cos(phi) / kr; Etheta *= (1. / kr) * (cos(phi)/stheta); Ephi *= (-1. / kr) * (sin(phi)/stheta); } else { for (int n = 1 ; n < ns ; n++){ std::complex an = pow(-I, n) * (2. * n + 1.) / (n * (n + 1.)); std::complex dHnka = - Hnka[n + 1] + (n + 1.) * Hnka[n] / ka; std::complex dHnkia = - Hnkia[n + 1] + (n + 1.) * Hnkia[n] / kia; std::complex dHnkir = - Hnkir[n + 1] + (n + 1.) * Hnkir[n] / kir; std::complex den = (ki * Zi / k) * (dHnka * Hnka[n].real() - dHnka.real() * Hnka[n] ) / (Zi*Hnkia[n].real() * dHnka - dHnkia.real() * Hnka[n]) ; std::complex gan = (ki * Zi / k) * (dHnka.real() * Hnka[n] - dHnka * Hnka[n].real() ) / (Zi*dHnkia.real() * Hnka[n] - dHnka * Hnkia[n].real()) ; std::complex dn = gan*an; std::complex jnkir = Hnkir[n].real() / kir; double Pn1 = Legendre(n, 1, ctheta); double Pn11 = Legendre(n+1, 1, ctheta); double dPn1 = n * Pn11 - (n + 1) * ctheta * Pn1 ; Er += (n * (n + 1.) * jnkir * dn ) * Pn1; Etheta += an * (I * gan * dHnkir.real() * dPn1 + den * Hnkir[n].real() * Pn1 ); Ephi += an * (I * gan * dHnkir.real() * Pn1 + den * Hnkir[n].real() * dPn1 ); } Er *= I * cos(phi) / kir; Etheta *= (1. / kir) * (cos(phi)/stheta); Ephi *= (-1. / kir) * (sin(phi)/stheta); } } // r, theta, phi components std::complex rtp[3] = {Er, Etheta, Ephi}; double mat[3][3]; // r basis vector mat[0][0] = sin(theta) * cos(phi) ; mat[0][1] = sin(theta) * sin(phi) ; mat[0][2] = cos(theta) ; // theta basis vector mat[1][0] = cos(theta) * cos(phi) ; mat[1][1] = cos(theta) * sin(phi) ; mat[1][2] = - sin(theta) ; // phi basis vector mat[2][0] = - sin(phi) ; mat[2][1] = cos(phi); mat[2][2] = 0.; // x, y, z components std::complex xyz[3] = {0., 0., 0.}; for(int i = 0; i < 3; i++) for(int j = 0; j < 3; j++) xyz[i] = xyz[i] + mat[j][i] * rtp[j]; V->Val[0] = xyz[0].real(); V->Val[1] = xyz[1].real(); V->Val[2] = xyz[2].real(); V->Val[MAX_DIM] = xyz[0].imag(); V->Val[MAX_DIM+1] = xyz[1].imag(); V->Val[MAX_DIM+2] = xyz[2].imag(); V->Type = VECTOR ; } // diffraction onde plane par une sphere PEC en -iwt void F_ElectricFieldPerfectlyConductingSphereMwt(F_ARG) { double x = A->Val[0]; double y = A->Val[1]; double z = A->Val[2]; double r = sqrt(x * x + y * y + z * z); double theta = atan2(sqrt(x * x + y * y), z); double phi = atan2(y, x); double k = Fct->Para[0] ; double a = Fct->Para[1] ; double kr = k * r; double ka = k * a; int ns = (int)k + 12; std::vector > Hnkr(ns + 1), Hnka(ns + 1); for (int n = 1 ; n <= ns ; n++){ Hnkr[n] = std::complex(AltSpherical_j_n(n, kr), AltSpherical_y_n(n, kr)); Hnka[n] = std::complex(AltSpherical_j_n(n, ka), AltSpherical_y_n(n, ka)); } double ctheta = cos(theta); double stheta = sin(theta); std::complex Er(0.,0), Etheta(0.,0), Ephi(0.,0), I(0, 1.); if( theta == 0.) { for (int n = 1 ; n < ns ; n++){ std::complex an = pow(-I, n) * (2. * n + 1.) / (n * (n + 1.)); double A1 = n * (n + 1.) / 2.; // PS: the following is correct (Hn(z) = z hn(z) is not a standard spherical // bessel function!) std::complex dHnka = - Hnka[n + 1] + (n + 1.) * Hnka[n] / ka; std::complex bn = - dHnka.real() / dHnka; std::complex cn = - Hnka[n].real() / Hnka[n]; std::complex dn = bn*an; std::complex dHnkr = - Hnkr[n + 1] + (n + 1.) * Hnkr[n] / kr; std::complex d2Hnkr = Hnkr[n] / kr; double Pn1 = Legendre(n, 1, ctheta); Er += n * (n + 1.) * d2Hnkr * Pn1 * dn; Etheta += an * (I * bn * dHnkr * A1 + cn * Hnkr[n] * A1); Ephi += an * (I * bn * dHnkr * A1 + cn * Hnkr[n] * A1); } Er *= I * cos(phi) / kr; Etheta *= (1. / kr) * (cos(phi)); Ephi *= (-1. / kr) * (sin(phi)); } else if( theta == M_PI ) { for (int n = 1 ; n < ns ; n++){ std::complex an = std::pow(-I, n) * (2. * n + 1.) / (n * (n + 1.)); double A2 = pow(-1, n + 1) * n * (n + 1.) / 2.; double A3 = pow(-1, n ) * n * (n + 1.) / 2.; // PS: the following is correct (Hn(z) = z hn(z) is not a standard spherical // bessel function!) std::complex dHnka = - Hnka[n + 1] + (n + 1.) * Hnka[n] / ka; std::complex bn = - dHnka.real() / dHnka; std::complex cn = - Hnka[n].real() / Hnka[n]; std::complex dn = bn*an; std::complex dHnkr = - Hnkr[n + 1] + (n + 1.) * Hnkr[n] / kr; std::complex d2Hnkr = Hnkr[n] / kr; double Pn1 = Legendre(n, 1, ctheta); Er += n * (n + 1.) * d2Hnkr * Pn1 * dn; Etheta += an * (I * bn * dHnkr * A3 + cn * Hnkr[n] * A2 ); Ephi += an * (I * bn * dHnkr * A2 + cn * Hnkr[n] * A3); } Er *= I * cos(phi) / kr; Etheta *= (1.0 / kr) * cos(phi); Ephi *= (-1.0 / kr) * sin(phi); } else { for (int n = 1 ; n < ns ; n++){ std::complex an = std::pow(-I, n) * (2. * n + 1.) / (n * (n + 1.)); // PS: the following is correct (Hn(z) = z hn(z) is not a standard spherical // bessel function!) std::complex dHnka = - Hnka[n + 1] + (n + 1.) * Hnka[n] / ka; std::complex bn = - dHnka.real() / dHnka; std::complex cn = - Hnka[n].real() / Hnka[n]; std::complex dn = bn * an; std::complex dHnkr = - Hnkr[n + 1] + (n + 1.) * Hnkr[n] / kr; std::complex d2Hnkr = Hnkr[n] / kr; double Pn1 = Legendre(n, 1, ctheta); double Pn11 = Legendre(n+1, 1, ctheta); double dPn1 = n * Pn11 - (n + 1) * ctheta * Pn1 ; Er += n * (n + 1.) * d2Hnkr * Pn1 * dn; Etheta += an * (I * bn * dHnkr * dPn1 + cn * Hnkr[n] * Pn1 ); Ephi += an * (I * bn * dHnkr * Pn1 + cn * Hnkr[n] * dPn1); } Er *= I * cos(phi) / kr; Etheta *= (1. / kr) * (cos(phi)/stheta); Ephi *= (-1. / kr) * (sin(phi)/stheta); } // r, theta, phi components std::complex rtp[3] = {Er, Etheta, Ephi}; double mat[3][3]; // r basis vector mat[0][0] = sin(theta) * cos(phi) ; mat[0][1] = sin(theta) * sin(phi) ; mat[0][2] = cos(theta) ; // theta basis vector mat[1][0] = cos(theta) * cos(phi) ; mat[1][1] = cos(theta) * sin(phi) ; mat[1][2] = - sin(theta) ; // phi basis vector mat[2][0] = - sin(phi) ; mat[2][1] = cos(phi); mat[2][2] = 0.; // x, y, z components std::complex xyz[3] = {0., 0., 0.}; for(int i = 0; i < 3; i++) for(int j = 0; j < 3; j++) xyz[i] = xyz[i] + mat[j][i] * rtp[j]; V->Val[0] = xyz[0].real(); V->Val[1] = xyz[1].real(); V->Val[2] = xyz[2].real(); V->Val[MAX_DIM] = xyz[0].imag(); V->Val[MAX_DIM+1] = xyz[1].imag(); V->Val[MAX_DIM+2] = xyz[2].imag(); V->Type = VECTOR ; } // calcul la solution exact de OSRC sur la sphere void F_ExactOsrcSolutionPerfectlyConductingSphereMwt(F_ARG) { double x = A->Val[0]; double y = A->Val[1]; double z = A->Val[2]; double theta = atan2(sqrt(x * x + y * y), z); double phi = atan2(y, x); double k = Fct->Para[0] ; double a = Fct->Para[1] ; double ka = k * a; int ns = (int)k + 10; std::vector > Hnka(ns + 1); for (int n = 1 ; n <= ns ; n++){ Hnka[n] = std::complex(AltSpherical_j_n(n, ka), AltSpherical_y_n(n, ka)); } double ctheta = cos(theta); double stheta = sin(theta); std::complex Er(0.,0), Etheta(0.,0), Ephi(0.,0), I(0, 1.); if( theta == 0.) { for (int n = 1 ; n < ns ; n++){ std::complex an = pow(-I, n) * (2. * n + 1.) / (n * (n + 1.)); double A1 = n * (n + 1.0) / 2.; double mu_n = 1 - n * (n + 1.0) / (k * k); std::complex dHnka = - Hnka[n + 1] + (n + 1.) * Hnka[n] / ka; std::complex bn = dHnka.real() ; std::complex cn = Hnka[n].real(); if ( k * k >= n * (n + 1) ) { Etheta += an * (-I * cn * A1 * sqrt(mu_n) + bn * A1 / sqrt(mu_n)); Ephi += an * ( I * cn * A1 * sqrt(mu_n) - bn * A1 / sqrt(mu_n)); } else{ Etheta += an * (-I * cn * A1 * I * sqrt(-mu_n) - I * bn * A1 / sqrt(-mu_n)); Ephi += an * ( I * cn * A1 * I * sqrt(-mu_n) + I * bn * A1 / sqrt(-mu_n)); } } Etheta *= cos(phi); Ephi *= sin(phi); } else if( theta == M_PI) { for (int n = 1 ; n < ns ; n++){ std::complex an = std::pow(-I, n) * (2. * n + 1.) / (n * (n + 1.)); double A2 = pow(-1.0, n + 1.0) * n * (n + 1.) / 2.; double A3 = pow(-1.0, n + 0.0) * n * (n + 1.) / 2.; double mu_n = 1 - n * (n + 1.0) / (k * k); std::complex dHnka = - Hnka[n + 1] + (n + 1.) * Hnka[n] / ka; std::complex bn = dHnka.real(); std::complex cn = Hnka[n].real(); if ( k * k >= n * (n+1)) { Etheta += an * (-I * cn * A2 * sqrt(mu_n) + bn * A3 / sqrt(mu_n)); Ephi += an * ( I * cn * A3 * sqrt(mu_n) - bn * A2 / sqrt(mu_n));} else { Etheta += an * (-I * cn * A2 * I * sqrt(-mu_n) - I * bn * A3 / sqrt(-mu_n)); Ephi += an * ( I * cn * A3 * I * sqrt(-mu_n) + I * bn * A2 / sqrt(-mu_n)); } } Etheta *= cos(phi); Ephi *= sin(phi); } else{ for (int n = 1 ; n < ns ; n++){ std::complex an = std::pow(-I, n) * (2. * n + 1.) / (n * (n + 1.)); std::complex dHnka = - Hnka[n + 1] + (n + 1.) * Hnka[n] / ka; std::complex bn = dHnka.real(); std::complex cn = Hnka[n].real(); double mu_n = 1 - n * (n + 1.0) / (k * k); double Pn1 = Legendre(n, 1, ctheta); double Pn11 = Legendre(n+1, 1, ctheta); double dPn1 = n * Pn11 - (n + 1) * ctheta * Pn1 ; if ( k * k >= n * (n+1)) { Etheta += an * (-I * cn * Pn1 * sqrt(mu_n) + bn * dPn1 / sqrt(mu_n)); Ephi += an * ( I * cn * dPn1 * sqrt(mu_n) - bn * Pn1 / sqrt(mu_n));} else { Etheta += an * (-I * cn * Pn1 * I * sqrt(-mu_n) -I * bn * dPn1 / sqrt(-mu_n)); Ephi += an * ( I * cn * dPn1 * I * sqrt(-mu_n) + I * bn * Pn1 / sqrt(-mu_n)); } } Etheta *= cos(phi)/stheta; Ephi *= sin(phi) /stheta; } Etheta *= -I / k; Ephi *= -I / k; // r, theta, phi components std::complex rtp[3] = {Er, Etheta, Ephi}; double mat[3][3]; // r basis vector mat[0][0] = sin(theta) * cos(phi) ; mat[0][1] = sin(theta) * sin(phi) ; mat[0][2] = cos(theta) ; // theta basis vector mat[1][0] = cos(theta) * cos(phi) ; mat[1][1] = cos(theta) * sin(phi) ; mat[1][2] = - sin(theta) ; // phi basis vector mat[2][0] = - sin(phi) ; mat[2][1] = cos(phi); mat[2][2] = 0.; // x, y, z components std::complex xyz[3] = {0., 0., 0.}; for(int i = 0; i < 3; i++) for(int j = 0; j < 3; j++) xyz[i] = xyz[i] + mat[j][i] * rtp[j]; V->Val[0] = xyz[0].real(); V->Val[1] = xyz[1].real(); V->Val[2] = xyz[2].real(); V->Val[MAX_DIM] = xyz[0].imag(); V->Val[MAX_DIM+1] = xyz[1].imag(); V->Val[MAX_DIM+2] = xyz[2].imag(); V->Type = VECTOR ; } // returne n /\ H en -iwt void F_CurrentPerfectlyConductingSphereMwt(F_ARG) { double x = A->Val[0]; double y = A->Val[1]; double z = A->Val[2]; double theta = atan2(sqrt(x * x + y * y), z); double phi = atan2(y, x); double k = Fct->Para[0] ; double a = Fct->Para[1] ; double Z0 = Fct->Para[2] ; double ka = k * a; int ns = (int)k + 10; std::vector > Hnka(ns + 1); for (int n = 1 ; n <= ns ; n++){ Hnka[n] = std::complex(AltSpherical_j_n(n, ka), AltSpherical_y_n(n, ka)); } double ctheta = cos(theta); double stheta = sin(theta); std::complex Er(0.,0), Etheta(0.,0), Ephi(0.,0), I(0, 1.); if( theta == 0.) { for (int n = 1 ; n < ns ; n++){ std::complex an = pow(-I, n) * (2. * n + 1.) / (n * (n + 1.)); double A1 = n * (n + 1.0) / 2.; std::complex dHnka = - Hnka[n + 1] + (n + 1.) * Hnka[n] / ka; std::complex bn = - dHnka.real() / dHnka; std::complex cn = - Hnka[n].real() / Hnka[n]; Etheta += an * (I * cn * dHnka * A1 + bn * Hnka[n] * A1); Ephi += an * (I * cn * dHnka * A1 + bn * Hnka[n] * A1); } Etheta *= (-1. / (Z0*ka)) * (sin(phi)); Ephi *= (-1. / (Z0*ka)) * (cos(phi)); } else if( theta == M_PI) { for (int n = 1 ; n < ns ; n++){ std::complex an = std::pow(-I, n) * (2. * n + 1.) / (n * (n + 1.)); double A2 = pow(-1.0, n + 1.0) * n * (n + 1.) / 2.; double A3 = pow(-1.0, n + 0.0) * n * (n + 1.) / 2.; std::complex dHnka = - Hnka[n + 1] + (n + 1.) * Hnka[n] / ka; std::complex bn = - dHnka.real() / dHnka; std::complex cn = - Hnka[n].real() / Hnka[n]; Etheta += an * (I * cn * dHnka * A3 + bn * Hnka[n] * A2); Ephi += an * (I * cn * dHnka * A2 + bn * Hnka[n] * A3); } Etheta *= (-1.0 / (Z0*ka)) * sin(phi); Ephi *= (-1.0 / (Z0*ka)) * cos(phi); } else{ for (int n = 1 ; n < ns ; n++){ std::complex an = std::pow(-I, n) * (2. * n + 1.) / (n * (n + 1.)); std::complex dHnka = - Hnka[n + 1] + (n + 1.) * Hnka[n] / ka; std::complex bn = - dHnka.real() / dHnka; std::complex cn = - Hnka[n].real() / Hnka[n]; double Pn1 = Legendre(n, 1, ctheta); double Pn11 = Legendre(n+1, 1, ctheta); double dPn1 = n * Pn11 - (n + 1) * ctheta * Pn1 ; Etheta += an * (I * cn * dHnka * dPn1 + bn * Hnka[n] * Pn1 ); Ephi += an * (I * cn * dHnka * Pn1 + bn * Hnka[n] * dPn1); } Etheta *= (-1. / (Z0*ka)) * (sin(phi)/stheta); Ephi *= (-1. / (Z0*ka)) * (cos(phi) /stheta); } // r, theta, phi components std::complex rtp[3] = {Er, -Ephi, Etheta}; double mat[3][3]; // r basis vector mat[0][0] = sin(theta) * cos(phi) ; mat[0][1] = sin(theta) * sin(phi) ; mat[0][2] = cos(theta) ; // theta basis vector mat[1][0] = cos(theta) * cos(phi) ; mat[1][1] = cos(theta) * sin(phi) ; mat[1][2] = - sin(theta) ; // phi basis vector mat[2][0] = - sin(phi) ; mat[2][1] = cos(phi); mat[2][2] = 0.; // x, y, z components std::complex xyz[3] = {0., 0., 0.}; for(int i = 0; i < 3; i++) for(int j = 0; j < 3; j++) xyz[i] = xyz[i] + mat[j][i] * rtp[j]; V->Val[0] = xyz[0].real(); V->Val[1] = xyz[1].real(); V->Val[2] = xyz[2].real(); V->Val[MAX_DIM] = xyz[0].imag(); V->Val[MAX_DIM+1] = xyz[1].imag(); V->Val[MAX_DIM+2] = xyz[2].imag(); V->Type = VECTOR ; } // version avec +iwt /* Scattering by a perfectly conducting sphere of radius R, under plane wave incidence pol*e^{ik \alpha\dot\r}, with alpha = (0,0,-1) and pol = (1,0,0). Returns surface current (From Harrington, Time-harmonic electromagnetic fields, p. 294) */ void F_CurrentPerfectlyConductingSphere(F_ARG) { cplx I = {0., 1.}, tmp, *hn, coef1, coef2, an, jtheta, jphi, rtp[3], xyz[3]; double k, R, r, kR, theta, phi, Z0, ctheta, stheta, Pn0, Pn1, dPn1, mat[3][3], x, y, z ; int n, ns, i, j ; x = A->Val[0]; y = A->Val[1]; z = A->Val[2]; r = sqrt(x*x+y*y+z*z); theta = atan2(sqrt(x*x+y*y), z); phi = atan2(y,x); // warning: approximation if (theta == 0. ) theta += 1e-6; if (theta == M_PI || theta == -M_PI) theta -= 1e-6; k = Fct->Para[0] ; R = Fct->Para[1] ; Z0 = Fct->Para[2] ; // impedance of vacuum = sqrt(mu_0/eps_0) \approx 120*pi kR = k * R; // test position to check if on sphere if(fabs(r - R) > 1.e-3) Message::Error("Evaluation point not on sphere"); V->Val[0] = 0.; V->Val[MAX_DIM] = 0. ; ns = (int)k + 10; hn = (cplx*)Malloc((ns + 1)*sizeof(cplx)); for (n = 0 ; n < ns + 1 ; n++){ hn[n].r = AltSpherical_j_n(n, kR); hn[n].i = - AltSpherical_y_n(n, kR); } ctheta = cos(theta); stheta = sin(theta); jtheta.r = 0; jtheta.i = 0; jphi.r = 0; jphi.i = 0; for (n = 1 ; n < ns ; n++){ // 1 / \hat{H}_n^2 (ka) coef1 = Cdivr( 1.0 , hn[n] ); // 1 / \hat{H}_n^2' (ka) coef2 = Cdivr( 1.0 , Csub( Cprodr( (double)(n+1) / kR , hn[n]) , hn[n+1] ) ); Pn0 = Legendre(n, 0, ctheta); Pn1 = Legendre(n, 1, ctheta); dPn1 = (n+1)*n* Pn0/stheta - (ctheta/(ctheta*ctheta-1))* Pn1; an = Cprodr( (2.*n+1.) / (double)(n * (n+1.)) , Cpow(I, -n) ); tmp = Cprod( an , Csum( Cprodr( stheta * dPn1 , coef2 ) , Cprodr( Pn1 / stheta , Cprod( I , coef1 )) ) ); jtheta = Csum( jtheta, tmp ); tmp = Cprod( an , Csub( Cprodr( Pn1 / stheta , coef2 ) , Cprodr( dPn1 * stheta , Cdiv(coef1 , I)) ) ); jphi = Csum( jphi, tmp ); } Free(hn); tmp = Cprodr( cos(phi)/(kR*Z0), I); jtheta = Cprod( jtheta, tmp ); tmp = Cprodr( sin(phi)/(kR*Z0), I ); jphi = Cprod( jphi, tmp ); // r, theta, phi components rtp[0].r = 0; rtp[0].i = 0; rtp[1] = jtheta; rtp[2] = jphi; // r basis vector mat[0][0] = sin(theta) * cos(phi) ; mat[0][1] = sin(theta) * sin(phi) ; mat[0][2] = cos(theta) ; // theta basis vector mat[1][0] = cos(theta) * cos(phi) ; mat[1][1] = cos(theta) * sin(phi) ; mat[1][2] = - sin(theta) ; // phi basis vector mat[2][0] = - sin(phi) ; mat[2][1] = cos(phi); mat[2][2] = 0.; // x, y, z components for(i = 0; i < 3; i++){ xyz[i].r = 0; xyz[i].i = 0; for(j = 0; j < 3; j++) xyz[i] = Csum( xyz[i] , Cprodr(mat[j][i] , rtp[j]) ); } V->Val[0] = xyz[0].r; V->Val[1] = xyz[1].r; V->Val[2] = xyz[2].r; V->Val[MAX_DIM] = xyz[0].i; V->Val[MAX_DIM+1] = xyz[1].i; V->Val[MAX_DIM+2] = xyz[2].i; V->Type = VECTOR ; } /* Scattering by an acoustically soft sphere (exterior Dirichlet problem) of radius R, under plane wave incidence e^{ikx}. Returns scattered field outside. (Colton and Kress, Inverse Acoustic..., p 51, eq. 3.29) */ void F_AcousticFieldSoftSphere(F_ARG) { cplx I = {0.,1.}, hnkR, hnkr, tmp; double k, R, r, kr, kR, theta, fact ; int n, ns ; r = sqrt(A->Val[0]*A->Val[0] + A->Val[1]*A->Val[1] + A->Val[2]*A->Val[2]) ; theta = acos(A->Val[0] / r); // angle between position vector and (1,0,0) k = Fct->Para[0] ; R = Fct->Para[1] ; kr = k*r; kR = k*R; V->Val[0] = 0.; V->Val[MAX_DIM] = 0. ; ns = (int)k + 10; for (n = 0 ; n < ns ; n++){ hnkR.r = Spherical_j_n(n, kR); hnkR.i = Spherical_y_n(n, kR); hnkr.r = Spherical_j_n(n, kr); hnkr.i = Spherical_y_n(n, kr); tmp = Cdiv( Cprod( Cpow(I,n) , Cprodr(hnkR.r, hnkr) ) , hnkR ); fact = (2*n+1) * Legendre(n, 0, cos(theta)); V->Val[0] += fact * tmp.r; V->Val[MAX_DIM] += fact * tmp.i; } V->Val[0] *= -1; V->Val[MAX_DIM] *= -1; V->Type = SCALAR ; } cplx Dhn_Spherical(cplx *hntab, int n, double x) { return Csub( Cprodr( (double)n/x, hntab[n] ) , hntab[n+1] ); } /* Scattering by an acoustically soft sphere (exterior Dirichlet problem) of radius R, under plane wave incidence e^{ikx}. Returns radial derivative of scattered field outside */ void F_DrAcousticFieldSoftSphere(F_ARG) { cplx I = {0.,1.}, hnkR, tmp, *hnkrtab; double k, R, r, kr, kR, theta, fact ; int n, ns ; r = sqrt(A->Val[0]*A->Val[0] + A->Val[1]*A->Val[1] + A->Val[2]*A->Val[2]) ; theta = acos(A->Val[0] / r); // angle between position vector and (1,0,0) k = Fct->Para[0] ; R = Fct->Para[1] ; kr = k*r; kR = k*R; V->Val[0] = 0.; V->Val[MAX_DIM] = 0. ; ns = (int)k + 10; hnkrtab = (cplx*)Malloc((ns + 1)*sizeof(cplx)); for (n = 0 ; n < ns + 1 ; n++){ hnkrtab[n].r = Spherical_j_n(n, kr); hnkrtab[n].i = Spherical_y_n(n, kr); } for (n = 0 ; n < ns ; n++){ hnkR.r = Spherical_j_n(n, kR); hnkR.i = Spherical_y_n(n, kR); tmp = Cdiv( Cprod( Cpow(I,n) , Cprodr(hnkR.r * k, Dhn_Spherical(hnkrtab, n, kr)) ) , hnkR ); fact = (2*n+1) * Legendre(n, 0, cos(theta)); V->Val[0] += fact * tmp.r; V->Val[MAX_DIM] += fact * tmp.i; } Free(hnkrtab); V->Val[0] *= -1; V->Val[MAX_DIM] *= -1; V->Type = SCALAR ; } /* Scattering by an acoustically soft sphere (exterior Dirichlet problem) of radius R, under plane wave incidence e^{ikx}. Returns RCS. (Colton and Kress, Inverse Acoustic..., p 52, eq. 3.30) */ void F_RCSSoftSphere(F_ARG) { cplx I = {0.,1.}, hnkR, tmp, res; double k, R, r, kR, theta, fact, val ; int n, ns ; r = sqrt(A->Val[0]*A->Val[0] + A->Val[1]*A->Val[1] + A->Val[2]*A->Val[2]) ; theta = acos(A->Val[0] / r); // angle between position vector and (1,0,0) k = Fct->Para[0] ; R = Fct->Para[1] ; kR = k*R; res.r = 0.; res.i = 0. ; ns = (int)k + 10; for (n = 0 ; n < ns ; n++){ hnkR.r = Spherical_j_n(n, kR); hnkR.i = Spherical_y_n(n, kR); tmp = Cdivr( hnkR.r, hnkR ); fact = (2*n+1) * Legendre(n, 0, cos(theta)); res.r += fact * tmp.r; res.i += fact * tmp.i; } val = Cmodu( Cprodr( 1./k , Cprod(res, I) ) ); val *= val; val *= 4. * M_PI; val = 10. * log10(val); V->Val[0] = val; V->Val[MAX_DIM] = 0.; V->Type = SCALAR ; } /* Scattering by an acoustically hard sphere (exterior Neumann problem) of radius R, under plane wave incidence e^{ikx}. Returns scattered field outside */ void F_AcousticFieldHardSphere(F_ARG) { cplx I = {0.,1.}, hnkr, tmp, DhnkR, *hnkRtab; double k, R, r, kr, kR, theta, fact ; int n, ns ; r = sqrt(A->Val[0]*A->Val[0] + A->Val[1]*A->Val[1] + A->Val[2]*A->Val[2]) ; theta = acos(A->Val[0] / r); // angle between position vector and (1,0,0) k = Fct->Para[0] ; R = Fct->Para[1] ; kr = k*r; kR = k*R; V->Val[0] = 0.; V->Val[MAX_DIM] = 0. ; ns = (int)k + 10; hnkRtab = (cplx*)Malloc((ns + 1)*sizeof(cplx)); for (n = 0 ; n < ns + 1 ; n++){ hnkRtab[n].r = Spherical_j_n(n, kR); hnkRtab[n].i = Spherical_y_n(n, kR); } for (n = 0 ; n < ns ; n++){ hnkr.r = Spherical_j_n(n, kr); hnkr.i = Spherical_y_n(n, kr); DhnkR = Dhn_Spherical(hnkRtab, n, kR); tmp = Cdiv( Cprod( Cpow(I,n) , Cprodr(DhnkR.r, hnkr) ) , DhnkR ); fact = (2*n+1) * Legendre(n, 0, cos(theta)); V->Val[0] += fact * tmp.r; V->Val[MAX_DIM] += fact * tmp.i; } Free(hnkRtab); V->Val[0] *= -1; V->Val[MAX_DIM] *= -1; V->Type = SCALAR ; } /* Scattering by an acoustically hard sphere (exterior Dirichlet problem) of radius R, under plane wave incidence e^{ikx}. Returns RCS */ void F_RCSHardSphere(F_ARG) { cplx I = {0.,1.}, DhnkR, tmp, res, *hnkRtab; double k, R, r, kR, theta, fact, val ; int n, ns ; r = sqrt(A->Val[0]*A->Val[0] + A->Val[1]*A->Val[1] + A->Val[2]*A->Val[2]) ; theta = acos(A->Val[0] / r); // angle between position vector and (1,0,0) k = Fct->Para[0] ; R = Fct->Para[1] ; kR = k*R; res.r = 0.; res.i = 0. ; ns = (int)k + 10; hnkRtab = (cplx*)Malloc((ns + 1)*sizeof(cplx)); for (n = 0 ; n < ns + 1 ; n++){ hnkRtab[n].r = Spherical_j_n(n, kR); hnkRtab[n].i = Spherical_y_n(n, kR); } for (n = 0 ; n < ns ; n++){ DhnkR = Dhn_Spherical(hnkRtab, n, kR); tmp = Cdivr( DhnkR.r, DhnkR ); fact = (2*n+1) * Legendre(n, 0, cos(theta)); res.r += fact * tmp.r; res.i += fact * tmp.i; } Free(hnkRtab); val = Cmodu( Cprodr( 1./k , Cprod(res, I) ) ); val *= val; val *= 4. * M_PI; val = 10. * log10(val); V->Val[0] = val; V->Val[MAX_DIM] = 0.; V->Type = SCALAR ; } /* ------------------------------------------------------------------------ */ /* Exact solutions for cylinders */ /* ------------------------------------------------------------------------ */ /* Scattering by solid PEC cylinder, incident wave z-polarized. Returns current on cylinder surface */ void F_JFIE_ZPolCyl(F_ARG) { double k0, r, kr, e0, eta, phi, a, b, c, d, den ; int i, ns ; phi = atan2( A->Val[1], A->Val[0] ) ; k0 = Fct->Para[0] ; eta = Fct->Para[1] ; e0 = Fct->Para[2] ; r = Fct->Para[3] ; kr = k0*r ; ns = 100 ; V->Val[0] = 0.; V->Val[MAX_DIM] = 0. ; for (i = -ns ; i <= ns ; i++ ){ a = cos(i*(phi-(M_PI/2))) ; b = sin(i*(phi-(M_PI/2))) ; c = jn(i,kr) ; d = -yn(i,kr) ; den = c*c+d*d ; V->Val[0] += (a*c+b*d)/den ; V->Val[MAX_DIM] += (b*c-a*d)/den ; } V->Val[0] *= -2*e0/kr/eta/M_PI ; V->Val[MAX_DIM] *= -2*e0/kr/eta/M_PI ; V->Type = SCALAR ; } /* Scattering by solid PEC cylinder, incident wave z-polarized. Returns RCS */ void F_RCS_ZPolCyl(F_ARG) { double k0, r, kr, rinf, krinf, phi, a, b, d,den ; double lambda, bjn, rr = 0., ri = 0. ; int i, ns ; phi = atan2( A->Val[1], A->Val[0] ) ; k0 = Fct->Para[0] ; r = Fct->Para[1] ; rinf = Fct->Para[2] ; kr = k0*r ; krinf = k0*rinf ; lambda = 2*M_PI/k0 ; ns = 100 ; for (i = -ns ; i <= ns ; i++ ){ bjn = jn(i,kr) ; a = bjn * cos(i*phi) ; b = bjn * sin(i*phi) ; d = -yn(i,kr) ; den = bjn*bjn+d*d ; rr += (a*bjn+b*d)/den ; ri += (b*bjn-a*d)/den ; } V->Val[0] = 10*log10( 4*M_PI*SQU(rinf/lambda) * 2/krinf/M_PI *(SQU(rr)+SQU(ri)) ) ; V->Val[MAX_DIM] = 0. ; V->Type = SCALAR ; } /* Scattering by solid PEC cylinder, incident wave polarized transversely to z. Returns current on cylinder surface */ void F_JFIE_TransZPolCyl(F_ARG) { double k0, r, kr, h0, phi, a, b, c, d, den ; int i, ns ; phi = atan2( A->Val[1], A->Val[0] ) ; k0 = Fct->Para[0] ; h0 = Fct->Para[1] ; r = Fct->Para[2] ; kr = k0*r ; ns = 100 ; V->Val[0] = 0.; V->Val[MAX_DIM] = 0. ; for (i = -ns ; i <= ns ; i++ ){ a = cos(M_PI/2 +i*(phi-(M_PI/2))) ; b = sin(M_PI/2 +i*(phi-(M_PI/2))) ; c = -jn(i+1,kr) + (i/kr)*jn(i,kr) ; d = yn(i+1,kr) - (i/kr)*yn(i,kr) ; den = c*c+d*d ; V->Val[0] += (a*c+b*d)/den ; V->Val[MAX_DIM] += (b*c-a*d)/den ; } V->Val[0] *= 2*h0/kr/M_PI ; V->Val[MAX_DIM] *= 2*h0/kr/M_PI ; V->Type = SCALAR ; } /* Scattering by acoustically soft circular cylinder of radius R, under plane wave incidence e^{ikx}. Returns scatterered field outside */ void F_AcousticFieldSoftCylinder(F_ARG) { cplx I = {0.,1.}, HnkR, Hnkr, tmp; double k, R, r, kr, kR, theta, cost ; int n, ns ; theta = atan2(A->Val[1], A->Val[0]) ; r = sqrt(A->Val[0]*A->Val[0] + A->Val[1]*A->Val[1]) ; k = Fct->Para[0] ; R = Fct->Para[1] ; kr = k*r; kR = k*R; V->Val[0] = 0.; V->Val[MAX_DIM] = 0. ; ns = (int)k + 10; for (n = 0 ; n < ns ; n++){ HnkR.r = jn(n,kR); HnkR.i = yn(n,kR); Hnkr.r = jn(n,kr); Hnkr.i = yn(n,kr); tmp = Cdiv( Cprod( Cpow(I,n) , Cprodr( HnkR.r, Hnkr) ) , HnkR ); cost = cos(n*theta); V->Val[0] += cost * tmp.r * (!n ? 0.5 : 1.); V->Val[MAX_DIM] += cost * tmp.i * (!n ? 0.5 : 1.); } V->Val[0] *= -2; V->Val[MAX_DIM] *= -2; V->Type = SCALAR ; } cplx DHn(cplx *Hnkrtab, int n, double x) { if(n == 0){ return Cneg(Hnkrtab[1]); } else{ return Csub( Hnkrtab[n-1] , Cprodr((double)n/x, Hnkrtab[n]) ); } } /* Scattering by acoustically soft circular cylinder of radius R0, under plane wave incidence e^{ikx}, with artificial boundary condition at R1. Returns exact solution of the (interior!) problem between R0 and R1. */ void F_AcousticFieldSoftCylinderABC(F_ARG) { cplx I = {0.,1.}, tmp, alpha1, alpha2, delta, am, bm, lambda, coef; cplx H1nkR0, *H1nkR1tab, *H2nkR1tab, H1nkr, alphaBT, betaBT, keps = {0., 0.}; double k, R0, R1, r, kr, kR0, kR1, theta, cost, sint, kappa ; int n, ns, ABCtype, SingleMode ; theta = atan2(A->Val[1], A->Val[0]) ; r = sqrt(A->Val[0] * A->Val[0] + A->Val[1] * A->Val[1]) ; k = Fct->Para[0] ; R0 = Fct->Para[1] ; R1 = Fct->Para[2] ; ABCtype = (int)Fct->Para[3] ; SingleMode = (int)Fct->Para[4] ; kr = k * r; kR0 = k * R0; kR1 = k * R1; if(ABCtype == 1){ /* Sommerfeld */ lambda = Cprodr(-k, I); } else if(ABCtype == 2){ /* Bayliss-Turkel */ /* alphaBT[] = 1/(2*R1) - I[]/(8*k*R1^2*(1+I[]/(k*R1))); betaBT[] = - 1/(2*I[]*k*(1+I[]/(k*R1))); */ coef.r = 2*k; coef.i = 2/R1; alphaBT = Csubr( 1/(2*R1) , Cdiv(I , Cprodr(4*R1*R1 , coef) ) ); betaBT = Cdiv(I , coef); } else if(ABCtype == 3){ /* Pade */ kappa = 1./R1; /* for circular boundary only! */ keps.r = k; keps.i = 0.4 * pow(k, 1./3.) * pow(kappa, 2./3.); } else{ Message::Error("Unknown ABC type"); } V->Val[0] = 0.; V->Val[MAX_DIM] = 0. ; ns = (int)k + 10; H1nkR1tab = (cplx*)Malloc(ns * sizeof(cplx)); for (n = 0 ; n < ns ; n++){ H1nkR1tab[n].r = jn(n, kR1); H1nkR1tab[n].i = yn(n, kR1); } H2nkR1tab = (cplx*)Malloc(ns * sizeof(cplx)); for (n = 0 ; n < ns ; n++){ H2nkR1tab[n] = Cconj(H1nkR1tab[n]); } for (n = 0 ; n < ns ; n++){ if(SingleMode >= 0 && SingleMode != n) continue; H1nkR0.r = jn(n, kR0); H1nkR0.i = yn(n, kR0); H1nkr.r = jn(n,kr); H1nkr.i = yn(n,kr); if(ABCtype == 2){ lambda = Csum( Csum( Cprodr(-k, I) , alphaBT ) , Cprodr( n*n/(R1*R1) , betaBT ) ); } else if(ABCtype == 3){ lambda = Cprod( Cprodr(-k, I) , Cpow( Csubr(1 , Cdivr(n*n/(R1*R1) , Cprod(keps , keps))) , 0.5)); } alpha1 = Csum( Cprodr(k, DHn(H1nkR1tab, n, kR1)) , Cprod(lambda, H1nkR1tab[n]) ); alpha2 = Csum( Cprodr(k, DHn(H2nkR1tab, n, kR1)) , Cprod(lambda, H2nkR1tab[n]) ); delta = Csub( Cprod( alpha1 , Cconj(H1nkR0) ) , Cprod( alpha2 , H1nkR0 ) ); if(Cmodu(delta) < 1.e-6) break; am = Cdiv( Cprodr(H1nkR0.r, alpha2) , delta ); bm = Cdiv( Cprodr(-H1nkR0.r, alpha1) , delta ); if(SingleMode >= 0 && SingleMode == n){ tmp = Csum( Cprod( am , H1nkr ) , Cprod( bm , Cconj(H1nkr) ) ); cost = cos(n * theta); sint = sin(n * theta); V->Val[0] += cost * tmp.r - sint * tmp.i; V->Val[MAX_DIM] += cost * tmp.i + sint * tmp.r; } else{ tmp = Cprod( Cpow(I,n) , Csum( Cprod( am , H1nkr ) , Cprod( bm , Cconj(H1nkr) ) ) ); cost = cos(n * theta); V->Val[0] += cost * tmp.r * (!n ? 0.5 : 1.); V->Val[MAX_DIM] += cost * tmp.i * (!n ? 0.5 : 1.); } } Free(H1nkR1tab); Free(H2nkR1tab); if(SingleMode < 0){ V->Val[0] *= 2; V->Val[MAX_DIM] *= 2; } V->Type = SCALAR ; } /* Scattering by acoustically soft circular cylinder of radius R, under plane wave incidence e^{ikx}. Returns radial derivative of the solution of the Helmholtz equation outside */ void F_DrAcousticFieldSoftCylinder(F_ARG) { cplx I = {0.,1.}, HnkR, tmp, *Hnkrtab; double k, R, r, kr, kR, theta, cost ; int n, ns ; theta = atan2(A->Val[1], A->Val[0]) ; r = sqrt(A->Val[0]*A->Val[0] + A->Val[1]*A->Val[1]) ; k = Fct->Para[0] ; R = Fct->Para[1] ; kr = k*r; kR = k*R; V->Val[0] = 0.; V->Val[MAX_DIM] = 0. ; ns = (int)k + 10; Hnkrtab = (cplx*)Malloc(ns*sizeof(cplx)); for (n = 0 ; n < ns ; n++){ Hnkrtab[n].r = jn(n,kr); Hnkrtab[n].i = yn(n,kr); } for (n = 0 ; n < ns ; n++){ HnkR.r = jn(n,kR); HnkR.i = yn(n,kR); tmp = Cdiv( Cprod( Cpow(I,n) , Cprodr( HnkR.r, DHn(Hnkrtab, n, kr) ) ) , HnkR ); cost = cos(n*theta); V->Val[0] += cost * tmp.r * (!n ? 0.5 : 1.); V->Val[MAX_DIM] += cost * tmp.i * (!n ? 0.5 : 1.); } Free(Hnkrtab); V->Val[0] *= -2 * k; V->Val[MAX_DIM] *= -2 * k; V->Type = SCALAR ; } /* Scattering by acoustically soft circular cylinder of radius R, under plane wave incidence e^{ikx}. Returns RCS */ void F_RCSSoftCylinder(F_ARG) { cplx I = {0.,1.}, HnkR, Hnkr, res, tmp; double k, R, r, kR, theta, cost, val ; int n, ns ; theta = atan2(A->Val[1], A->Val[0]) ; r = sqrt(A->Val[0]*A->Val[0] + A->Val[1]*A->Val[1]) ; k = Fct->Para[0] ; R = Fct->Para[1] ; kR = k*R; res.r = 0.; res.i = 0. ; ns = (int)k + 10; for (n = 0 ; n < ns ; n++){ HnkR.r = jn(n,kR); HnkR.i = yn(n,kR); /* leaving r in following asymptotic formula for clarity (see Colton and Kress, Inverse Acoustic..., p. 65, eq. 3.59) */ Hnkr.r = cos(k*r - n*M_PI/2. - M_PI/4.) / sqrt(k*r) * sqrt(2./M_PI); Hnkr.i = sin(k*r - n*M_PI/2. - M_PI/4.) / sqrt(k*r) * sqrt(2./M_PI); tmp = Cdiv( Cprod( Cpow(I,n) , Cprodr( HnkR.r, Hnkr) ) , HnkR ); cost = cos(n*theta); res.r += cost * tmp.r * (!n ? 0.5 : 1.); res.i += cost * tmp.i * (!n ? 0.5 : 1.); } res.r *= -2; res.i *= -2; val = Cmodu(res); val *= val; val *= 2. * M_PI * r; val = 10. * log10(val); V->Val[0] = val; V->Val[MAX_DIM] = 0.; V->Type = SCALAR ; } /* Scattering by acoustically hard circular cylinder of radius R, under plane wave incidence e^{ikx}. Returns scatterered field outside */ void F_AcousticFieldHardCylinder(F_ARG) { cplx I = {0.,1.}, Hnkr, dHnkR, tmp, *HnkRtab; double k, R, r, kr, kR, theta, cost ; int n, ns ; theta = atan2(A->Val[1], A->Val[0]) ; r = sqrt(A->Val[0]*A->Val[0] + A->Val[1]*A->Val[1]) ; k = Fct->Para[0] ; R = Fct->Para[1] ; kr = k*r; kR = k*R; V->Val[0] = 0.; V->Val[MAX_DIM] = 0. ; ns = (int)k + 10; HnkRtab = (cplx*)Malloc(ns*sizeof(cplx)); for (n = 0 ; n < ns ; n++){ HnkRtab[n].r = jn(n,kR); HnkRtab[n].i = yn(n,kR); } for (n = 0 ; n < ns ; n++){ Hnkr.r = jn(n,kr); Hnkr.i = yn(n,kr); dHnkR = DHn(HnkRtab, n, kR); tmp = Cdiv( Cprod( Cpow(I,n) , Cprodr( dHnkR.r, Hnkr) ) , dHnkR ); cost = cos(n*theta); V->Val[0] += cost * tmp.r * (!n ? 0.5 : 1.); V->Val[MAX_DIM] += cost * tmp.i * (!n ? 0.5 : 1.); } Free(HnkRtab); V->Val[0] *= -2; V->Val[MAX_DIM] *= -2; V->Type = SCALAR ; } /* Scattering by acoustically hard circular cylinder of radius R, under plane wave incidence e^{ikx}. Returns the angular derivative of the solution outside */ void F_DthetaAcousticFieldHardCylinder(F_ARG) { cplx I = {0.,1.}, Hnkr, dHnkR, tmp, *HnkRtab; double k, R, r, kr, kR, theta, sint ; int n, ns ; theta = atan2(A->Val[1], A->Val[0]) ; r = sqrt(A->Val[0]*A->Val[0] + A->Val[1]*A->Val[1]) ; k = Fct->Para[0] ; R = Fct->Para[1] ; kr = k*r; kR = k*R; V->Val[0] = 0.; V->Val[MAX_DIM] = 0. ; ns = (int)k + 10; HnkRtab = (cplx*)Malloc(ns*sizeof(cplx)); for (n = 0 ; n < ns ; n++){ HnkRtab[n].r = jn(n,kR); HnkRtab[n].i = yn(n,kR); } for (n = 0 ; n < ns ; n++){ Hnkr.r = jn(n,kr); Hnkr.i = yn(n,kr); dHnkR = DHn(HnkRtab, n, kR); tmp = Cdiv( Cprod( Cpow(I,n) , Cprodr( dHnkR.r, Hnkr) ) , dHnkR ); sint = sin(n*theta); V->Val[0] += - n * sint * tmp.r * (!n ? 0.5 : 1.); V->Val[MAX_DIM] += - n * sint * tmp.i * (!n ? 0.5 : 1.); } Free(HnkRtab); V->Val[0] *= -2 ; V->Val[MAX_DIM] *= -2 ; V->Type = SCALAR ; } /* Scattering by acoustically hard circular cylinder of radius R0, under plane wave incidence e^{ikx}, with artificial boundary condition at R1. Returns exact solution of the (interior!) problem between R0 and R1. */ void F_AcousticFieldHardCylinderABC(F_ARG) { cplx I = {0.,1.}, tmp, alpha1, alpha2, delta, am, bm, lambda, coef; cplx *H1nkR0tab, *H2nkR0tab, *H1nkR1tab, *H2nkR1tab, H1nkr, alphaBT, betaBT; double k, R0, R1, r, kr, kR0, kR1, theta, cost, sint ; int n, ns, ABCtype, SingleMode ; theta = atan2(A->Val[1], A->Val[0]) ; r = sqrt(A->Val[0] * A->Val[0] + A->Val[1] * A->Val[1]) ; k = Fct->Para[0] ; R0 = Fct->Para[1] ; R1 = Fct->Para[2] ; ABCtype = (int)Fct->Para[3] ; SingleMode = (int)Fct->Para[4] ; kr = k * r; kR0 = k * R0; kR1 = k * R1; if(ABCtype == 1){ /* Sommerfeld */ lambda = Cprodr(-k, I); } else if(ABCtype == 2){ /* Bayliss-Turkel */ /* alphaBT[] = 1/(2*R1) - I[]/(8*k*R1^2*(1+I[]/(k*R1))); betaBT[] = - 1/(2*I[]*k*(1+I[]/(k*R1))); */ coef.r = 2*k; coef.i = 2/R1; alphaBT = Csubr( 1/(2*R1) , Cdiv(I , Cprodr(4*R1*R1 , coef) ) ); betaBT = Cdiv(I , coef); } else{ Message::Error("Unknown ABC type"); } V->Val[0] = 0.; V->Val[MAX_DIM] = 0. ; ns = (int)k + 10; H1nkR0tab = (cplx*)Malloc(ns * sizeof(cplx)); for (n = 0 ; n < ns ; n++){ H1nkR0tab[n].r = jn(n, kR0); H1nkR0tab[n].i = yn(n, kR0); } H2nkR0tab = (cplx*)Malloc(ns * sizeof(cplx)); for (n = 0 ; n < ns ; n++){ H2nkR0tab[n] = Cconj(H1nkR0tab[n]); } H1nkR1tab = (cplx*)Malloc(ns * sizeof(cplx)); for (n = 0 ; n < ns ; n++){ H1nkR1tab[n].r = jn(n, kR1); H1nkR1tab[n].i = yn(n, kR1); } H2nkR1tab = (cplx*)Malloc(ns * sizeof(cplx)); for (n = 0 ; n < ns ; n++){ H2nkR1tab[n] = Cconj(H1nkR1tab[n]); } for (n = 0 ; n < ns ; n++){ if(SingleMode >= 0 && SingleMode != n) continue; H1nkr.r = jn(n,kr); H1nkr.i = yn(n,kr); if(ABCtype == 2){ lambda = Csum( Csum( Cprodr(-k, I) , alphaBT ) , Cprodr( n*n/(R1*R1) , betaBT ) ); } alpha1 = Csum( Cprodr(k, DHn(H1nkR1tab, n, kR1)) , Cprod(lambda, H1nkR1tab[n]) ); alpha2 = Csum( Cprodr(k, DHn(H2nkR1tab, n, kR1)) , Cprod(lambda, H2nkR1tab[n]) ); delta = Cprodr( k , Csub( Cprod( alpha1 , DHn(H2nkR0tab, n, kR0) ) , Cprod( alpha2 , DHn(H1nkR0tab, n, kR0) ) ) ); if(Cmodu(delta) < 1.e-6) break; am = Cdiv( Cprodr(k * DHn(H1nkR0tab, n, kR0).r, alpha2) , delta ); bm = Cdiv( Cprodr(-k * DHn(H1nkR0tab, n, kR0).r, alpha1) , delta ); if(SingleMode >= 0 && SingleMode == n){ tmp = Csum( Cprod( am , H1nkr ) , Cprod( bm , Cconj(H1nkr) ) ) ; cost = cos(n * theta); sint = sin(n * theta); V->Val[0] += cost * tmp.r - sint * tmp.i; V->Val[MAX_DIM] += cost * tmp.i + sint * tmp.r; } else{ tmp = Cprod( Cpow(I,n) , Csum( Cprod( am , H1nkr ) , Cprod( bm , Cconj(H1nkr) ) ) ); cost = cos(n * theta); V->Val[0] += cost * tmp.r * (!n ? 0.5 : 1.); V->Val[MAX_DIM] += cost * tmp.i * (!n ? 0.5 : 1.); } } Free(H1nkR0tab); Free(H2nkR0tab); Free(H1nkR1tab); Free(H2nkR1tab); if(SingleMode < 0){ V->Val[0] *= 2; V->Val[MAX_DIM] *= 2; } V->Type = SCALAR ; } /* Scattering by acoustically hard circular cylinder of radius R, under plane wave incidence e^{ikx}. Returns RCS. */ void F_RCSHardCylinder(F_ARG) { cplx I = {0.,1.}, Hnkr, dHnkR, res, tmp, *HnkRtab; double k, R, r, kR, theta, cost, val ; int n, ns ; theta = atan2(A->Val[1], A->Val[0]) ; r = sqrt(A->Val[0]*A->Val[0] + A->Val[1]*A->Val[1]) ; k = Fct->Para[0] ; R = Fct->Para[1] ; kR = k*R; res.r = 0.; res.i = 0. ; ns = (int)k + 10; HnkRtab = (cplx*)Malloc(ns*sizeof(cplx)); for (n = 0 ; n < ns ; n++){ HnkRtab[n].r = jn(n,kR); HnkRtab[n].i = yn(n,kR); } for (n = 0 ; n < ns ; n++){ /* leaving r in following asymptotic formula for clarity (see Colton and Kress, Inverse Acoustic..., p. 65, eq. 3.59) */ Hnkr.r = cos(k*r - n*M_PI/2. - M_PI/4.) / sqrt(k*r) * sqrt(2./M_PI); Hnkr.i = sin(k*r - n*M_PI/2. - M_PI/4.) / sqrt(k*r) * sqrt(2./M_PI); dHnkR = DHn(HnkRtab, n, kR); tmp = Cdiv( Cprod( Cpow(I,n) , Cprodr( dHnkR.r, Hnkr) ) , dHnkR ); cost = cos(n*theta); res.r += cost * tmp.r * (!n ? 0.5 : 1.); res.i += cost * tmp.i * (!n ? 0.5 : 1.); } Free(HnkRtab); res.r *= -2; res.i *= -2; val = Cmodu(res); val *= val; val *= 2. * M_PI * r; val = 10. * log10(val); V->Val[0] = val; V->Val[MAX_DIM] = 0.; V->Type = SCALAR ; } /* ------------------------------------------------------------------------ */ /* On Surface Radiation Conditions (OSRC) */ /* ------------------------------------------------------------------------ */ /* Coefficients C0, Aj and Bj: see papers 1) Kechroud, Antoine & Soulaimani, Nuemrical accuracy of a Pade-type non-reflecting..., IJNME 2005 2) Antoine, Darbas & Lu, An improved surface radiation condition... CMAME, 2006(?) */ static double aj(int j, int N) { return 2./(2.*N + 1.) * SQU(sin((double)j * M_PI/(2.*N + 1.))) ; } static double bj(int j, int N) { return SQU(cos((double)j * M_PI/(2.*N + 1.))) ; } void F_OSRC_C0(F_ARG) { int j, N; double theta; cplx sum = {1., 0.}, z, un = {1., 0.}; N = (int)Fct->Para[0] ; theta = Fct->Para[1] ; z.r = cos(-theta) - 1. ; z.i = sin(-theta) ; for(j = 1; j <= N; j++){ sum = Csum( sum, Cdiv( Cprodr(aj(j,N), z) , Csum(un, Cprodr(bj(j,N), z)))) ; } z.r = cos(theta/2.) ; z.i = sin(theta/2.) ; sum = Cprod(sum, z); V->Val[0] = sum.r; V->Val[MAX_DIM] = sum.i; V->Type = SCALAR ; } void F_OSRC_Aj(F_ARG) { int j, N; double theta; cplx z, res, un = {1., 0.}; j = (int)Fct->Para[0] ; N = (int)Fct->Para[1] ; theta = Fct->Para[2] ; z.r = cos(-theta/2.) ; z.i = sin(-theta/2.) ; res = Cprodr(aj(j,N), z); z.r = cos(-theta) - 1. ; z.i = sin(-theta) ; res = Cdiv(res, Cpow( Csum(un, Cprodr(bj(j,N), z)), 2.)); V->Val[0] = res.r; V->Val[MAX_DIM] = res.i; V->Type = SCALAR ; } void F_OSRC_Bj(F_ARG) { int j, N; double theta; cplx z, res, un = {1., 0.}; j = (int)Fct->Para[0] ; N = (int)Fct->Para[1] ; theta = Fct->Para[2] ; z.r = cos(-theta) ; z.i = sin(-theta) ; res = Cprodr(bj(j,N), z); z.r = cos(-theta) - 1. ; z.i = sin(-theta) ; res = Cdiv(res, Csum(un, Cprodr(bj(j,N), z))); V->Val[0] = res.r; V->Val[MAX_DIM] = res.i; V->Type = SCALAR ; } #undef F_ARG getdp-2.4.2-source/Legacy/F_Hysteresis.cpp000644 001750 001750 00000074632 12211017577 022136 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Johan Gyselinck // #include #include "ProData.h" #include "F.h" #include "Message.h" #include #define SQU(a) ((a)*(a)) #define MU0 1.25663706144e-6 /* ------------------------------------------------------------------------ */ /* Vectorized Jiles-Atherton hysteresis model J. Gyselinck, P. Dular, N. Sadowski, J. Leite and J.P.A. Bastos, "Incorporation of a Jiles-Atherton vector hysteresis model in 2D FE magnetic field computations. Application of the Newton-Raphson method", Vol. 23, No. 3, pp. 685-693, 2004. */ double F_Man (double He, double Ms, double a) { // Anhysteretic magnetisation if (fabs(He) < 0.01*a) return Ms*He/(3.*a) ; else return Ms*(cosh(He/a)/sinh(He/a)-a/He) ; } double F_dMandHe (double He, double Ms, double a) { // Derivative of the magnetisation Man with respect to the effective field He if (fabs(He) < 0.01*a) return Ms/(3.*a) ; else return Ms/a*(1-SQU(cosh(He/a)/sinh(He/a))+SQU(a/He)) ; } void FV_Man (double He[3], double Ms, double a, double Man[3]) { double nHe = sqrt(He[0]*He[0]+He[1]*He[1]+He[2]*He[2]) ; if ( !nHe ) { Man[0] = Man[1] = Man[2]= 0. ; } else { double auxMan = F_Man(nHe, Ms, a) ; Man[0] = auxMan * He[0]/nHe ; Man[1] = auxMan * He[1]/nHe ; Man[2] = auxMan * He[2]/nHe ; } } void FV_dMandHe(double He[3], double Ms, double a, double dMandHe[6]) { double nHe = sqrt(He[0]*He[0]+He[1]*He[1]+He[2]*He[2]) ; double Man = F_Man(nHe, Ms, a) ; double ndMandHe = F_dMandHe(nHe,Ms,a) ; if ( !nHe ) { dMandHe[0] = dMandHe[3] = dMandHe[5] = ndMandHe ; dMandHe[1] = dMandHe[2] = dMandHe[4] = 0 ; } else { dMandHe[0] = Man/nHe + (ndMandHe - Man/nHe)*He[0]*He[0]/(nHe*nHe) ; dMandHe[3] = Man/nHe + (ndMandHe - Man/nHe)*He[1]*He[1]/(nHe*nHe) ; dMandHe[5] = Man/nHe + (ndMandHe - Man/nHe)*He[2]*He[2]/(nHe*nHe) ; dMandHe[1] = (ndMandHe - Man/nHe)*He[0]*He[1]/(nHe*nHe) ; dMandHe[2] = (ndMandHe - Man/nHe)*He[0]*He[2]/(nHe*nHe) ; dMandHe[4] = (ndMandHe - Man/nHe)*He[1]*He[2]/(nHe*nHe) ; } } void FV_dMidHe(double He[3], double Man[3], double Mi[3], double dH[3], double k, double dMidHe[6]) { double dM = sqrt( (Man[0]-Mi[0])*(Man[0]-Mi[0]) + (Man[1]-Mi[1])*(Man[1]-Mi[1]) + (Man[2]-Mi[2])*(Man[2]-Mi[2]) ) ; if ( !dM || (Man[0]-Mi[0])*dH[0] + (Man[1]-Mi[1])*dH[1] + (Man[2]-Mi[2])*dH[2] < 0 ) { dMidHe[0] = dMidHe[3] = dMidHe[5] = dMidHe[1] = dMidHe[2] = dMidHe[4] = 0 ; } else { double kdM = k * dM; dMidHe[0] = (Man[0]-Mi[0])*(Man[0]-Mi[0]) / kdM ; dMidHe[3] = (Man[1]-Mi[1])*(Man[1]-Mi[1]) / kdM ; dMidHe[5] = (Man[2]-Mi[2])*(Man[2]-Mi[2]) / kdM ; dMidHe[1] = (Man[0]-Mi[0])*(Man[1]-Mi[1]) / kdM ; dMidHe[2] = (Man[0]-Mi[0])*(Man[2]-Mi[2]) / kdM ; dMidHe[4] = (Man[1]-Mi[1])*(Man[2]-Mi[2]) / kdM ; } } void Vector_dBdH(double H[3], double B[3], double dH[3], struct FunctionActive *D, double dBdH[6]) { double M[3], He[3], Man[3], Mi[3] ; double dMandHe[6], dMidHe[6], dMdH[6] ; double d[6], e[6], f[6] ; if (D->Case.Interpolation.NbrPoint != 5) Message::Error("Jiles-Atherton parameters missing: {List[{Ms, a, k, c, alpha}]}"); double Ms = D->Case.Interpolation.x[0] ; double a = D->Case.Interpolation.x[1] ; double kk = D->Case.Interpolation.x[2] ; double c = D->Case.Interpolation.x[3] ; double alpha = D->Case.Interpolation.x[4] ; for (int i=0 ; i<3 ; i++){ M[i] = B[i]/MU0 - H[i] ; // Magnetisation He[i] = H[i] + alpha * M[i] ; // Effective field } FV_Man (He, Ms, a, Man) ; for (int i=0 ; i<3 ; i++) Mi[i] = (M[i]-c*Man[i]) / (1-c) ; // Irreversible magnetisation FV_dMandHe(He, Ms, a, dMandHe) ; FV_dMidHe(He, Man, Mi, dH, kk, dMidHe) ; d[0] = 1 - alpha*c*dMandHe[0] - alpha*(1-c)*dMidHe[0] ; // xx d[3] = 1 - alpha*c*dMandHe[3] - alpha*(1-c)*dMidHe[3] ; // yy d[5] = 1 - alpha*c*dMandHe[5] - alpha*(1-c)*dMidHe[5] ; // zz d[1] = - alpha*c*dMandHe[1] - alpha*(1-c)*dMidHe[1] ; // xy d[2] = - alpha*c*dMandHe[2] - alpha*(1-c)*dMidHe[2] ; // xz d[4] = - alpha*c*dMandHe[4] - alpha*(1-c)*dMidHe[4] ; // zz double dd = d[0] * (d[3] *d[5] - d[4] *d[4]) - d[1] * (d[1] *d[5] - d[4] *d[2]) + d[2] * (d[1] *d[4] - d[3] *d[2]); e[0] = (d[3]*d[5]-d[4]*d[4])/dd ; e[1] = -(d[1]*d[5]-d[2]*d[4])/dd ; e[2] = (d[1]*d[4]-d[2]*d[3])/dd ; e[3] = (d[0]*d[5]-d[2]*d[2])/dd ; e[4] = -(d[0]*d[4]-d[1]*d[2])/dd ; e[5] = (d[0]*d[3]-d[1]*d[1])/dd ; for (int i=0 ; i<6 ; i++) f[i] = c*dMandHe[i] + (1-c)*dMidHe[i] ; dMdH[0] = e[0]*f[0]+e[1]*f[1]+e[2]*f[2] ; dMdH[1] = e[0]*f[1]+e[1]*f[3]+e[2]*f[4] ; dMdH[2] = e[0]*f[2]+e[1]*f[4]+e[2]*f[5] ; dMdH[3] = e[1]*f[1]+e[3]*f[3]+e[4]*f[4] ; dMdH[4] = e[1]*f[2]+e[3]*f[4]+e[4]*f[5] ; dMdH[5] = e[2]*f[2]+e[4]*f[4]+e[5]*f[5] ; dBdH[0] = MU0 * (100.0 + dMdH[0]) ; // 100 for better convergence, forcing a bit of slope in NR iterations dBdH[3] = MU0 * (100.0 + dMdH[3]) ; dBdH[5] = MU0 * (100.0 + dMdH[5]) ; dBdH[1] = MU0 * dMdH[1] ; dBdH[2] = MU0 * dMdH[2] ; dBdH[4] = MU0 * dMdH[4] ; } void Vector_dHdB(double H[3], double B[3], double dH[3], struct FunctionActive *D, double dHdB[6]) { double dBdH[6] ; // Inverting the matrix representation of the db/dh we get dh/db Vector_dBdH (H, B, dH, D, dBdH) ; double det = dBdH[0] * (dBdH[3] *dBdH[5] - dBdH[4] *dBdH[4]) - dBdH[1] * (dBdH[1] *dBdH[5] - dBdH[4] *dBdH[2]) + dBdH[2] * (dBdH[1] *dBdH[4] - dBdH[3] *dBdH[2]); if (!det) Message::Error("Null determinant of db/dh!"); dHdB[0] = (dBdH[3]*dBdH[5]-dBdH[4]*dBdH[4])/det ; dHdB[1] = -(dBdH[1]*dBdH[5]-dBdH[2]*dBdH[4])/det ; dHdB[2] = (dBdH[1]*dBdH[4]-dBdH[2]*dBdH[3])/det ; dHdB[3] = (dBdH[0]*dBdH[5]-dBdH[2]*dBdH[2])/det ; dHdB[4] = -(dBdH[0]*dBdH[4]-dBdH[1]*dBdH[2])/det ; dHdB[5] = (dBdH[0]*dBdH[3]-dBdH[1]*dBdH[1])/det ; } void F_dhdb_Jiles(F_ARG) { // input : h, b ,dh // dhdb_Jiles[{h}, {d a}, {h}-{h}[1] ]{List[hyst_FeSi]} // Material parameters: e.g. hyst_FeSi = { Msat, a, k, c, alpha};==> struct FunctionActive *D double H[3], B[3], dH[3], dHdB[6] ; struct FunctionActive * D ; if( (A+0)->Type != VECTOR || (A+1)->Type != VECTOR || (A+2)->Type != VECTOR ) Message::Error("Three vector arguments required"); if (!Fct->Active) Fi_InitListX (Fct, A, V) ; D = Fct->Active ; for (int k=0 ; k<3 ; k++){ H[k] = (A+0)->Val[k] ; B[k] = (A+1)->Val[k] ; dH[k] = (A+2)->Val[k] ; } Vector_dHdB (H, B, dH, D, dHdB) ; V->Type = TENSOR_SYM ;// xx, xy, xz, yy, yz, zz for (int k=0 ; k<6 ; k++) V->Val[k] = dHdB[k] ; } void F_dbdh_Jiles(F_ARG) { // input : h, b, dh // dbdh_Jiles[{h}, {d a}, {h}-{h}[1] ]{List[hyst_FeSi]} // Material parameters: e.g. hyst_FeSi = { Msat, a, k, c, alpha};==> struct FunctionActive *D double H[3], B[3], dH[3], dBdH[6] ; struct FunctionActive *D; if( (A+0)->Type != VECTOR || (A+1)->Type != VECTOR || (A+2)->Type != VECTOR ) Message::Error("dbdh_Jiles requires three vector: {h} at t_i, {b} at t_i and ({h}-{h}[1]), i.e {h} at t_i - {h} at t_{i-1}"); if (!Fct->Active) Fi_InitListX (Fct, A, V) ; D = Fct->Active ; for (int k=0 ; k<3 ; k++){ H[k] = (A+0)->Val[k] ; B[k] = (A+1)->Val[k] ; dH[k] = (A+2)->Val[k] ; } Vector_dBdH (H, B, dH, D, dBdH) ; V->Type = TENSOR_SYM ; for (int k=0 ; k<6 ; k++) V->Val[k] = dBdH[k] ; } void F_h_Jiles(F_ARG) { // input : h1, b1, b2 // h_Jiles[ {h}[1], {b}[1], {b} ]{List[hyst_FeSi]} // Material parameters: e.g. hyst_FeSi = { Msat, a, k, c, alpha}; double Hone[3], Bone[3], Btwo[3], Htwo[3] ; struct FunctionActive *D; void Vector_H2 (double Hone[3], double Bone[3], double Btwo[3], int n, struct FunctionActive *D, double Htwo[3]) ; if( (A+0)->Type != VECTOR || (A+1)->Type != VECTOR || (A+2)->Type != VECTOR ) Message::Error("h_Jiles requires three vector arguments: {h} at t_{i-1}, {b} at t_{i-1} and {b} at t_i"); if (!Fct->Active) Fi_InitListX (Fct, A, V) ; D = Fct->Active ; for (int k=0 ; k<3 ; k++) { Hone[k] = (A+0)->Val[k] ; Bone[k] = (A+1)->Val[k] ; Btwo[k] = (A+2)->Val[k] ; } Vector_H2 (Hone, Bone, Btwo, 10, D, Htwo) ; V->Type = VECTOR ; for (int k=0 ; k<3 ; k++) V->Val[k] = Htwo[k] ; } void F_b_Jiles(F_ARG) { // input : b1, h1, h2 // b_Jiles[ {b}[1], {h}[1], {h} ]{List[hyst_FeSi]} // Material parameters: e.g. hyst_FeSi = { Msat, a, k, c, alpha}; double Bone[3], Hone[3], Btwo[3], Htwo[3] ; struct FunctionActive * D ; void Vector_B2 (double Bone[3], double Hone[3], double Htwo[3], int n, struct FunctionActive *D, double Btwo[3]) ; if( (A+0)->Type != VECTOR || (A+1)->Type != VECTOR || (A+2)->Type != VECTOR ) Message::Error("b_Jiles requires three vector arguments: {b} at t_{i-1}, " "{h} at t_{i-1} and {h} at t_i"); if (!Fct->Active) Fi_InitListX (Fct, A, V) ; D = Fct->Active ; for (int k = 0; k < 3 ; k++){ Bone[k] = (A+0)->Val[k] ; Hone[k] = (A+1)->Val[k] ; Htwo[k] = (A+2)->Val[k] ; } Vector_B2 (Bone, Hone, Htwo, 10, D, Btwo) ; V->Type = VECTOR ; for (int k = 0; k < 3 ; k++) V->Val[k] = Btwo[k] ; } void Vector_H2 (double Hone[3], double Bone[3], double Btwo[3], int n, struct FunctionActive *D, double Htwo[3]) { double H[3], dH[3], B[3], dB[3] ; double dHdB[6] ; for (int k=0 ; k<3 ; k++) { H[k] = Hone[k]; dB[k] = (Btwo[k] - Bone[k])/(double)n ; } for (int i=0 ; i (b,h) The final flux density b is imposed. In practice, the magnetic field is given by: /b h(b) = | (dh/db).db /b0 where the values of (dh/db) are functions of (b,h) and are interpolated from a provided table {bi, hi, M, NL, NC}, obtained e.g. experimentally. bi Flux density (T) for the tabulated values hi Magnetic field (A/m) for the tabulated values M Matrix with the slopes of reversal paths NL Number of lines NC Number of columns b0 Initial flux density (T) h0 Initial magnetic field (A/m) b Final flux density (T) */ /* ------------------------------------------------------------------------ */ double Fi_h_Ducharne (double *hi, double *bi, double *M, int NL, int NC, double h0, double b0, double b) { double db, dh, dHdB, s; int i, N = 200 ; // fixed number of steps for numerical integration db = (b - b0)/N ; s = (b - b0 < 0) ? -1. : 1. ; for (i=0 ; i < N ; ++i) { bool IsInGrid = Fi_InterpolationBilinear(hi, bi, M, NL, NC, s*h0, s*b0, &dHdB); if (!IsInGrid) dHdB = MU0 ; dh = dHdB * db; h0 += dh; b0 += db; } return h0 ; } void F_h_Ducharne(F_ARG) { int NL, NC, i; double b0, h0, b, h, *bi, *hi, *M; struct FunctionActive * D; if (!Fct->Active) Fi_InitListMatrix (Fct, A, V) ; D = Fct->Active ; NL = D->Case.ListMatrix.NbrLines ; NC = D->Case.ListMatrix.NbrColumns ; hi = D->Case.ListMatrix.x ; bi = D->Case.ListMatrix.y ; M = D->Case.ListMatrix.data ; for (i=0 ; i<3 ; ++i) { // (h0,b0) = state of the model, and b h0 = (A+0)->Val[i] ; b0 = (A+1)->Val[i] ; b = (A+2)->Val[i] ; // Compute the magnetic field h = Fi_h_Ducharne (hi, bi, M, NL, NC, h0, b0, b); V->Val[i] = h; } V->Type = VECTOR ; } void F_nu_Ducharne(F_ARG) { int NL, NC, i; double b0, h0, b[3], h[3], *bi, *hi, *M; struct FunctionActive * D; if (!Fct->Active) Fi_InitListMatrix (Fct, A, V) ; D = Fct->Active ; NL = D->Case.ListMatrix.NbrLines ; NC = D->Case.ListMatrix.NbrColumns ; hi = D->Case.ListMatrix.x ; bi = D->Case.ListMatrix.y ; M = D->Case.ListMatrix.data ; for (i=0 ; i<3 ; ++i) { // Get (h0,b0) = state of the model, and b h0 = (A+0)->Val[i] ; b0 = (A+1)->Val[i] ; b[i] = (A+2)->Val[i] ; // Compute h h[i] = Fi_h_Ducharne (hi, bi, M, NL, NC, h0, b0, b[i]); } V->Type = TENSOR_SYM ; V->Val[0] = (b[0] == 0) ? 1/(1e4*MU0) : h[0]/b[0] ; V->Val[1] = 0.0 ; V->Val[2] = 0 ; V->Val[3] = (b[1] == 0) ? 1/(1e4*MU0) : h[1]/b[1] ; V->Val[4] = 0 ; V->Val[5] = (b[2] == 0) ? 1/(1e4*MU0) : h[2]/b[2] ; } void F_dhdb_Ducharne(F_ARG) { int NL, NC, i; double b0, h0, b[3], *bi, *hi, *M, dHdB[3], s; struct FunctionActive * D; if (!Fct->Active) Fi_InitListMatrix (Fct, A, V) ; D = Fct->Active ; NL = D->Case.ListMatrix.NbrLines ; NC = D->Case.ListMatrix.NbrColumns ; hi = D->Case.ListMatrix.x ; bi = D->Case.ListMatrix.y ; M = D->Case.ListMatrix.data ; for (i=0 ; i<3 ; ++i) { // Get (h0,b0) = state of the model, and b h0 = (A+0)->Val[i] ; b0 = (A+1)->Val[i] ; b[i] = (A+2)->Val[i] ; s = (b[i] - b0 < 0) ? -1 : +1; bool IsInGrid = Fi_InterpolationBilinear (hi, bi, M, NL, NC, s*h0, s*b0, &(dHdB[i])); if (!IsInGrid) dHdB[i] = MU0 ; } V->Type = TENSOR_SYM ; V->Val[0] = dHdB[0] ; V->Val[1] = 0.0 ; V->Val[2] = 0 ; V->Val[3] = dHdB[1] ; V->Val[4] = 0 ; V->Val[5] = dHdB[2] ; } // Functions for Vectorial Incremental Nonconservative Consistent Hysteresis // Model double norm(double a[3]) { return sqrt(a[0]*a[0] + a[1]*a[1] + a[2]*a[2]); } double chi_mag_Vinch(double b_rev, double Js0, double alpha) { double h = 0.; double chi_mag ; if(!b_rev) chi_mag = Js0/alpha/MU0 ; // value at the limit else { // Newton iteration to find h double TOL=1e-7; double r, drdh, dh; int MAX_ITER=50, iter=0; do { iter++; r = MU0 * h + Js0 * tanh(h/alpha) - b_rev ; drdh = MU0 + Js0/alpha/SQU(cosh(h/alpha)) ; dh = -r/drdh ; h += dh ; } while( (fabs(dh) > TOL) && (iter < MAX_ITER) ); //Message::Info("%d %.2f %.2f NR iterations in chi_mag_Vinch", iter, b_rev, h); if(iter>=MAX_ITER) Message::Error("Newton did not converge: h = %lf \n", h); chi_mag = Js0/MU0* ((fabs(h)<1e-4) ? 1/alpha : tanh(h/alpha)/h ) ; } return chi_mag ; } void F_nu_Vinch(F_ARG) { // input : // (A+0)->Val[0] = norm of the reversible inductance // -- norm(b_rev) = norm(b_tot-sum(\Js_k)) // (A+1)->Val[0] = saturation magnetisation of the reversible case // -- Js_0 // (A+2)->Val[0] = characteristic magnetic field inversely proportional to the // slope of the curve at origin -- alpha // output : nu double vb_rev[3] = {(A+0)->Val[0], (A+0)->Val[1], (A+0)->Val[2]}; double b_rev = norm(vb_rev); //double b_rev = (A+0)->Val[1]; // I am taking just the Y-component, so I keep track of the sign.. double Js0 = (A+1)->Val[0]; double alpha = (A+2)->Val[0]; double chi_mag = chi_mag_Vinch(b_rev, Js0, alpha); //printf("chi_mag %.3f h %.3f nu_vinch %.3f \n", chi_mag, h, 1/MU0/(1+chi_mag) ); //V->Type = SCALAR; //V->Val[0] = 1/MU0/(1+chi_mag); // reluctivity V->Type = TENSOR_SYM ; // For extension to vectorial case ... Now it does not make any difference, of course. V->Val[0] = 1/MU0/(1+chi_mag) ; V->Val[1] = 0.0 ; V->Val[2] = 0.0 ; V->Val[3] = 1/MU0/(1+chi_mag) ; V->Val[4] = 0.0 ; V->Val[5] = 1/MU0/(1+chi_mag) ; } void F_mu_Vinch(F_ARG) { // input : // (A+0)->Val[0] = norm of the reversible inductance // -- norm(b_rev) = norm(b_tot-sum(\Js_k)) // (A+1)->Val[0] = saturation magnetisation of the reversible case // -- Js_0 // (A+2)->Val[0] = characteristic magnetic field inversely proportional to the // slope of the curve at origin -- alpha // output : nu double vb_rev[3] = {(A+0)->Val[0], (A+0)->Val[1], (A+0)->Val[2]}; double b_rev = norm(vb_rev); //double b_rev = (A+0)->Val[1]; // I am taking just the Y-component, so I keep track of the sign.. double Js0 = (A+1)->Val[0]; double alpha = (A+2)->Val[0]; double chi_mag = chi_mag_Vinch(b_rev, Js0, alpha); //printf("chi_mag %.3f h %.3f nu_vinch %.3f \n", chi_mag, h, 1/MU0/(1+chi_mag) ); //V->Type = SCALAR; //V->Val[0] = 1/MU0/(1+chi_mag); // reluctivity V->Type = TENSOR_SYM ; // For extension to vectorial case ... Now it does not make any difference, of course. V->Val[0] = MU0*(1+chi_mag) ; V->Val[1] = 0.0 ; V->Val[2] = 0 ; V->Val[3] = MU0*(1+chi_mag) ; V->Val[4] = 0 ; V->Val[5] = MU0*(1+chi_mag) ; } double F_Man_Vinch (double h, double Js0, double alpha) { // Anhysteretic magnetisation double chi_mag = Js0/MU0* ((fabs(h)<1e-4) ? 1/alpha : tanh(h/alpha)/h ) ; return chi_mag ; } double F_dMandH_Vinch (double h, double Js0, double alpha) { double dmdh = Js0/MU0 * ( (fabs(h)<1e-4) ? 0. : 1/alpha/SQU(cosh(h/alpha))/h - tanh(h/alpha)/h/h) ; return dmdh ; } void FV_Man_Vinch (double H[3], double Js0, double alpha, double Man[3]) { double nH = sqrt(H[0]*H[0]+H[1]*H[1]+H[2]*H[2]) ; if ( !nH ) { Man[0] = Man[1] = Man[2]= 0. ; } else { double auxMan = F_Man_Vinch(nH, Js0, alpha) ; Man[0] = auxMan * H[0]/nH ; Man[1] = auxMan * H[1]/nH ; Man[2] = auxMan * H[2]/nH ; } } void FV_dMandH_Vinch(double H[3], double Js0, double alpha, double dMandH[6]) { double nH2 = H[0]*H[0]+H[1]*H[1]+H[2]*H[2] ; double nH = sqrt(nH2) ; double Man = F_Man_Vinch(nH, Js0, alpha) ; double ndMandH = F_dMandH_Vinch(nH,Js0,alpha) ; if ( !nH ) { dMandH[0] = dMandH[3] = dMandH[5] = ndMandH ; dMandH[1] = dMandH[2] = dMandH[4] = 0 ; } else { dMandH[0] = Man/nH + (ndMandH - Man/nH)*H[0]*H[0]/nH2 ; dMandH[3] = Man/nH + (ndMandH - Man/nH)*H[1]*H[1]/nH2 ; dMandH[5] = Man/nH + (ndMandH - Man/nH)*H[2]*H[2]/nH2 ; dMandH[1] = (ndMandH - Man/nH)*H[0]*H[1]/nH2 ; dMandH[2] = (ndMandH - Man/nH)*H[0]*H[2]/nH2 ; dMandH[4] = (ndMandH - Man/nH)*H[1]*H[2]/nH2 ; } } void F_dbdh_Vinch(F_ARG) { // input : // (A+0)->Val = magnetic field // (A+1)->Val[0] = saturation magnetisation of the reversible case // -- Js_0 // (A+2)->Val[0] = characteristic magnetic field inversely proportional to the // slope of the curve at origin -- alpha // output : dnudb2 double H[3] = {(A+0)->Val[0], (A+0)->Val[1], (A+0)->Val[2]}; double Js0 = (A+1)->Val[0]; double alpha = (A+2)->Val[0]; double dMdH[6] ; // differential susceptibility db/dh = MU0 (1 + dm/dh) // m = chi = Js0*tanh(h/alpha)/(MU0*h); FV_dMandH_Vinch(H, Js0, alpha, dMdH) ; V->Type = TENSOR_SYM ; // Vectorial extension or not does not make any difference for the time being... V->Val[0] = MU0 * (1 + dMdH[0]) ; V->Val[1] = MU0 *dMdH[1] ; V->Val[2] = MU0 *dMdH[2] ; V->Val[3] = MU0 * (1 + dMdH[3]) ; V->Val[4] = MU0 *dMdH[3] ; V->Val[5] = MU0 * (1 + dMdH[5]) ; } void F_h_Vinch(F_ARG) { // input : // (A+0)->Val = Curl a // (A+1)->Val = \sum J_k // (A+2)->Val[0] = saturation magnetisation of the reversible case // -- Js_0 // (A+3)->Val[0] = characteristic magnetic field inversely proportional to the // slope of the curve at origin -- alpha double B[3] = {(A+0)->Val[0], (A+0)->Val[1], (A+0)->Val[2]}; double Jk[3] = {(A+1)->Val[0], (A+1)->Val[1], (A+1)->Val[2]}; double Js0 = (A+2)->Val[0]; double alpha = (A+3)->Val[0]; double Brev[3] = {B[0]-Jk[0], B[1]-Jk[1], B[2]-Jk[2]}; double nBrev = norm(Brev); double chi_mag = chi_mag_Vinch(nBrev, Js0, alpha); V->Type = VECTOR ; for (int k=0 ; k<3 ; k++) V->Val[k] = 1/MU0/(1+chi_mag) * (B[k]-Jk[k]) ; } void F_dhdb_Vinch(F_ARG) { // input : // (A+0)->Val = magnetic field // (A+1)->Val[0] = saturation magnetisation of the reversible case // -- Js_0 // (A+2)->Val[0] = characteristic magnetic field inversely proportional to the // slope of the curve at origin -- alpha // output : dnudb2 double H[3] = {(A+0)->Val[0], (A+0)->Val[1], (A+0)->Val[2]}; double Js0 = (A+1)->Val[0]; double alpha = (A+2)->Val[0]; double dMdH[6], dBdH[6], dHdB[6] ; // differential susceptibility db/dh = MU0 (1 + dm/dh) // m = chi = Js0*tanh(h/alpha)/(MU0*h); FV_dMandH_Vinch(H, Js0, alpha, dMdH) ; dBdH[0] = MU0 * (1 + dMdH[0]) ; dBdH[3] = MU0 * (1 + dMdH[3]) ; dBdH[5] = MU0 * (1 + dMdH[5]) ; dBdH[1] = MU0 * dMdH[1] ; dBdH[2] = MU0 * dMdH[2] ; dBdH[4] = MU0 * dMdH[4] ; double det = dBdH[0] * (dBdH[3] *dBdH[5] - dBdH[4] *dBdH[4]) - dBdH[1] * (dBdH[1] *dBdH[5] - dBdH[4] *dBdH[2]) + dBdH[2] * (dBdH[1] *dBdH[4] - dBdH[3] *dBdH[2]); if (!det) Message::Error("Null determinant of db/dh!"); dHdB[0] = (dBdH[3]*dBdH[5]-dBdH[4]*dBdH[4])/det ; dHdB[1] = -(dBdH[1]*dBdH[5]-dBdH[2]*dBdH[4])/det ; dHdB[2] = (dBdH[1]*dBdH[4]-dBdH[2]*dBdH[3])/det ; dHdB[3] = (dBdH[0]*dBdH[5]-dBdH[2]*dBdH[2])/det ; dHdB[4] = -(dBdH[0]*dBdH[4]-dBdH[1]*dBdH[2])/det ; dHdB[5] = (dBdH[0]*dBdH[3]-dBdH[1]*dBdH[1])/det ; V->Type = TENSOR_SYM ; // Watch out!: extension to vectorial case not yet done... Now it does not make any difference, of course. for (int i=0 ; i<6 ; i++) V->Val[i] = dHdB[i] ; } bool limiter(const double max, double v[3]) { double mod = norm(v); if(mod >= max){ for (int n=0; n<3; n++) v[n] *= max/mod; return true; } return false; } // pour info // #define F_ARG struct Function * Fct, struct Value * A, struct Value * V // http://www.gnu.org/software/gsl/manual/html_node/Multimin-Examples.html #if !defined(HAVE_GSL) void F_Update_Jk(F_ARG) { Message::Error("F_Update_Jk requires the GSL"); } #else #include #include #include struct omega_f_context { double h[3], Jp[3]; double chi, Js, alpha; } ; double omega_f(const gsl_vector *v, void *params) { double J[3], dJ[3] ; struct omega_f_context * p = (struct omega_f_context *)params; double h[3] = { p->h[0] , p->h[1] , p->h[2] }; double Jp[3] = { p->Jp[0], p->Jp[1], p->Jp[2] }; double chi = p->chi; double Js = p->Js; double alpha = p->alpha; for (int i=0; i<3; i++) J[i] = gsl_vector_get(v, i); limiter(0.9999*Js, J) ; double nJ = norm(J); for (int i=0; i<3; i++) dJ[i] = J[i]-Jp[i]; // J-Jp double val = Js*alpha*( nJ/Js*atanh(nJ/Js) + 0.5*log(1-SQU(nJ/Js)) ) // u(J) - (J[0]*h[0] + J[1]*h[1] + J[2]*h[2]) // -J.h + chi * norm(dJ); // chi | J-Jp | return(val); } void omega_df (const gsl_vector *v, void *params, gsl_vector *df) { double J[3], dJ[3] ; struct omega_f_context * p = (struct omega_f_context *)params; double h[3] = {p->h[0] , p->h[1] , p->h[2] }; double Jp[3] = {p->Jp[0], p->Jp[1], p->Jp[2]}; double chi = p->chi; double Js = p->Js; double alpha = p->alpha; double grad[3] = {0.,0.,0.}; for (int i=0; i<3; i++) J[i] = gsl_vector_get(v, i); limiter(0.9999*Js, J); double nJ = norm(J); for (int i=0; i<3; i++) dJ[i] = J[i]-Jp[i]; // J-Jp double ndJ = norm(dJ); for (int i=0; i<3; i++) { if (nJ) grad[i] += alpha*atanh(nJ/Js)*J[i]/nJ; grad[i] -= h[i]; if (ndJ) grad[i] += chi*dJ[i]/ndJ; gsl_vector_set(df, i, grad[i]); } } void omega_fdf (const gsl_vector *x, void *params, double *f, gsl_vector *df) { *f = omega_f(x, params); omega_df(x, params, df); } void F_Update_Jk(F_ARG) { const int MAX_ITER = 100; int iter = 0, status; double step_size = 0.01; double TOL = 1e-4; double omegap; struct omega_f_context context ; context.h[0] = (A+0)->Val[0]; context.h[1] = (A+0)->Val[1]; context.h[2] = (A+0)->Val[2]; double J[3] = { (A+1)->Val[0], (A+1)->Val[1], (A+1)->Val[2] }; context.Jp[0] = (A+2)->Val[0]; context.Jp[1] = (A+2)->Val[1]; context.Jp[2] = (A+2)->Val[2]; context.chi = (A+3)->Val[0]; context.Js = (A+4)->Val[0]; context.alpha = (A+5)->Val[0]; //http://www.gnu.org/software/gsl/manual/html_node/Multimin-Algorithms-with-Derivatives.html const gsl_multimin_fdfminimizer_type *TYPE = gsl_multimin_fdfminimizer_conjugate_fr; //const gsl_multimin_fdfminimizer_type *TYPE = gsl_multimin_fdfminimizer_conjugate_pr; //const gsl_multimin_fdfminimizer_type *TYPE = gsl_multimin_fdfminimizer_vector_bfgs2; //const gsl_multimin_fdfminimizer_type *TYPE = gsl_multimin_fdfminimizer_vector_bfgs; //const gsl_multimin_fdfminimizer_type *TYPE = gsl_multimin_fdfminimizer_steepest_descent; gsl_multimin_function_fdf my_func; my_func.n = 3; my_func.f = omega_f ; my_func.df = omega_df ; my_func.fdf = omega_fdf; my_func.params = &context; gsl_vector* x = gsl_vector_alloc (3); for (int i=0; i<3; i++) gsl_vector_set(x, i, J[i]) ; // initial value for the minimizer gsl_multimin_fdfminimizer *solver = gsl_multimin_fdfminimizer_alloc(TYPE, 3); gsl_multimin_fdfminimizer_set (solver, &my_func, x, step_size, TOL); do { iter++; omegap = solver->f; status = gsl_multimin_fdfminimizer_iterate (solver); if (status) break; // check if solver is stuck } while( fabs(solver->f-omegap)>1e-2 && iter < MAX_ITER); V->Type = VECTOR ; for (int i=0 ; i<3 ; i++) V->Val[i] = gsl_vector_get (solver->x, i) ; /* for (int i=0 ; i<3 ; i++) J[i] = gsl_vector_get (solver->x, i) ; limiter(0.9999*context.Js, J) ; for (int i=0 ; i<3 ; i++) V->Val[i] = J[i]; */ gsl_multimin_fdfminimizer_free (solver); gsl_vector_free (x); } #endif //=================================================== // V. Francois original implementation with steepest descent //=================================================== double fct_omega(double h[3], double Jk[3], double Jkp[3], double chi, double Js, double alpha) { double diff[3]; double nJk = norm(Jk); // magnetisation Jk assumed to be < the saturation magnetisation Js for (int n=0; n<3; n++) diff[n] = Jk[n]-Jkp[n]; // J-Jp double g2 = alpha*Js *( nJk/Js*atanh(nJk/Js) + 0.5*log(fabs(SQU(nJk/Js)-1)) ); // magnetic energy u(J) double g3 = Jk[0] * h[0] + Jk[1] * h[1] + Jk[2] * h[2]; // -J.h double Dissip = chi * norm(diff) ; // chi | J-Jp | return(g2-g3+Dissip); } void fct_d_omega (double h[3], double Jk[3], double Jkp[3], double chi, double Js, double alpha, double *d_omega) { d_omega[0] = d_omega[1] = d_omega[2] = 0.; double dJk[3]; for (int n=0; n<3; n++) dJk[n] = Jk[n]-Jkp[n]; double nJk = norm(Jk); double ndJk = norm(dJk); for (int n = 0; n < 3; n++) { if(nJk) d_omega[n] += alpha * atanh(nJk/Js) * Jk[n]/nJk; d_omega[n] -= h[n]; if(ndJk) d_omega[n] += chi * dJk[n]/ndJk ; } } void F_Update_Jk_sd(F_ARG) { // Updating Jk with a steepest descent algorithm // --------------------------------------------- // input: // (A+0)->Val = magnetic field -- h // (A+1)->Val = material magnetization -- Jk // (A+2)->Val = material magnetization at previous time step -- Jkp // (A+3)->Val = limit force related to the dissipation -- chi // (A+4)->Val = saturation magnetization -- Js // (A+5)->Val = characteristic magnetic field inversely proportional to the slope at origin -- alpha // --------------------------------------------- // output: updated Jk double h[3], Jk[3], Jkp[3] ; double min_Jk[3] = {0,0,0}; double sdfactor = 0.1; //suitable value of tol for most applications double TOL = 1e-6; double d_omega[3]= {0,0,0} ; for (int n=0; n<3; n++) { h[n] = (A+0)->Val[n]; Jk[n] = (A+1)->Val[n]; Jkp[n] = (A+2)->Val[n]; } double chi =(A+3)->Val[0]; double Js =(A+4)->Val[0]; double alpha=(A+5)->Val[0]; limiter(0.9999*Js, Jk ) ; // why do I need this ? limiter(0.9999*Js, Jkp); // ???????? fct_d_omega(h, Jk, Jkp, chi, Js, alpha, d_omega) ; // updating the derivative of omega double omega = fct_omega(h, Jk, Jkp, chi, Js, alpha) ; // updating omega double min_omega = 1e+22 ; int iter = 0 ; const int MAX_ITER = 100; while( (fabs(d_omega[0])/(1+fabs(omega))*sdfactor >TOL || fabs(d_omega[1])/(1+fabs(omega))*sdfactor >TOL || fabs(d_omega[2])/(1+fabs(omega))*sdfactor >TOL )) { for (int n = 0; n < 3; n++) min_Jk[n] = Jk[n] - sdfactor * d_omega[n] ; // gradient descent algorithm limiter(0.9999*Js, min_Jk); min_omega = fct_omega(h, min_Jk, Jkp, chi, Js, alpha); //updating omega if (iter>MAX_ITER) Message::Warning("Too many iterations to find the minimum of omega: min_omega %g, omega-TOL/10 %g", min_omega, omega-TOL/10); if( min_omega < omega-TOL/10 && norm(min_Jk) < Js ){ fct_d_omega(h, min_Jk, Jkp, chi, Js, alpha, d_omega); //update the derivative d_omega omega = min_omega; if(Jk[0]==Jkp[0] && Jk[1]==Jkp[1] && Jk[2]==Jkp[2]) sdfactor=0.1; // re-initialize rfactor which may have become very small due to an angulous starting point for (int n=0; n<3; n++) Jk[n] = min_Jk[n]; } else sdfactor = sdfactor/2 ; iter++ ; } Message::Debug("iter %d omega %.6e d_omega %.6e %.6e %.6e", iter, omega, d_omega[0], d_omega[1], d_omega[2]); V->Type = VECTOR ; for (int n=0 ; n<3 ; n++) V->Val[n] = min_Jk[n]; } getdp-2.4.2-source/Legacy/F_Math.cpp000644 001750 001750 00000013660 12116424202 020646 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "ProData.h" #include "F.h" #include "MallocUtils.h" #include "Message.h" extern struct CurrentData Current ; /* ------------------------------------------------------------------------ */ /* C math functions (scalar, 1 argument, imaginary part set to zero) */ /* ------------------------------------------------------------------------ */ #define scalar_real_1_arg(func, string) \ int k; \ \ if(A->Type != SCALAR) \ Message::Error("Non scalar argument for function '" string "'"); \ \ V->Val[0] = func(A->Val[0]) ; \ if (Current.NbrHar != 1){ \ V->Val[MAX_DIM] = 0. ; \ for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) \ V->Val[MAX_DIM*k] = V->Val[MAX_DIM*(k+1)] = 0. ; \ } \ V->Type = SCALAR; void F_Exp (F_ARG) { scalar_real_1_arg (exp, "Exp") } void F_Log (F_ARG) { scalar_real_1_arg (log, "Log") } void F_Log10 (F_ARG) { scalar_real_1_arg (log10,"Log10") } void F_Sqrt (F_ARG) { scalar_real_1_arg (sqrt, "Sqrt") } void F_Sin (F_ARG) { scalar_real_1_arg (sin, "Sin") } void F_Asin (F_ARG) { scalar_real_1_arg (asin, "Asin") } void F_Cos (F_ARG) { scalar_real_1_arg (cos, "Cos" ) } void F_Acos (F_ARG) { scalar_real_1_arg (acos, "Acos") } void F_Tan (F_ARG) { scalar_real_1_arg (tan, "Tan") } void F_Atan (F_ARG) { scalar_real_1_arg (atan, "Atan") } void F_Sinh (F_ARG) { scalar_real_1_arg (sinh, "Sinh") } void F_Cosh (F_ARG) { scalar_real_1_arg (cosh, "Cosh") } void F_Tanh (F_ARG) { scalar_real_1_arg (tanh, "Tanh") } void F_Fabs (F_ARG) { scalar_real_1_arg (fabs, "Fabs") } void F_Floor (F_ARG) { scalar_real_1_arg (floor,"Floor") } void F_Ceil (F_ARG) { scalar_real_1_arg (ceil, "Ceil") } #undef scalar_real_1_arg /* ------------------------------------------------------------------------ */ /* C math functions (scalar, 2 arguments, imaginary part set to zero) */ /* ------------------------------------------------------------------------ */ #define scalar_real_2_arg(func, string) \ int k; \ \ if(A->Type != SCALAR || (A+1)->Type != SCALAR) \ Message::Error("Non scalar argument(s) for function '" string "'"); \ \ V->Val[0] = func(A->Val[0], (A+1)->Val[0]) ; \ if (Current.NbrHar != 1){ \ V->Val[MAX_DIM] = 0. ; \ for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) \ V->Val[MAX_DIM*k] = V->Val[MAX_DIM*(k+1)] = 0. ; \ } \ V->Type = SCALAR; void F_Atan2 (F_ARG) { scalar_real_2_arg (atan2, "Atan2") } void F_Fmod (F_ARG) { scalar_real_2_arg (fmod, "Fmod") } #undef scalar_real_2_arg /* ------------------------------------------------------------------------ */ /* Sign function */ /* ------------------------------------------------------------------------ */ void F_Sign(F_ARG) { int k; double x; if(A->Type != SCALAR) Message::Error("Non scalar argument for function 'Sign'"); x = A->Val[0]; if(x >= 0.) V->Val[0] = 1.; else if(x < 0.) V->Val[0] = -1.; else V->Val[0] = 0.; if (Current.NbrHar != 1){ V->Val[MAX_DIM] = 0. ; for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) V->Val[MAX_DIM*k] = V->Val[MAX_DIM*(k+1)] = 0. ; } V->Type = SCALAR; } /* ------------------------------------------------------------------------ */ /* Bessel functions jn, yn and their derivatives */ /* ------------------------------------------------------------------------ */ void F_Jn(F_ARG) { int k, n; double x; if(A->Type != SCALAR || (A+1)->Type != SCALAR) Message::Error("Non scalar argument(s) for function 'Jn'"); n = (int)A->Val[0]; x = (A+1)->Val[0]; V->Val[0] = jn(n, x); if (Current.NbrHar != 1){ V->Val[MAX_DIM] = 0. ; for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) V->Val[MAX_DIM*k] = V->Val[MAX_DIM*(k+1)] = 0. ; } V->Type = SCALAR; } void F_Yn(F_ARG) { int k, n; double x; if(A->Type != SCALAR || (A+1)->Type != SCALAR) Message::Error("Non scalar argument(s) for function 'Yn'"); n = (int)A->Val[0]; x = (A+1)->Val[0]; V->Val[0] = yn(n, x); if (Current.NbrHar != 1){ V->Val[MAX_DIM] = 0. ; for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) V->Val[MAX_DIM*k] = V->Val[MAX_DIM*(k+1)] = 0. ; } V->Type = SCALAR; } double dBessel(double *tab, int n, double x) { if(n == 0){ return - tab[1]; } else{ return tab[n-1] - (double)n/x * tab[n]; } } void F_dJn(F_ARG) { int k, n; double x, *jntab; if(A->Type != SCALAR || (A+1)->Type != SCALAR) Message::Error("Non scalar argument(s) for function 'dJn'"); n = (int)A->Val[0]; x = (A+1)->Val[0]; jntab = (double*)Malloc((n + 2) * sizeof(double)); for(k = 0; k < n + 2; k++){ jntab[k] = jn(k, x); } V->Val[0] = dBessel(jntab, n, x); Free(jntab); if (Current.NbrHar != 1){ V->Val[MAX_DIM] = 0. ; for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) V->Val[MAX_DIM*k] = V->Val[MAX_DIM*(k+1)] = 0. ; } V->Type = SCALAR; } void F_dYn(F_ARG) { int k, n; double x, *yntab; if(A->Type != SCALAR || (A+1)->Type != SCALAR) Message::Error("Non scalar argument(s) for function 'dYn'"); n = (int)A->Val[0]; x = (A+1)->Val[0]; yntab = (double*)Malloc((n + 2) * sizeof(double)); for(k = 0; k < n + 2; k++){ yntab[k] = yn(k, x); } V->Val[0] = dBessel(yntab, n, x); Free(yntab); if (Current.NbrHar != 1){ V->Val[MAX_DIM] = 0. ; for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) V->Val[MAX_DIM*k] = V->Val[MAX_DIM*(k+1)] = 0. ; } V->Type = SCALAR; } getdp-2.4.2-source/Legacy/Gauss_Triangle.cpp000644 001750 001750 00000006531 12116424202 022416 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "Gauss.h" #include "Gauss_Triangle.h" #include "Message.h" #include "MallocUtils.h" /* Gauss Integration over a triangle */ void Gauss_Triangle(int Nbr_Points, int Num, double *u, double *v, double *w, double *wght) { switch (Nbr_Points) { case 1 : *u= xt1 [Num] ; *v= yt1 [Num] ; *w= 0. ; *wght= pt1 [Num] ; break ; case 3 : *u= xt3 [Num] ; *v= yt3 [Num] ; *w= 0. ; *wght= pt3 [Num] ; break ; case 4 : *u= xt4 [Num] ; *v= yt4 [Num] ; *w= 0. ; *wght= pt4 [Num] ; break ; case 6 : *u= xt6 [Num] ; *v= yt6 [Num] ; *w= 0. ; *wght= pt6 [Num] ; break ; case 7 : *u= xt7 [Num] ; *v= yt7 [Num] ; *w= 0. ; *wght= pt7 [Num] ; break ; case 12 : *u= xt12[Num] ; *v= yt12[Num] ; *w= 0. ; *wght= pt12[Num] ; break ; case 13 : *u= xt13[Num] ; *v= yt13[Num] ; *w= 0. ; *wght= pt13[Num] ; break ; case 16 : *u= xt16[Num] ; *v= yt16[Num] ; *w= 0. ; *wght= pt16[Num] ; break ; default : Message::Error("Wrong number of Gauss points for Triangle: " "valid choices: 1, 3, 4, 6, 7, 12, 13, 16"); break; } } /* Degenerate n1Xn2 Gauss-Legendre scheme to integrate over a tri */ static int glt[MAX_LINE_POINTS] = {-1}; static double *glxt[MAX_LINE_POINTS], *glyt[MAX_LINE_POINTS], *glpt[MAX_LINE_POINTS]; static void quadToTri(double xi,double eta,double *r, double *s, double *J) { double r1; *r = 0.5e0 * (1.0e0 + xi); r1 = 1.0e0 - (*r); *s = 0.5e0 * (1.0e0 + eta) * r1; *J = 0.25e0 * r1; } void GaussLegendre_Triangle(int Nbr_Points, int Num, double *u, double *v, double *w, double *wght) { int i,j,index=0,nb; double pt1,pt2,wt1,wt2,dJ,dum; nb = (int)sqrt((double)Nbr_Points); if(nb*nb != Nbr_Points || nb > MAX_LINE_POINTS){ Message::Error("Number of points should be n^2 with n in [1,%d]", MAX_LINE_POINTS) ; return; } if(glt[0] < 0) for(i=0 ; i < MAX_LINE_POINTS ; i++) glt[i] = 0 ; if(!glt[nb - 1]){ Message::Info("Computing degenerate GaussLegendre %dX%d for Triangle", nb, nb); glxt[nb - 1] = (double*)Malloc(Nbr_Points * sizeof(double)); glyt[nb - 1] = (double*)Malloc(Nbr_Points * sizeof(double)); glpt[nb - 1] = (double*)Malloc(Nbr_Points * sizeof(double)); for(i = 0; i < nb; i++) { Gauss_Line(nb, i, &pt1, &dum, &dum, &wt1); for(j = 0; j < nb; j++) { Gauss_Line(nb, j, &pt2, &dum, &dum, &wt2); quadToTri(pt1, pt2, &glxt[nb - 1][index], &glyt[nb - 1][index], &dJ); glpt[nb - 1][index++] = dJ * wt1 * wt2; } } glt[nb - 1] = 1; } *u = glxt[nb - 1][Num] ; *v = glyt[nb - 1][Num] ; *w = 0. ; *wght = glpt[nb - 1][Num] ; } /* Gauss Integration over a triangle with a 1/R singularity over node (0,0,0) */ void GaussSingularR_Triangle(int Nbr_Points, int Num, double *u, double *v, double *w, double *wght) { switch (Nbr_Points) { case 1 : *u= xts1 [Num] ; *v= yts1 [Num] ; *w= 0. ; *wght= pts1 [Num] ; break ; case 3 : *u= xts3 [Num] ; *v= yts3 [Num] ; *w= 0. ; *wght= pts3 [Num] ; break ; case 4 : *u= xts4 [Num] ; *v= yts4 [Num] ; *w= 0. ; *wght= pts4 [Num] ; break ; default : Message::Error("Wrong number of (modified) Gauss points for Triangle: " "valid choices: 1, 3, 4"); break; } } getdp-2.4.2-source/Legacy/Get_FunctionValue.cpp000644 001750 001750 00000023536 12116424202 023074 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include "ProData.h" #include "GeoData.h" #include "DofData.h" #include "Cal_Quantity.h" #include "Get_Geometry.h" #include "Message.h" #define SQU(a) ((a)*(a)) extern struct Problem Problem_S ; extern struct CurrentData Current ; /* ------------------------------------------------------------------------ */ /* G e t _ V a l u e F r o m F o r m */ /* ------------------------------------------------------------------------ */ int Get_ValueFromForm(int Form) { switch (Form) { case FORM0 : case FORM3 : case FORM3P : case SCALAR : return(SCALAR) ; case FORM1 : case FORM1P : case FORM1S : case FORM2 : case FORM2P : case FORM2S : case VECTOR : case VECTORP : return(VECTOR) ; default : Message::Error("Unknown Form type in 'Get_ValueFromForm'"); return(-1) ; } } /* ------------------------------------------------------------------------ */ /* G e t _ I n t e g r a t i o n C a s e */ /* ------------------------------------------------------------------------ */ /* Il faudrait reorganiser les 'Current.XXX' Ca devient un peu le bordel. */ struct IntegrationCase * Get_IntegrationCase (struct Element * Element, List_T *IntegrationCase_L, int CriterionIndex) { struct Value Criterion ; if (CriterionIndex >= 0){ Current.Element = Element ; Current.ElementSource = Element->ElementSource ; Get_ValueOfExpression ((struct Expression *) List_Pointer(Problem_S.Expression, CriterionIndex), NULL, 0., 0., 0., &Criterion) ; if(Criterion.Val[0] < 0 || Criterion.Val[0] >= List_Nbr(IntegrationCase_L)) Message::Error("Integration criterion out of range"); } else { if(List_Nbr(IntegrationCase_L) > 1) Message::Error("Missing integration criterion"); Criterion.Val[0] = 0; } return((struct IntegrationCase*) List_Pointer(IntegrationCase_L, (int)Criterion.Val[0])) ; } /* ------------------------------------------------------------------------ */ /* G e t _ F u n c t i o n V a l u e */ /* ------------------------------------------------------------------------ */ void Get_FunctionValue(int Nbr_Function, void (*xFunctionBF[])(), int Type_Operator, struct QuantityStorage * QuantityStorage_P, int * Type_Form) { int i ; switch (Type_Operator) { case NOOP : *Type_Form = QuantityStorage_P->TypeQuantity ; for (i = 0 ; i < Nbr_Function ; i++) xFunctionBF[i] = QuantityStorage_P->BasisFunction[i].BasisFunction->Function ; break ; case EXTDER : *Type_Form = QuantityStorage_P->TypeQuantity + 1 ; for (i = 0 ; i < Nbr_Function ; i++) xFunctionBF[i] = QuantityStorage_P->BasisFunction[i].BasisFunction->dFunction ; break ; case EXTDERINV : *Type_Form = QuantityStorage_P->TypeQuantity - 1 ; for (i = 0 ; i < Nbr_Function ; i++) xFunctionBF[i] = QuantityStorage_P->BasisFunction[i].BasisFunction->dInvFunction ; break ; case GRAD : if (QuantityStorage_P->TypeQuantity == FORM0) { *Type_Form = QuantityStorage_P->TypeQuantity + 1 ; for (i = 0 ; i < Nbr_Function ; i++) xFunctionBF[i] = QuantityStorage_P->BasisFunction[i].BasisFunction->dFunction ; } else if (QuantityStorage_P->TypeQuantity == SCALAR) { *Type_Form = VECTOR ; } break ; case CURL : if ((QuantityStorage_P->TypeQuantity == FORM1) || (QuantityStorage_P->TypeQuantity == FORM1P)) { *Type_Form = QuantityStorage_P->TypeQuantity + 1 ; for (i = 0 ; i < Nbr_Function ; i++) xFunctionBF[i] = QuantityStorage_P->BasisFunction[i].BasisFunction->dFunction ; } else if (QuantityStorage_P->TypeQuantity == VECTOR) { *Type_Form = VECTOR ; for (i = 0 ; i < Nbr_Function ; i++) xFunctionBF[i] = QuantityStorage_P->BasisFunction[i].BasisFunction->dFunction ; } break ; case DIV : if (QuantityStorage_P->TypeQuantity == FORM2) { *Type_Form = QuantityStorage_P->TypeQuantity + 1 ; for (i = 0 ; i < Nbr_Function ; i++) xFunctionBF[i] = QuantityStorage_P->BasisFunction[i].BasisFunction->dFunction ; } else if (QuantityStorage_P->TypeQuantity == VECTOR) { *Type_Form = SCALAR ; for (i = 0 ; i < Nbr_Function ; i++) xFunctionBF[i] = QuantityStorage_P->BasisFunction[i].BasisFunction->dInvFunction ; } break ; case GRADINV : if (QuantityStorage_P->TypeQuantity == FORM1) { *Type_Form = QuantityStorage_P->TypeQuantity - 1 ; for (i = 0 ; i < Nbr_Function ; i++) xFunctionBF[i] = QuantityStorage_P->BasisFunction[i].BasisFunction->dInvFunction ; } else if (QuantityStorage_P->TypeQuantity == VECTOR) { *Type_Form = SCALAR ; } break ; case CURLINV : if (QuantityStorage_P->TypeQuantity == FORM2) { *Type_Form = QuantityStorage_P->TypeQuantity - 1 ; for (i = 0 ; i < Nbr_Function ; i++) xFunctionBF[i] = QuantityStorage_P->BasisFunction[i].BasisFunction->dInvFunction ; } else if (QuantityStorage_P->TypeQuantity == VECTOR) { *Type_Form = VECTOR ; } break ; case DIVINV : if ((QuantityStorage_P->TypeQuantity == FORM3) || (QuantityStorage_P->TypeQuantity == FORM3P)) { *Type_Form = QuantityStorage_P->TypeQuantity - 1 ; for (i = 0 ; i < Nbr_Function ; i++) xFunctionBF[i] = QuantityStorage_P->BasisFunction[i].BasisFunction->dInvFunction ; } else if (QuantityStorage_P->TypeQuantity == SCALAR) { *Type_Form = VECTOR ; } break ; case _D1 : if (QuantityStorage_P->TypeQuantity == VECTOR) { *Type_Form = VECTOR ; for (i = 0 ; i < Nbr_Function ; i++) xFunctionBF[i] = QuantityStorage_P->BasisFunction[i].BasisFunction->dFunction ; } break ; case _D2 : if (QuantityStorage_P->TypeQuantity == VECTOR) { *Type_Form = VECTOR ; for (i = 0 ; i < Nbr_Function ; i++) xFunctionBF[i] = QuantityStorage_P->BasisFunction[i].BasisFunction->dInvFunction ; } break ; default : Message::Error("Unknown operator in 'Get_FunctionValue'"); break; } } /* ------------------------------------------------------------------------ */ /* G e t _ I n i t F u n c t i o n V a l u e */ /* ------------------------------------------------------------------------ */ void Get_InitFunctionValue(int Type_Operator, struct QuantityStorage * QuantityStorage_P, int * Type_Form) { switch (Type_Operator) { case NOOP : *Type_Form = QuantityStorage_P->TypeQuantity ; break ; case EXTDER : *Type_Form = QuantityStorage_P->TypeQuantity + 1 ; break ; case EXTDERINV : *Type_Form = QuantityStorage_P->TypeQuantity - 1 ; break ; case GRAD : if (QuantityStorage_P->TypeQuantity == FORM0) *Type_Form = QuantityStorage_P->TypeQuantity + 1 ; else if (QuantityStorage_P->TypeQuantity == SCALAR) *Type_Form = VECTOR ; break ; case CURL : if ((QuantityStorage_P->TypeQuantity == FORM1) || (QuantityStorage_P->TypeQuantity == FORM1P)) *Type_Form = QuantityStorage_P->TypeQuantity + 1 ; else if (QuantityStorage_P->TypeQuantity == VECTOR) *Type_Form = VECTOR ; break ; case DIV : if (QuantityStorage_P->TypeQuantity == FORM2) *Type_Form = QuantityStorage_P->TypeQuantity + 1 ; else if (QuantityStorage_P->TypeQuantity == VECTOR) *Type_Form = SCALAR ; break ; case GRADINV : if (QuantityStorage_P->TypeQuantity == FORM1) *Type_Form = QuantityStorage_P->TypeQuantity - 1 ; else if (QuantityStorage_P->TypeQuantity == VECTOR) *Type_Form = SCALAR ; break ; case CURLINV : if (QuantityStorage_P->TypeQuantity == FORM2) *Type_Form = QuantityStorage_P->TypeQuantity - 1 ; else if (QuantityStorage_P->TypeQuantity == VECTOR) *Type_Form = VECTOR ; break ; case DIVINV : if ((QuantityStorage_P->TypeQuantity == FORM3) || (QuantityStorage_P->TypeQuantity == FORM3P)) *Type_Form = QuantityStorage_P->TypeQuantity - 1 ; else if (QuantityStorage_P->TypeQuantity == SCALAR) *Type_Form = VECTOR ; break ; case _D1 : case _D2 : if (QuantityStorage_P->TypeQuantity == VECTOR) *Type_Form = VECTOR ; else *Type_Form = VECTOR ; break ; default : Message::Error("Unknown operator in 'Get_InitFunctionValue'"); break; } } /* ------------------------------------------------------------------------ */ /* C a l _ I n t e r p o l a t i o n O r d e r */ /* ------------------------------------------------------------------------ */ double Cal_InterpolationOrder(struct Element * Element, struct QuantityStorage * QuantityStorage) { int i ; double Order = 0.0 ; for(i = 0 ; i < QuantityStorage->NbrElementaryBasisFunction ; i++) if(QuantityStorage->BasisFunction[i].Dof->Type == DOF_UNKNOWN) Order = std::max(QuantityStorage->BasisFunction[i].BasisFunction->Order, Order) ; return(Order) ; } /* ------------------------------------------------------------------------ */ /* C a l _ M a x E d g e L e n g t h */ /* ------------------------------------------------------------------------ */ double Cal_MaxEdgeLength(struct Element * Element) { int i, *IM, *N, NbrEdges ; double l, lmax = 0.0 ; IM = Geo_GetIM_Den(Element->Type, &NbrEdges) ; for(i = 0 ; i < NbrEdges ; i++){ N = IM + i * NBR_MAX_SUBENTITIES_IN_ELEMENT ; l = sqrt(SQU(Element->x[abs(N[1])-1]-Element->x[abs(N[0])-1]) + SQU(Element->y[abs(N[1])-1]-Element->y[abs(N[0])-1]) + SQU(Element->z[abs(N[1])-1]-Element->z[abs(N[0])-1])) ; lmax = std::max(lmax, l) ; } return(lmax) ; } getdp-2.4.2-source/Legacy/Gauss_Quadrangle.h000644 001750 001750 00000003662 12116424202 022403 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . /* 3 integration points */ static double xq3[3] = {0.816496580928,-0.408248290464,-0.408248290464}; static double yq3[3] = {0.0,0.840896415255,-0.840896415255}; static double pq3[3] = {1.33333333333,1.33333333333,1.33333333333}; /* 4 integration points */ static double xq4[4] = {0.577350269189,-0.577350269189,0.577350269189,-0.577350269189}; static double yq4[4] = {0.577350269189,0.577350269189,-0.577350269189,-0.577350269189}; static double pq4[4] = {1.,1.,1.,1.}; /* 7 integration points */ static double xq7[7] = {0.0,-0.683130051064,0.683130051064,0.890654421782, -0.890654421782,0.374256642286,-0.374256642286}; static double yq7[7] = {0.0,-0.683130051064,0.683130051064,-0.374256642286,0.374256642286, -0.890654421782,0.890654421782}; static double pq7[7] = {1.142857142857,0.595238095238,0.595238095238, 0.416666666666,0.416666666666,0.416666666666,0.416666666666}; /* GAUSS QUADRANGLE WITH 1/R SINGULARITY OVER NODE (-1,-1,0) ref.: H. L. G. Pina, J. L. M. Fernandes, C. A. Brebbia, Some numerical integration formulae over triangles and squares with a 1/R singularity, Appl. Math. Modelling, Vol 5, June 1981, pp 209--211 */ /* 1 integration point */ static double xqs1[1] = {-0.26501817}; static double yqs1[1] = {-0.26501817}; static double pqs1[1] = {3.52549435}; /* 3 integration points */ static double xqs3[3] = {-0.58105530,1.0,-0.21877566}; static double yqs3[3] = {-0.58105530,-0.21877566,1.0}; static double pqs3[3] = {2.37881900,0.57333767,0.57333767}; /* 4 integration points */ static double xqs4[4] = {-0.37512304,0.69629093,-0.92928746,-0.15602536}; static double yqs4[4] = {-0.92928746,-0.15602536,-0.37512304,0.69629093}; static double pqs4[4] = {1.02276580,0.73998134,1.02276580,0.73998134}; getdp-2.4.2-source/Legacy/Pre_TermOfFemEquation.cpp000644 001750 001750 00000072201 12166744450 023663 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "ProData.h" #include "DofData.h" #include "Get_DofOfElement.h" #include "ExtendedGroup.h" #include "BF.h" #include "Message.h" extern struct Problem Problem_S ; extern struct CurrentData Current ; /* ------------------------------------------------------------------------ */ /* P r e _ I n i t T e r m O f F e m F o r m u l a t i o n */ /* ------------------------------------------------------------------------ */ void Pre_InitTermOfFemEquation(struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0) { struct DefineQuantity * DefineQuantity_P ; if (EquationTerm_P->Case.LocalTerm.Term.DefineQuantityIndexDof >= 0) { DefineQuantity_P = (QuantityStorage_P0 + EquationTerm_P->Case.LocalTerm.Term.DefineQuantityIndexDof)->DefineQuantity ; Dof_AddFunctionSpaceIndex(DefineQuantity_P->FunctionSpaceIndex) ; } if (EquationTerm_P->Case.LocalTerm.Term.DefineQuantityIndexNoDof >= 0) { DefineQuantity_P = (QuantityStorage_P0 + EquationTerm_P->Case.LocalTerm.Term.DefineQuantityIndexNoDof)->DefineQuantity ; Dof_AddFunctionSpaceIndex(DefineQuantity_P->FunctionSpaceIndex) ; } } /* ------------------------------------------------------------------------ */ /* P r e _ T e r m O f F e m F o r m u l a t i o n */ /* ------------------------------------------------------------------------ */ bool IsEquationNonLocal(BasisFunction *bf) { if(!bf) return false; if(bf->Function == (void(*)())BF_Region || bf->Function == (void(*)())BF_RegionX || bf->Function == (void(*)())BF_RegionY || bf->Function == (void(*)())BF_RegionZ || bf->Function == (void(*)())BF_Global || bf->Function == (void(*)())BF_dGlobal || bf->Function == (void(*)())BF_Zero || bf->Function == (void(*)())BF_One || bf->Function == (void(*)())BF_GroupOfNodes || bf->Function == (void(*)())BF_GroupOfNodes_2E || bf->Function == (void(*)())BF_GroupOfNodes_2F || bf->Function == (void(*)())BF_GroupOfNodes_2V || bf->Function == (void(*)())BF_GroupOfNodes_3E || bf->Function == (void(*)())BF_GroupOfNodes_3F || bf->Function == (void(*)())BF_GroupOfNodes_3V || bf->Function == (void(*)())BF_GradGroupOfNodes || bf->Function == (void(*)())BF_GradGroupOfNodes_2E || bf->Function == (void(*)())BF_GradGroupOfNodes_2F || bf->Function == (void(*)())BF_GradGroupOfNodes_2V || bf->Function == (void(*)())BF_GradGroupOfNodes_3E || bf->Function == (void(*)())BF_GradGroupOfNodes_3F || bf->Function == (void(*)())BF_GradGroupOfNodes_3V || bf->Function == (void(*)())BF_GroupOfEdges || bf->Function == (void(*)())BF_GroupOfEdges_2E || bf->Function == (void(*)())BF_GroupOfEdges_2F || bf->Function == (void(*)())BF_GroupOfEdges_2V || bf->Function == (void(*)())BF_GroupOfEdges_3E || bf->Function == (void(*)())BF_GroupOfEdges_3F_a || bf->Function == (void(*)())BF_GroupOfEdges_3F_b || bf->Function == (void(*)())BF_GroupOfEdges_3F_c || bf->Function == (void(*)())BF_GroupOfEdges_3V || bf->Function == (void(*)())BF_GroupOfEdges_4E || bf->Function == (void(*)())BF_GroupOfEdges_4F || bf->Function == (void(*)())BF_GroupOfEdges_4V || bf->Function == (void(*)())BF_CurlGroupOfEdges || bf->Function == (void(*)())BF_CurlGroupOfEdges_2E || bf->Function == (void(*)())BF_CurlGroupOfEdges_2F || bf->Function == (void(*)())BF_CurlGroupOfEdges_2V || bf->Function == (void(*)())BF_CurlGroupOfEdges_3E || bf->Function == (void(*)())BF_CurlGroupOfEdges_3F_a || bf->Function == (void(*)())BF_CurlGroupOfEdges_3F_b || bf->Function == (void(*)())BF_CurlGroupOfEdges_3F_c || bf->Function == (void(*)())BF_CurlGroupOfEdges_3V || bf->Function == (void(*)())BF_CurlGroupOfEdges_4E || bf->Function == (void(*)())BF_CurlGroupOfEdges_4F || bf->Function == (void(*)())BF_CurlGroupOfEdges_4V || bf->Function == (void(*)())BF_GroupOfPerpendicularEdges || bf->Function == (void(*)())BF_GroupOfPerpendicularEdges_2E || bf->Function == (void(*)())BF_GroupOfPerpendicularEdges_2F || bf->Function == (void(*)())BF_GroupOfPerpendicularEdges_2V || bf->Function == (void(*)())BF_GroupOfPerpendicularEdges_3E || bf->Function == (void(*)())BF_GroupOfPerpendicularEdges_3F || bf->Function == (void(*)())BF_GroupOfPerpendicularEdges_3V || bf->Function == (void(*)())BF_CurlGroupOfPerpendicularEdges || bf->Function == (void(*)())BF_CurlGroupOfPerpendicularEdges_2E || bf->Function == (void(*)())BF_CurlGroupOfPerpendicularEdges_2F || bf->Function == (void(*)())BF_CurlGroupOfPerpendicularEdges_2V || bf->Function == (void(*)())BF_CurlGroupOfPerpendicularEdges_3E || bf->Function == (void(*)())BF_CurlGroupOfPerpendicularEdges_3F || bf->Function == (void(*)())BF_CurlGroupOfPerpendicularEdges_3V || bf->Function == (void(*)())BF_GroupOfNodesX || bf->Function == (void(*)())BF_GroupOfNodesY || bf->Function == (void(*)())BF_GroupOfNodesZ || bf->Function == (void(*)())BF_GroupOfNodesX_D1 || bf->Function == (void(*)())BF_GroupOfNodesY_D1 || bf->Function == (void(*)())BF_GroupOfNodesZ_D1 || bf->Function == (void(*)())BF_GroupOfNodesX_D2 || bf->Function == (void(*)())BF_GroupOfNodesY_D2 || bf->Function == (void(*)())BF_GroupOfNodesZ_D2 || bf->Function == (void(*)())BF_GroupOfNodesX_D12 || bf->Function == (void(*)())BF_GroupOfNodesY_D12 || bf->Function == (void(*)())BF_GroupOfNodesZ_D12) return true; return false; } void Pre_TermOfFemEquation(struct Element * Element, struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0) { struct QuantityStorage * QuantityStorageEqu_P, * QuantityStorageDof_P ; int i ; bool NonLocal=false; QuantityStorageEqu_P = QuantityStorage_P0 + EquationTerm_P->Case.LocalTerm.Term.DefineQuantityIndexEqu ; QuantityStorageDof_P = (EquationTerm_P->Case.LocalTerm.Term.DefineQuantityIndexDof >= 0)? QuantityStorage_P0 + EquationTerm_P->Case.LocalTerm.Term.DefineQuantityIndexDof : NULL ; if (QuantityStorageEqu_P->NumLastElementForEquDefinition != Element->Num) { QuantityStorageEqu_P->NumLastElementForEquDefinition = Element->Num ; for (i = 0 ; i < QuantityStorageEqu_P->NbrElementaryBasisFunction ; i++){ NonLocal = (QuantityStorageEqu_P->TypeQuantity == INTEGRALQUANTITY) || IsEquationNonLocal(QuantityStorageEqu_P->BasisFunction[i].BasisFunction); switch(QuantityStorageEqu_P->BasisFunction[i].Constraint){ case NONE: Dof_DefineUnknownDof (QuantityStorageEqu_P->BasisFunction[i].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[i].CodeEntity, Current.NbrHar, NonLocal) ; break; case ASSIGN: Dof_DefineAssignFixedDof (QuantityStorageEqu_P->BasisFunction[i].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[i].CodeEntity, Current.NbrHar, QuantityStorageEqu_P->BasisFunction[i].Value, QuantityStorageEqu_P->BasisFunction[i].TimeFunctionIndex) ; break; case INIT: Dof_DefineInitFixedDof (QuantityStorageEqu_P->BasisFunction[i].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[i].CodeEntity, Current.NbrHar, QuantityStorageEqu_P->BasisFunction[i].Value, QuantityStorageEqu_P->BasisFunction[i].Value2, NonLocal) ; break; case ASSIGNFROMRESOLUTION: Dof_DefineAssignSolveDof (QuantityStorageEqu_P->BasisFunction[i].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[i].CodeEntity, Current.NbrHar, QuantityStorageEqu_P->BasisFunction[i].TimeFunctionIndex) ; break; case INITFROMRESOLUTION: Dof_DefineInitSolveDof (QuantityStorageEqu_P->BasisFunction[i].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[i].CodeEntity, Current.NbrHar); break; case CST_LINK: Dof_DefineLinkDof (QuantityStorageEqu_P->BasisFunction[i].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[i].CodeEntity, Current.NbrHar, QuantityStorageEqu_P->BasisFunction[i].Value, QuantityStorageEqu_P->BasisFunction[i].CodeEntity_Link) ; break; case CST_LINKCPLX: Dof_DefineLinkCplxDof (QuantityStorageEqu_P->BasisFunction[i].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[i].CodeEntity, Current.NbrHar, QuantityStorageEqu_P->BasisFunction[i].Value, QuantityStorageEqu_P->BasisFunction[i].CodeEntity_Link) ; break; } } } if (QuantityStorageDof_P && (QuantityStorageDof_P != QuantityStorageEqu_P) && (QuantityStorageDof_P->NumLastElementForDofDefinition != Element->Num)) { QuantityStorageDof_P->NumLastElementForDofDefinition = Element->Num ; for (i = 0 ; i < QuantityStorageDof_P->NbrElementaryBasisFunction ; i++) { NonLocal = (QuantityStorageDof_P->TypeQuantity == INTEGRALQUANTITY) || IsEquationNonLocal(QuantityStorageDof_P->BasisFunction[i].BasisFunction); switch(QuantityStorageDof_P->BasisFunction[i].Constraint){ case ASSIGN: Dof_DefineAssignFixedDof (QuantityStorageDof_P->BasisFunction[i].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[i].CodeEntity, Current.NbrHar, QuantityStorageDof_P->BasisFunction[i].Value, QuantityStorageDof_P->BasisFunction[i].TimeFunctionIndex) ; break; case INIT: Dof_DefineInitFixedDof (QuantityStorageDof_P->BasisFunction[i].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[i].CodeEntity, Current.NbrHar, QuantityStorageDof_P->BasisFunction[i].Value, QuantityStorageDof_P->BasisFunction[i].Value2, NonLocal) ; break; case ASSIGNFROMRESOLUTION: Dof_DefineAssignSolveDof (QuantityStorageDof_P->BasisFunction[i].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[i].CodeEntity, Current.NbrHar, QuantityStorageDof_P->BasisFunction[i].TimeFunctionIndex) ; break; case INITFROMRESOLUTION: Dof_DefineInitSolveDof (QuantityStorageDof_P->BasisFunction[i].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[i].CodeEntity, Current.NbrHar); break; case CST_LINK: Dof_DefineLinkDof (QuantityStorageDof_P->BasisFunction[i].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[i].CodeEntity, Current.NbrHar, QuantityStorageDof_P->BasisFunction[i].Value, QuantityStorageDof_P->BasisFunction[i].CodeEntity_Link) ; break; case CST_LINKCPLX: Dof_DefineLinkCplxDof (QuantityStorageDof_P->BasisFunction[i].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[i].CodeEntity, Current.NbrHar, QuantityStorageDof_P->BasisFunction[i].Value, QuantityStorageDof_P->BasisFunction[i].CodeEntity_Link) ; break; } } } } /* ------------------------------------------------------------------------ */ /* P r e _ I n i t G l o b a l T e r m O f F e m F o r m u l a t i o n */ /* ------------------------------------------------------------------------ */ void Pre_InitGlobalTermOfFemEquation(struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0) { struct DefineQuantity * DefineQuantity_P ; if (EquationTerm_P->Case.GlobalTerm.Term.DefineQuantityIndexDof >= 0) { DefineQuantity_P = (QuantityStorage_P0 + EquationTerm_P->Case.GlobalTerm.Term.DefineQuantityIndexDof)->DefineQuantity ; Dof_AddFunctionSpaceIndex(DefineQuantity_P->FunctionSpaceIndex) ; } if (EquationTerm_P->Case.GlobalTerm.Term.DefineQuantityIndexNoDof >= 0) { DefineQuantity_P = (QuantityStorage_P0 + EquationTerm_P->Case.GlobalTerm.Term.DefineQuantityIndexNoDof)->DefineQuantity ; Dof_AddFunctionSpaceIndex(DefineQuantity_P->FunctionSpaceIndex) ; } } /* ------------------------------------------------------------------------ */ /* P r e _ G l o b a l T e r m O f F e m F o r m u l a t i o n */ /* ------------------------------------------------------------------------ */ void Pre_GlobalTermOfFemEquation(int Num_Region, struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0) { struct QuantityStorage * QuantityStorageEqu_P, * QuantityStorageDof_P ; QuantityStorageEqu_P = QuantityStorage_P0 + EquationTerm_P->Case.GlobalTerm.Term.DefineQuantityIndexEqu ; QuantityStorageDof_P = (EquationTerm_P->Case.GlobalTerm.Term.DefineQuantityIndexDof >= 0)? QuantityStorage_P0 + EquationTerm_P->Case.GlobalTerm.Term.DefineQuantityIndexDof : NULL ; if (QuantityStorageEqu_P->NbrElementaryBasisFunction == 1) { switch(QuantityStorageEqu_P->BasisFunction[0].Constraint) { case NONE: Dof_DefineUnknownDof (QuantityStorageEqu_P->BasisFunction[0].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[0].CodeEntity, Current.NbrHar, true) ; break ; case ASSIGN: Dof_DefineAssignFixedDof (QuantityStorageEqu_P->BasisFunction[0].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[0].CodeEntity, Current.NbrHar, QuantityStorageEqu_P->BasisFunction[0].Value, QuantityStorageEqu_P->BasisFunction[0].TimeFunctionIndex) ; break ; case INIT: Dof_DefineInitFixedDof (QuantityStorageEqu_P->BasisFunction[0].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[0].CodeEntity, Current.NbrHar, QuantityStorageEqu_P->BasisFunction[0].Value, QuantityStorageEqu_P->BasisFunction[0].Value2, true) ; break; case ASSIGNFROMRESOLUTION: Dof_DefineAssignSolveDof (QuantityStorageEqu_P->BasisFunction[0].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[0].CodeEntity, Current.NbrHar, QuantityStorageEqu_P->BasisFunction[0].TimeFunctionIndex) ; break; case INITFROMRESOLUTION: Dof_DefineInitSolveDof (QuantityStorageEqu_P->BasisFunction[0].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[0].CodeEntity, Current.NbrHar); break; case CST_LINK: Dof_DefineLinkDof (QuantityStorageEqu_P->BasisFunction[0].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[0].CodeEntity, Current.NbrHar, QuantityStorageEqu_P->BasisFunction[0].Value, QuantityStorageEqu_P->BasisFunction[0].CodeEntity_Link) ; break; case CST_LINKCPLX: Dof_DefineLinkCplxDof (QuantityStorageEqu_P->BasisFunction[0].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[0].CodeEntity, Current.NbrHar, QuantityStorageEqu_P->BasisFunction[0].Value, QuantityStorageEqu_P->BasisFunction[0].CodeEntity_Link) ; break; } } if (QuantityStorageDof_P && (QuantityStorageDof_P != QuantityStorageEqu_P)) { if (QuantityStorageDof_P->NbrElementaryBasisFunction == 1) { switch(QuantityStorageDof_P->BasisFunction[0].Constraint) { case NONE: if (QuantityStorageDof_P->BasisFunction[0].CodeAssociateBasisFunction > 0) Dof_DefineAssociateDof (QuantityStorageDof_P->BasisFunction[0].CodeAssociateBasisFunction, QuantityStorageDof_P->BasisFunction[0].CodeEntity, QuantityStorageDof_P->BasisFunction[0].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[0].CodeEntity, Current.NbrHar, 0, NULL) ; break ; case ASSIGN: Dof_DefineAssignFixedDof (QuantityStorageDof_P->BasisFunction[0].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[0].CodeEntity, Current.NbrHar, QuantityStorageDof_P->BasisFunction[0].Value, QuantityStorageDof_P->BasisFunction[0].TimeFunctionIndex) ; break ; case INIT: Dof_DefineAssociateDof (QuantityStorageDof_P->BasisFunction[0].CodeAssociateBasisFunction, QuantityStorageDof_P->BasisFunction[0].CodeEntity, QuantityStorageDof_P->BasisFunction[0].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[0].CodeEntity, Current.NbrHar, 1, QuantityStorageDof_P->BasisFunction[0].Value) ; /* Dof_DefineInitFixedDof (QuantityStorageDof_P->BasisFunction[0].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[0].CodeEntity, Current.NbrHar, QuantityStorageDof_P->BasisFunction[0].Value, QuantityStorageDof_P->BasisFunction[0].Value2, true); */ break; case ASSIGNFROMRESOLUTION: Dof_DefineAssignSolveDof (QuantityStorageDof_P->BasisFunction[0].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[0].CodeEntity, Current.NbrHar, QuantityStorageDof_P->BasisFunction[0].TimeFunctionIndex) ; break; case INITFROMRESOLUTION: Dof_DefineInitSolveDof (QuantityStorageDof_P->BasisFunction[0].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[0].CodeEntity, Current.NbrHar); break; case CST_LINK: Dof_DefineLinkDof (QuantityStorageDof_P->BasisFunction[0].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[0].CodeEntity, Current.NbrHar, QuantityStorageDof_P->BasisFunction[0].Value, QuantityStorageDof_P->BasisFunction[0].CodeEntity_Link) ; break; case CST_LINKCPLX: Dof_DefineLinkCplxDof (QuantityStorageDof_P->BasisFunction[0].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[0].CodeEntity, Current.NbrHar, QuantityStorageDof_P->BasisFunction[0].Value, QuantityStorageDof_P->BasisFunction[0].CodeEntity_Link) ; break; } } } } /* ------------------------------------------------------------------------ */ /* C s t _ G l o b a l T e r m O f F e m F o r m u l a t i o n */ /* ------------------------------------------------------------------------ */ void Cst_GlobalTermOfFemEquation(int Num_Region, struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0) { struct QuantityStorage * QuantityStorageEqu_P, * QuantityStorageDof_P ; QuantityStorageEqu_P = QuantityStorage_P0 + EquationTerm_P->Case.GlobalTerm.Term.DefineQuantityIndexEqu ; QuantityStorageDof_P = (EquationTerm_P->Case.GlobalTerm.Term.DefineQuantityIndexDof >= 0)? QuantityStorage_P0 + EquationTerm_P->Case.GlobalTerm.Term.DefineQuantityIndexDof : NULL ; if (QuantityStorageEqu_P->NbrElementaryBasisFunction == 1) { switch(QuantityStorageEqu_P->BasisFunction[0].Constraint) { case ASSIGN: Dof_UpdateAssignFixedDof (QuantityStorageEqu_P->BasisFunction[0].Dof, Current.NbrHar, QuantityStorageEqu_P->BasisFunction[0].Value) ; break ; case CST_LINK: case CST_LINKCPLX: Dof_UpdateLinkDof (QuantityStorageEqu_P->BasisFunction[0].Dof, Current.NbrHar, QuantityStorageEqu_P->BasisFunction[0].Value, QuantityStorageEqu_P->BasisFunction[0].CodeEntity_Link) ; break; } } if (QuantityStorageDof_P && (QuantityStorageDof_P != QuantityStorageEqu_P)) { if (QuantityStorageDof_P->NbrElementaryBasisFunction == 1) { switch(QuantityStorageDof_P->BasisFunction[0].Constraint) { case ASSIGN: Dof_UpdateAssignFixedDof (QuantityStorageDof_P->BasisFunction[0].Dof, Current.NbrHar, QuantityStorageDof_P->BasisFunction[0].Value) ; break ; case CST_LINK: case CST_LINKCPLX: Dof_UpdateLinkDof (QuantityStorageDof_P->BasisFunction[0].Dof, Current.NbrHar, QuantityStorageDof_P->BasisFunction[0].Value, QuantityStorageDof_P->BasisFunction[0].CodeEntity_Link) ; break; } } } } /* ------------------------------------------------------------------------ */ /* P r e _ F e m G l o b a l E q u a t i o n */ /* ------------------------------------------------------------------------ */ void Pre_FemGlobalEquation2(int Index_DefineQuantity, int Num_Region, struct DefineQuantity * DefineQuantity_P0, struct QuantityStorage * QuantityStorage_P0) { struct DefineQuantity * DefineQuantity_P ; struct QuantityStorage * QuantityStorage_P ; struct GlobalQuantity * GlobalQuantity_P ; struct QuantityStorage QuaSto_S ; DefineQuantity_P = DefineQuantity_P0 + Index_DefineQuantity ; QuantityStorage_P = QuantityStorage_P0 + Index_DefineQuantity ; GlobalQuantity_P = (struct GlobalQuantity*) List_Pointer(QuantityStorage_P->FunctionSpace->GlobalQuantity, *(int *)List_Pointer(DefineQuantity_P->IndexInFunctionSpace, 0)) ; Get_DofOfRegion(Num_Region, GlobalQuantity_P, QuantityStorage_P->FunctionSpace, &QuaSto_S) ; if (QuaSto_S.NbrElementaryBasisFunction == 1) { switch(QuaSto_S.BasisFunction[0].Constraint) { case NONE: Dof_DefineUnknownDof (QuaSto_S.BasisFunction[0].CodeBasisFunction, QuaSto_S.BasisFunction[0].CodeEntity, Current.NbrHar, true) ; break ; case ASSIGN: Dof_DefineAssignFixedDof (QuaSto_S.BasisFunction[0].CodeBasisFunction, QuaSto_S.BasisFunction[0].CodeEntity, Current.NbrHar, QuaSto_S.BasisFunction[0].Value, QuaSto_S.BasisFunction[0].TimeFunctionIndex) ; break ; case INIT: Dof_DefineInitFixedDof (QuaSto_S.BasisFunction[0].CodeBasisFunction, QuaSto_S.BasisFunction[0].CodeEntity, Current.NbrHar, QuaSto_S.BasisFunction[0].Value, QuaSto_S.BasisFunction[0].Value2, true); break; case ASSIGNFROMRESOLUTION: Dof_DefineAssignSolveDof (QuaSto_S.BasisFunction[0].CodeBasisFunction, QuaSto_S.BasisFunction[0].CodeEntity, Current.NbrHar, QuaSto_S.BasisFunction[0].TimeFunctionIndex) ; break; case INITFROMRESOLUTION: Dof_DefineInitSolveDof (QuaSto_S.BasisFunction[0].CodeBasisFunction, QuaSto_S.BasisFunction[0].CodeEntity, Current.NbrHar); break; case CST_LINK: Dof_DefineLinkDof (QuaSto_S.BasisFunction[0].CodeBasisFunction, QuaSto_S.BasisFunction[0].CodeEntity, Current.NbrHar, QuaSto_S.BasisFunction[0].Value, QuaSto_S.BasisFunction[0].CodeEntity_Link) ; break; case CST_LINKCPLX: Dof_DefineLinkCplxDof (QuaSto_S.BasisFunction[0].CodeBasisFunction, QuaSto_S.BasisFunction[0].CodeEntity, Current.NbrHar, QuaSto_S.BasisFunction[0].Value, QuaSto_S.BasisFunction[0].CodeEntity_Link) ; break; } } } void Pre_FemGlobalEquation(struct EquationTerm * EquationTerm_P, struct DefineQuantity * DefineQuantity_P0, struct QuantityStorage * QuantityStorage_P0) { int Nbr_GlobalEquationTerm, i_GlobalEquationTerm ; struct Constraint * Constraint_P ; struct GlobalEquationTerm * GlobalEquationTerm_P ; int Nbr_EquAndDof ; List_T * InitialListInIndex_L, * RegionIndex_L ; int Nbr_Region, i_Region, Num_Region ; int Nbr_MCPR, i_MCPR, Nbr_CPR, i_CPR, Nbr_GlobalEqu ; struct MultiConstraintPerRegion * MCPR_P ; struct ConstraintPerRegion * CPR_P ; struct Group * Group_P ; struct DofGlobal { int NumRegion ; struct Dof * Dof ; } ; /* Liste des Regions auxquelles on associe des Equations de Type 'Network' */ RegionIndex_L = List_Create(50,50, sizeof(int)) ; Constraint_P = (struct Constraint*) List_Pointer(Problem_S.Constraint, EquationTerm_P->Case.GlobalEquation.ConstraintIndex) ; Nbr_MCPR = List_Nbr(Constraint_P->MultiConstraintPerRegion) ; for (i_MCPR = 0 ; i_MCPR < Nbr_MCPR ; i_MCPR++) { MCPR_P = (struct MultiConstraintPerRegion*) List_Pointer(Constraint_P->MultiConstraintPerRegion, i_MCPR) ; Nbr_CPR = List_Nbr(MCPR_P->ConstraintPerRegion) ; for (i_CPR = 0 ; i_CPR < Nbr_CPR ; i_CPR++) { CPR_P = (struct ConstraintPerRegion*) List_Pointer(MCPR_P->ConstraintPerRegion, i_CPR) ; Group_P = (struct Group *)List_Pointer(Problem_S.Group, CPR_P->RegionIndex) ; if (List_Nbr(Group_P->InitialList) == 1) { List_Read(Group_P->InitialList, 0, &Num_Region) ; if (!List_Search(RegionIndex_L, &Num_Region, fcmp_int)) List_Add(RegionIndex_L, &Num_Region) ; else Message::Error("2 occurences of Elementary Region #%d in Contraint '%s'", Num_Region, Constraint_P->Name); } else Message::Error("Not 1 Elementary Region in Group '%s'", Group_P->Name); } } Nbr_EquAndDof = List_Nbr(RegionIndex_L) ; if (!Nbr_EquAndDof){ return ; } /* Codes des Dof globaux pour Equ, DofNode, DofLoop */ Nbr_GlobalEqu = 0 ; Nbr_GlobalEquationTerm = List_Nbr(EquationTerm_P->Case.GlobalEquation.GlobalEquationTerm) ; for (i_GlobalEquationTerm = 0 ; i_GlobalEquationTerm < Nbr_GlobalEquationTerm ; i_GlobalEquationTerm++) { GlobalEquationTerm_P = (struct GlobalEquationTerm*) List_Pointer(EquationTerm_P->Case.GlobalEquation.GlobalEquationTerm, i_GlobalEquationTerm) ; InitialListInIndex_L = ((struct Group *)List_Pointer(Problem_S.Group, GlobalEquationTerm_P->InIndex))->InitialList ; Nbr_Region = List_Nbr(InitialListInIndex_L) ; List_Sort(InitialListInIndex_L, fcmp_int) ; for (i_Region = 0 ; i_Region < Nbr_Region ; i_Region++) { List_Read(InitialListInIndex_L, i_Region, &Num_Region) ; if (List_Search(RegionIndex_L, &Num_Region, fcmp_int)) { Pre_FemGlobalEquation2 (GlobalEquationTerm_P->DefineQuantityIndexEqu, Num_Region, DefineQuantity_P0, QuantityStorage_P0) ; Pre_FemGlobalEquation2 (GlobalEquationTerm_P->DefineQuantityIndexNode, Num_Region, DefineQuantity_P0, QuantityStorage_P0) ; Pre_FemGlobalEquation2 (GlobalEquationTerm_P->DefineQuantityIndexLoop, Num_Region, DefineQuantity_P0, QuantityStorage_P0) ; Nbr_GlobalEqu++ ; } } } if (Nbr_GlobalEqu != Nbr_EquAndDof){ Message::Error("Incompatible number of equations with Contraint '%s'", Constraint_P->Name); Message::Error("(%d equations obtained while %d branches are defined)", Nbr_GlobalEqu, Nbr_EquAndDof); } List_Delete(RegionIndex_L) ; } /* ------------------------------------------------------------------------ */ /* C s t _ T e r m O f F e m F o r m u l a t i o n */ /* ------------------------------------------------------------------------ */ void Cst_TermOfFemEquation(struct Element * Element, struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0) { struct QuantityStorage * QuantityStorageEqu_P, * QuantityStorageDof_P ; int i ; QuantityStorageEqu_P = QuantityStorage_P0 + EquationTerm_P->Case.LocalTerm.Term.DefineQuantityIndexEqu ; QuantityStorageDof_P = (EquationTerm_P->Case.LocalTerm.Term.DefineQuantityIndexDof >= 0)? QuantityStorage_P0 + EquationTerm_P->Case.LocalTerm.Term.DefineQuantityIndexDof : NULL ; if (QuantityStorageEqu_P->NumLastElementForEquDefinition != Element->Num) { QuantityStorageEqu_P->NumLastElementForEquDefinition = Element->Num ; for (i = 0 ; i < QuantityStorageEqu_P->NbrElementaryBasisFunction ; i++) switch(QuantityStorageEqu_P->BasisFunction[i].Constraint){ /* case NONE: Dof_DefineUnknownDof (QuantityStorageEqu_P->BasisFunction[i].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[i].CodeEntity, Current.NbrHar) ; break; */ case ASSIGN: Dof_UpdateAssignFixedDof (QuantityStorageEqu_P->BasisFunction[i].Dof, Current.NbrHar, QuantityStorageEqu_P->BasisFunction[i].Value) ; break; /* case INIT: Dof_DefineInitFixedDof (QuantityStorageEqu_P->BasisFunction[i].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[i].CodeEntity, Current.NbrHar, QuantityStorageEqu_P->BasisFunction[i].Value, QuantityStorageEqu_P->BasisFunction[i].Value2, false) ; break; case ASSIGNFROMRESOLUTION: Dof_DefineAssignSolveDof (QuantityStorageEqu_P->BasisFunction[i].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[i].CodeEntity, Current.NbrHar, QuantityStorageEqu_P->BasisFunction[i].TimeFunctionIndex) ; break; case INITFROMRESOLUTION: Dof_DefineInitSolveDof (QuantityStorageEqu_P->BasisFunction[i].CodeBasisFunction, QuantityStorageEqu_P->BasisFunction[i].CodeEntity, Current.NbrHar); break; */ case CST_LINK: case CST_LINKCPLX: Dof_UpdateLinkDof (QuantityStorageEqu_P->BasisFunction[i].Dof, Current.NbrHar, QuantityStorageEqu_P->BasisFunction[i].Value, QuantityStorageEqu_P->BasisFunction[i].CodeEntity_Link) ; break; } } if (QuantityStorageDof_P && (QuantityStorageDof_P != QuantityStorageEqu_P) && (QuantityStorageDof_P->NumLastElementForDofDefinition != Element->Num)) { QuantityStorageDof_P->NumLastElementForDofDefinition = Element->Num ; for (i = 0 ; i < QuantityStorageDof_P->NbrElementaryBasisFunction ; i++) switch(QuantityStorageDof_P->BasisFunction[i].Constraint){ case ASSIGN: Dof_UpdateAssignFixedDof (QuantityStorageDof_P->BasisFunction[i].Dof, Current.NbrHar, QuantityStorageDof_P->BasisFunction[i].Value) ; break; /* case INIT: Dof_DefineInitFixedDof (QuantityStorageDof_P->BasisFunction[i].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[i].CodeEntity, Current.NbrHar, QuantityStorageDof_P->BasisFunction[i].Value, QuantityStorageDof_P->BasisFunction[i].Value2) ; break; case ASSIGNFROMRESOLUTION: Dof_DefineAssignSolveDof (QuantityStorageDof_P->BasisFunction[i].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[i].CodeEntity, Current.NbrHar, QuantityStorageDof_P->BasisFunction[i].TimeFunctionIndex) ; break; case INITFROMRESOLUTION: Dof_DefineInitSolveDof (QuantityStorageDof_P->BasisFunction[i].CodeBasisFunction, QuantityStorageDof_P->BasisFunction[i].CodeEntity, Current.NbrHar); break; */ case CST_LINK: case CST_LINKCPLX: Dof_UpdateLinkDof (QuantityStorageDof_P->BasisFunction[i].Dof, Current.NbrHar, QuantityStorageDof_P->BasisFunction[i].Value, QuantityStorageDof_P->BasisFunction[i].CodeEntity_Link) ; break; } } } getdp-2.4.2-source/Legacy/Operation_ChangeOfCoordinates.cpp000644 001750 001750 00000016212 12116424202 025371 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Johan Gyselinck // Ruth Sabariego // #include #include #include #include "ProData.h" #include "DofData.h" #include "GeoData.h" #include "Pos_Search.h" #include "SolvingOperations.h" #include "Cal_Quantity.h" #include "ExtendedGroup.h" #include "BF.h" #include "Message.h" extern struct Problem Problem_S ; extern struct CurrentData Current ; /* ------------------------------------------------------------------------ */ /* O p e r a t i o n _ C h a n g e O f C o o r d i n a t e s */ /* ------------------------------------------------------------------------ */ void Operation_ChangeOfCoordinates(struct Resolution * Resolution_P, struct Operation * Operation_P, struct DofData * DofData_P0, struct GeoData * GeoData_P0) { int i, Nbr_Node, Num_Node, ThisIsTheNode ; double x=0., y=0., z=0.; struct Value Value, Value1, Value2 ; struct Group * Group_P ; Group_P = (struct Group *) List_Pointer(Problem_S.Group, Operation_P->Case.ChangeOfCoordinates.GroupIndex) ; if (!Group_P->ExtendedList) Generate_ExtendedGroup(Group_P) ; if (Group_P->FunctionType != NODESOF) Message::Error("ChangeOfCoordinates: Group must be of NodesOf function type") ; Nbr_Node = List_Nbr(Group_P->ExtendedList) ; for (i=0 ; i < Nbr_Node ; i++) { List_Read(Group_P->ExtendedList, i, &Num_Node) ; if (!Group_P->InitialSuppList || ! List_Search(Group_P->ExtendedSuppList, &Num_Node, fcmp_int)) { Geo_GetNodesCoordinates(1, &Num_Node, &Current.x, &Current.y, &Current.z) ; if (Operation_P->Case.ChangeOfCoordinates.ExpressionIndex2 >= 0 && Num_Node == Operation_P->Case.ChangeOfCoordinates.NumNode) { x = Current.x ; y = Current.y ; z = Current.z ; Get_ValueOfExpressionByIndex (Operation_P->Case.ChangeOfCoordinates.ExpressionIndex2, NULL, 0., 0., 0., &Value1) ; ThisIsTheNode = 1 ; } else ThisIsTheNode = 0 ; Get_ValueOfExpressionByIndex (Operation_P->Case.ChangeOfCoordinates.ExpressionIndex, NULL, 0., 0., 0., &Value) ; if (ThisIsTheNode) { Current.x = Value.Val[0] ; Current.y = Value.Val[1] ; Current.z = Value.Val[2] ; Get_ValueOfExpressionByIndex (Operation_P->Case.ChangeOfCoordinates.ExpressionIndex2, NULL, 0., 0., 0., &Value2) ; printf("before x %e y %e z %e ||| after x %e y %e z %e\n", x, y, z, Value.Val[0], Value.Val[1], Value.Val[2]); Message::Info(" before %e after %e", Value1.Val[0], Value2.Val[0]) ; } Geo_SetNodesCoordinates(1, &Num_Node, &Value.Val[0], &Value.Val[1], &Value.Val[2]) ; } } Free_SearchGrid(&Current.GeoData->Grid); Init_SearchGrid(&Current.GeoData->Grid); } /* ------------------------------------------------------------------------ */ /* O p e r a t i o n _ D e f o r m e M e s h */ /* ------------------------------------------------------------------------ */ void Operation_DeformeMesh(struct Resolution * Resolution_P, struct Operation * Operation_P, struct DofData * DofData_P0, struct GeoData * GeoData_P0) { int i, Num_Node, NumBF_X=-1, NumBF_Y=-1, NumBF_Z=-1 ; double Value, un_x = 0., un_y = 0., un_z = 0. ; struct DefineSystem * DS ; struct Formulation * FO ; struct DefineQuantity * DQ_P ; struct FunctionSpace * FunctionSpace_P ; struct DofData * DofData_P ; DS = (struct DefineSystem*)List_Pointer(Resolution_P->DefineSystem, Operation_P->DefineSystemIndex) ; if( List_Nbr(DS->FormulationIndex) > 1 ) Message::Error("DeformeMesh: Only one formulation must be associated to the system %s", DS->Name) ; FO = (struct Formulation *) List_Pointer(Problem_S.Formulation, *((int *)List_Pointer(DS->FormulationIndex, 0))) ; if((i = List_ISearchSeq(FO->DefineQuantity, Operation_P->Case.DeformeMesh.Quantity, fcmp_DefineQuantity_Name)) < 0) Message::Error("Unknown Quantity '%s' in Formulation %s", Operation_P->Case.DeformeMesh.Quantity, FO->Name ) ; DQ_P = (struct DefineQuantity *) List_Pointer(FO->DefineQuantity, i) ; DofData_P = DofData_P0 + Operation_P->DefineSystemIndex ; FunctionSpace_P = (struct FunctionSpace*)List_Pointer(Problem_S.FunctionSpace, DQ_P->FunctionSpaceIndex) ; for(i = 0 ; i < List_Nbr(FunctionSpace_P->BasisFunction); i++){ if( (void(*)())((struct BasisFunction*)List_Pointer(FunctionSpace_P->BasisFunction, i))->Function == (void(*)())BF_NodeX ) NumBF_X = ((struct BasisFunction*)List_Pointer(FunctionSpace_P->BasisFunction, i))->Num; if( (void(*)())((struct BasisFunction*)List_Pointer(FunctionSpace_P->BasisFunction, i))->Function == (void(*)())BF_NodeY ) NumBF_Y = ((struct BasisFunction*)List_Pointer(FunctionSpace_P->BasisFunction, i))->Num; if( (void(*)())((struct BasisFunction*)List_Pointer(FunctionSpace_P->BasisFunction, i))->Function == (void(*)())BF_NodeZ ) NumBF_Z = ((struct BasisFunction*)List_Pointer(FunctionSpace_P->BasisFunction, i))->Num; } for(i = 0 ; i < List_Nbr(FunctionSpace_P->DofData->DofList) ; i++){ if (((struct Dof*)List_Pointer(FunctionSpace_P->DofData->DofList, i ))->NumType == NumBF_X || ((struct Dof*)List_Pointer(FunctionSpace_P->DofData->DofList, i ))->NumType == NumBF_Y || ((struct Dof*)List_Pointer(FunctionSpace_P->DofData->DofList, i ))->NumType == NumBF_Z ){ Dof_GetRealDofValue (FunctionSpace_P->DofData, ((struct Dof*)List_Pointer(FunctionSpace_P->DofData->DofList, i )) , &Value) ; Num_Node = ((struct Dof*)List_Pointer(FunctionSpace_P->DofData->DofList, i ))->Entity ; /* Reference mesh */ Geo_SetCurrentGeoData(Current.GeoData = GeoData_P0 + Operation_P->Case.DeformeMesh.GeoDataIndex) ; Geo_GetNodesCoordinates(1, &Num_Node, &un_x, &un_y, &un_z) ; /* Mesh associated to the electromechanical system */ if( GeoData_P0 + DofData_P->GeoDataIndex != GeoData_P0 + Operation_P->Case.DeformeMesh.GeoDataIndex ) Geo_SetCurrentGeoData(Current.GeoData = GeoData_P0 + DofData_P->GeoDataIndex) ; if (((struct Dof*)List_Pointer(FunctionSpace_P->DofData->DofList, i))->NumType == NumBF_X){ un_x += Operation_P->Case.DeformeMesh.Factor * Value ; Geo_SetNodesCoordinatesX(1, &Num_Node, &un_x) ; } if (((struct Dof*)List_Pointer(FunctionSpace_P->DofData->DofList, i))->NumType == NumBF_Y){ un_y += Operation_P->Case.DeformeMesh.Factor * Value ; Geo_SetNodesCoordinatesY(1, &Num_Node, &un_y) ; } if (((struct Dof*)List_Pointer(FunctionSpace_P->DofData->DofList, i))->NumType == NumBF_Z){ un_z += Operation_P->Case.DeformeMesh.Factor * Value ; Geo_SetNodesCoordinatesZ(1, &Num_Node, &un_z) ; } } } Current.GeoData = GeoData_P0 + Operation_P->Case.DeformeMesh.GeoDataIndex; Free_SearchGrid(&Current.GeoData->Grid); Init_SearchGrid(&Current.GeoData->Grid) ; } getdp-2.4.2-source/Legacy/F_MultiHar.cpp000644 001750 001750 00000062315 12116424202 021503 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Johan Gyselinck // #include #include "ProData.h" #include "ProDefine.h" #include "DofData.h" #include "F.h" #include "Get_Geometry.h" #include "Get_FunctionValue.h" #include "Cal_Quantity.h" #include "MallocUtils.h" #include "Message.h" #define TWO_PI 6.2831853071795865 extern struct Problem Problem_S ; extern struct CurrentData Current ; struct MH_InitData{ int Case ; int NbrPoints, NbrPointsX; /* number of samples per smallest and fundamental period resp. */ struct DofData *DofData ; double **H, ***HH ; double *t, *w; }; List_T * MH_InitData_L = NULL; int fcmp_MH_InitData(const void * a, const void * b) { int Result ; if ((Result = ((struct MH_InitData *)a)->DofData - ((struct MH_InitData *)b)->DofData) != 0) return Result ; if ((Result = ((struct MH_InitData *)a)->Case - ((struct MH_InitData *)b)->Case) != 0) return Result ; if (((struct MH_InitData *)a)->Case != 3) return ((struct MH_InitData *)a)->NbrPoints - ((struct MH_InitData *)b)->NbrPoints ; else return ((struct MH_InitData *)a)->NbrPointsX - ((struct MH_InitData *)b)->NbrPointsX ; } int NbrValues_Type (int Type) { switch (Type){ case SCALAR : return 1 ; case VECTOR : case TENSOR_DIAG : return 3 ; case TENSOR_SYM : return 6 ; case TENSOR : return 9 ; default : Message::Error("Unknown type in NbrValues_Type"); return 0; } } double Product_SCALARxSCALARxSCALAR (double *V1, double *V2, double *V3) { return V1[0] * V2[0] * V3[0] ; } double Product_VECTORxTENSOR_SYMxVECTOR (double *V1, double *V2, double *V3) { return V3[0] * (V1[0] * V2[0] + V1[1] * V2[1] + V1[2] * V2[2]) + V3[1] * (V1[0] * V2[1] + V1[1] * V2[3] + V1[2] * V2[4]) + V3[2] * (V1[0] * V2[2] + V1[1] * V2[4] + V1[2] * V2[5]) ; } double Product_VECTORxTENSOR_DIAGxVECTOR (double *V1, double *V2, double *V3) { return V1[0] * V2[0] * V3[0] + V1[1] * V2[1] * V3[1] + V1[2] * V2[2] * V3[2] ; } double Product_VECTORxSCALARxVECTOR (double *V1, double *V2, double *V3) { return V2[0] * (V1[0] * V3[0] + V1[1] * V3[1] + V1[2] * V3[2]) ; } void *Get_RealProductFunction_Type1xType2xType1 (int Type1, int Type2) { if (Type1 == SCALAR && Type2 == SCALAR) { return (void *)Product_SCALARxSCALARxSCALAR; } else if (Type1 == VECTOR && Type2 == TENSOR_SYM) { return (void *)Product_VECTORxTENSOR_SYMxVECTOR; } else if (Type1 == VECTOR && Type2 == TENSOR_DIAG) { return (void *)Product_VECTORxTENSOR_DIAGxVECTOR; } else if (Type1 == VECTOR && Type1 == SCALAR) { return (void *)Product_VECTORxSCALARxVECTOR; } else { Message::Error("Not allowed types in Get_RealProductFunction_Type1xType2xType1"); return 0; } } /* ------------------------------------------------------------------------ */ /* MH_Get_InitData */ /* ------------------------------------------------------------------------ */ /* Case = 1 : MHTransform NbrPoints (samples per smallest period) is given, NbrPointsX (samples per fundamental period) is derived Case = 2 : MHJacNL NbrPoints given, NbrPointsX derived Case = 3 : HarmonicToTime NbrPointsX given, NbrPoints derived */ void MH_Get_InitData(int Case, int NbrPoints, int *NbrPointsX_P, double ***H_P, double ****HH_P, double **t_P, double **w_P) { int NbrHar, iPul, iTime, iHar, jHar, NbrPointsX ; double *Val_Pulsation, MaxPuls, MinPuls ; double **H, ***HH = 0, *t, *w ; struct MH_InitData MH_InitData_S, *MH_InitData_P ; MH_InitData_S.Case = Case; MH_InitData_S.DofData = Current.DofData; MH_InitData_S.NbrPoints = NbrPoints; MH_InitData_S.NbrPointsX = NbrPointsX = *NbrPointsX_P; if (MH_InitData_L == NULL) MH_InitData_L = List_Create(1, 1, sizeof(struct MH_InitData)) ; if ((MH_InitData_P = (struct MH_InitData *) List_PQuery(MH_InitData_L, &MH_InitData_S, fcmp_MH_InitData))){ *H_P = MH_InitData_P->H; *HH_P = MH_InitData_P->HH; *t_P = MH_InitData_P->t; *w_P = MH_InitData_P->w; *NbrPointsX_P = MH_InitData_P->NbrPointsX; return; } NbrHar = Current.NbrHar; Val_Pulsation = Current.DofData->Val_Pulsation; MaxPuls = 0. ; MinPuls = 1.e99 ; for (iPul = 0 ; iPul < NbrHar/2 ; iPul++) { if (Val_Pulsation[iPul] && Val_Pulsation[iPul] < MinPuls) MinPuls = Val_Pulsation[iPul] ; if (Val_Pulsation[iPul] && Val_Pulsation[iPul] > MaxPuls) MaxPuls = Val_Pulsation[iPul] ; } if (Case != 3) NbrPointsX = (int)((MaxPuls/MinPuls*(double)NbrPoints)); else NbrPoints = (int)((MinPuls/MaxPuls*(double)NbrPointsX)); Message::Info("MH_Get_InitData => NbrHar = %d NbrPoints = %d|%d Case = %d", NbrHar, NbrPoints, NbrPointsX, Case); t = (double *)Malloc(sizeof(double)*NbrPointsX) ; if (Case != 3) for (iTime = 0 ; iTime < NbrPointsX ; iTime++) t[iTime] = (double)iTime/(double)NbrPointsX/(MinPuls/TWO_PI) ; else for (iTime = 0 ; iTime < NbrPointsX ; iTime++) t[iTime] = (double)iTime/((double)NbrPointsX-1.)/(MinPuls/TWO_PI) ; /* w = (double *)Malloc(sizeof(double)*NbrPointsX) ; for (iTime = 0 ; iTime < NbrPointsX ; iTime++) w[iTime] = 2. / (double)NbrPointsX ; */ w = (double *)Malloc(sizeof(double)*NbrHar) ; for (iPul = 0 ; iPul < NbrHar/2 ; iPul++) if (Val_Pulsation[iPul]){ w[2*iPul ] = 2. / (double)NbrPointsX ; w[2*iPul+1] = 2. / (double)NbrPointsX ; }else{ w[2*iPul ] = 1. / (double)NbrPointsX ; w[2*iPul+1] = 1. / (double)NbrPointsX ; } H = (double **)Malloc(sizeof(double *)*NbrPointsX) ; for (iTime = 0 ; iTime < NbrPointsX ; iTime++){ H[iTime] = (double *)Malloc(sizeof(double)*NbrHar) ; for (iPul = 0 ; iPul < NbrHar/2 ; iPul++) { /* if (Val_Pulsation [iPul]){ */ H[iTime][2*iPul ] = cos(Val_Pulsation[iPul] * t[iTime]) ; H[iTime][2*iPul+1] = - sin(Val_Pulsation[iPul] * t[iTime]) ; } /* } else { H[iTime][2*iPul ] = 0.5 ; H[iTime][2*iPul + 1] = 0 ; } */ } /* for (iHar = 0 ; iHar < NbrHar ; iHar++) for (jHar = iHar ; jHar < NbrHar ; jHar++){ sum = 0.; for (iTime = 0 ; iTime < NbrPointsX ; iTime++) sum += w[iTime] * H[iTime][iHar] * H[iTime][jHar] ; sum -= (iHar==jHar)? 1. : 0. ; printf("iHar %d jHar %d sum %e\n", iHar, jHar, sum); } */ if (Case == 2) { HH = (double ***)Malloc(sizeof(double **)*NbrPointsX) ; for (iTime = 0 ; iTime < NbrPointsX ; iTime++){ HH[iTime] = (double **)Malloc(sizeof(double *)*NbrHar) ; for (iHar = 0 ; iHar < NbrHar ; iHar++){ HH[iTime][iHar] = (double *)Malloc(sizeof(double)*NbrHar) ; for (jHar = 0 ; jHar < NbrHar ; jHar++){ if (Val_Pulsation [iHar/2] && Val_Pulsation [jHar/2] ) HH[iTime][iHar][jHar] = 2. / (double)NbrPointsX * H[iTime][iHar] * H[iTime][jHar] ; else HH[iTime][iHar][jHar] = 1. / (double)NbrPointsX * H[iTime][iHar] * H[iTime][jHar] ; } } } } *H_P = MH_InitData_S.H = H; *t_P = MH_InitData_S.t = t; *w_P = MH_InitData_S.w = w; *HH_P = MH_InitData_S.HH = HH; *NbrPointsX_P = MH_InitData_S.NbrPointsX = NbrPointsX; List_Add (MH_InitData_L, &MH_InitData_S); } /* ------------------------------------------------------------------------ */ /* F_MHToTime0 (HarmonicToTime in PostOperation) */ /* ------------------------------------------------------------------------ */ void F_MHToTime0(int init, struct Value * A, struct Value * V, int iTime, int NbrPointsX, double * TimeMH) { static double **H, ***HH, *t, *weight; int iVal, nVal, iHar; if (Current.NbrHar == 1) return; if (!init) MH_Get_InitData(3, 0, &NbrPointsX, &H, &HH, &t, &weight); *TimeMH = t[iTime] ; V->Type = A->Type ; nVal = NbrValues_Type (A->Type) ; for (iVal = 0 ; iVal < nVal ; iVal++){ V->Val[iVal] = 0; for (iHar = 0 ; iHar < Current.NbrHar ; iHar++) V->Val[iVal] += H[iTime][iHar] * A->Val[iHar*MAX_DIM+iVal] ; } } /* ---------------------------------------------------------------------- */ /* F_MHToTime */ /* ---------------------------------------------------------------------- */ void F_MHToTime (struct Function * Fct, struct Value * A, struct Value * V) { int iHar, iVal, nVal ; double time, H[NBR_MAX_HARMONIC]; struct Value Vtemp; if (Current.NbrHar == 1) Message::Error("'F_MHToTime' only for Multi-Harmonic stuff") ; if((A+1)->Type != SCALAR) Message::Error("'F_MHToTime' requires second scalar argument (time)"); time = (A+1)->Val[0] ; for (iHar = 0 ; iHar < Current.NbrHar/2 ; iHar++) { /* if (Current.DofData->Val_Pulsation [iHar]){ */ H[2*iHar ] = cos(Current.DofData->Val_Pulsation[iHar] * time) ; H[2*iHar+1] = - sin(Current.DofData->Val_Pulsation[iHar] * time) ; /* } else { H[2*iHar ] = 0.5 ; H[2*iHar+1] = 0 ; } */ } nVal = NbrValues_Type (A->Type) ; for (iVal = 0 ; iVal < MAX_DIM ; iVal++) for (iHar = 0 ; iHar < Current.NbrHar ; iHar++) Vtemp.Val[iHar*MAX_DIM+iVal] = 0.; for (iVal = 0 ; iVal < nVal ; iVal++) for (iHar = 0 ; iHar < Current.NbrHar ; iHar++) Vtemp.Val[iVal] += H[iHar] * A->Val[iHar*MAX_DIM+iVal] ; V->Type = A->Type ; for (iVal = 0 ; iVal < MAX_DIM ; iVal++) for (iHar = 0 ; iHar < Current.NbrHar ; iHar++) V->Val[iHar*MAX_DIM+iVal] = Vtemp.Val[iHar*MAX_DIM+iVal] ; } /* ------------------------------------------------------------------------ */ /* MHTransform */ /* ------------------------------------------------------------------------ */ void MHTransform(struct Element * Element, struct QuantityStorage * QuantityStorage_P0, double u, double v, double w, struct Value *MH_Value, struct Expression * Expression_P, int NbrPoints) { double **H, ***HH, *t, *weight ; int NbrHar; struct Value t_Value, MH_Value_Tr; int NbrPointsX, iVal, nVal1, nVal2 = 0, iHar, iTime; MH_Get_InitData(1, NbrPoints, &NbrPointsX, &H, &HH, &t, &weight); nVal1 = NbrValues_Type (MH_Value->Type) ; t_Value.Type = MH_Value_Tr.Type = MH_Value->Type; NbrHar = Current.NbrHar; /* save NbrHar */ Current.NbrHar = 1; /* evaluation in time domain ! */ for (iVal = 0 ; iVal < MAX_DIM ; iVal++) for (iHar = 0 ; iHar < NbrHar ; iHar++) MH_Value_Tr.Val[iHar*MAX_DIM+iVal] = 0. ; for (iTime = 0 ; iTime < NbrPointsX ; iTime++) { for (iVal = 0 ; iVal < nVal1 ; iVal++){ /* evaluation of MH_Value at iTime-th time point */ t_Value.Val[iVal] = 0; for (iHar = 0 ; iHar < NbrHar ; iHar++) t_Value.Val[iVal] += H[iTime][iHar] * MH_Value->Val[iHar*MAX_DIM+iVal] ; } /* evaluation of the function */ Get_ValueOfExpression(Expression_P, QuantityStorage_P0, u, v, w, &t_Value); if (!iTime) nVal2 = NbrValues_Type (t_Value.Type) ; for (iVal = 0 ; iVal < nVal2 ; iVal++) for (iHar = 0 ; iHar < NbrHar ; iHar++) MH_Value_Tr.Val[iHar*MAX_DIM+iVal] += weight[iHar] * H[iTime][iHar] * t_Value.Val[iVal] ; /* weight[iTime] * H[iTime][iHar] * t_Value.Val[iVal] ; */ } /* for iTime */ for (iVal = 0 ; iVal < nVal2 ; iVal++) for (iHar = 0 ; iHar < NbrHar ; iHar++) MH_Value->Val[iHar*MAX_DIM+iVal] = MH_Value_Tr.Val[iHar*MAX_DIM+iVal] ; MH_Value->Type = t_Value.Type ; Current.NbrHar = NbrHar ; } /* ----------------------------------------------------------------------------------- */ /* C a l _ I n i t G a l e r k i n T e r m O f F e m E q u a t i o n _ M H J a c N L */ /* ----------------------------------------------------------------------------------- */ void Cal_InitGalerkinTermOfFemEquation_MHJacNL(struct EquationTerm * EquationTerm_P) { struct FemLocalTermActive * FI ; List_T * WholeQuantity_L; struct WholeQuantity *WholeQuantity_P0 ; int i_WQ ; FI = EquationTerm_P->Case.LocalTerm.Active ; FI->MHJacNL = 0 ; /* search for MHJacNL-term(s) */ WholeQuantity_L = EquationTerm_P->Case.LocalTerm.Term.WholeQuantity ; WholeQuantity_P0 = (struct WholeQuantity*)List_Pointer(WholeQuantity_L, 0) ; i_WQ = 0 ; while ( i_WQ < List_Nbr(WholeQuantity_L) && (WholeQuantity_P0 + i_WQ)->Type != WQ_MHJACNL) i_WQ++ ; if (i_WQ == List_Nbr(WholeQuantity_L) ) return; /* no MHJacNL stuff, let's get the hell out of here ! */ /* check if Galerkin term produces symmetrical contribution to system matrix */ if (!FI->SymmetricalMatrix) Message::Error("Galerkin term with MHJacNL must be symmetrical"); if (List_Nbr(WholeQuantity_L) == 3){ if (i_WQ != 0 || EquationTerm_P->Case.LocalTerm.Term.DofIndexInWholeQuantity != 1 || (WholeQuantity_P0 + 2)->Type != WQ_BINARYOPERATOR || (WholeQuantity_P0 + 2)->Case.Operator.TypeOperator != OP_TIME) Message::Error("Not allowed expression in Galerkin term with MHJacNL"); FI->MHJacNL_Factor = 1.; } else if (List_Nbr(WholeQuantity_L) == 5){ if ((WholeQuantity_P0 + 0)->Type != WQ_CONSTANT || i_WQ != 1 || (WholeQuantity_P0 + 2)->Type != WQ_BINARYOPERATOR || (WholeQuantity_P0 + 2)->Case.Operator.TypeOperator != OP_TIME || EquationTerm_P->Case.LocalTerm.Term.DofIndexInWholeQuantity != 3 || (WholeQuantity_P0 + 4)->Type != WQ_BINARYOPERATOR || (WholeQuantity_P0 + 4)->Case.Operator.TypeOperator != OP_TIME) Message::Error("Not allowed expression in Galerkin term with MHJacNL"); FI->MHJacNL_Factor = WholeQuantity_P0->Case.Constant ; /* printf(" Factor = %e \n" , FI->MHJacNL_Factor); */ } else { Message::Error("Not allowed expression in Galerkin term with MHJacNL (%d terms) ", List_Nbr(WholeQuantity_L)); } if(EquationTerm_P->Case.LocalTerm.Term.CanonicalWholeQuantity_Equ != CWQ_NONE) Message::Error("Not allowed expression in Galerkin term with MHJacNL"); if (EquationTerm_P->Case.LocalTerm.Term.TypeTimeDerivative != JACNL_) Message::Error("MHJacNL can only be used with JACNL") ; FI->MHJacNL = 1 ; FI->MHJacNL_Index = (WholeQuantity_P0 + i_WQ)->Case.MHJacNL.Index ; FI->MHJacNL_HarOffSet = 2 * (WholeQuantity_P0 + i_WQ)->Case.MHJacNL.FreqOffSet ; if (FI->MHJacNL_HarOffSet > Current.NbrHar-2){ Message::Warning("FreqOffSet in 'MHJacNL' cannot exceed %d => set to %d ", Current.NbrHar/2-1, Current.NbrHar/2-1) ; FI->MHJacNL_HarOffSet = Current.NbrHar-2 ; } MH_Get_InitData(2, (WholeQuantity_P0 + i_WQ)->Case.MHJacNL.NbrPoints, &FI->MHJacNL_NbrPointsX, &FI->MHJacNL_H, &FI->MHJacNL_HH, &FI->MHJacNL_t, &FI->MHJacNL_w) ; } #define OFFSET (iHar < NbrHar-OffSet)? 0 : iHar-NbrHar+OffSet+2-iHar%2 /* --------------------------------------------------------------------------- */ /* C a l _ G a l e r k i n T e r m O f F e m E q u a t i o n _ M H J a c N L */ /* --------------------------------------------------------------------------- */ void Cal_GalerkinTermOfFemEquation_MHJacNL(struct Element * Element, struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0) { struct FemLocalTermActive * FI ; struct QuantityStorage * QuantityStorage_P; struct IntegrationCase * IntegrationCase_P ; struct Quadrature * Quadrature_P ; int Nbr_Dof, NbrHar ; double vBFuDof [NBR_MAX_BASISFUNCTIONS][MAX_DIM] ; double vBFxDof [NBR_MAX_BASISFUNCTIONS][MAX_DIM] ; double Val_Dof [NBR_MAX_BASISFUNCTIONS][NBR_MAX_HARMONIC] ; double Val [3*NBR_MAX_BASISFUNCTIONS]; int i, j, k, Type_Dimension, Nbr_IntPoints, i_IntPoint ; int iTime, iDof, jDof, iHar, jHar, nVal1, nVal2 = 0, iVal1, iVal2, Type1; double **H, ***HH, Factor, plus, plus0, weightIntPoint; int NbrPointsX, OffSet; struct Expression * Expression_P; struct Dof * Dofi, *Dofj; struct Value t_Value; gMatrix * Jac; double one=1.0 ; int iPul, ZeroHarmonic, DcHarmonic; double E_MH[NBR_MAX_BASISFUNCTIONS][NBR_MAX_BASISFUNCTIONS][NBR_MAX_HARMONIC][NBR_MAX_HARMONIC]; double E_D[NBR_MAX_HARMONIC][NBR_MAX_HARMONIC][MAX_DIM]; void (*xFunctionBFDof[NBR_MAX_BASISFUNCTIONS]) (struct Element * Element, int NumEntity, double u, double v, double w, double Value[] ) ; double (*Get_Jacobian)(struct Element*, MATRIX3x3*) ; void (*Get_IntPoint)(int,int,double*,double*,double*,double*); double (*Get_Product)(double*,double*,double*) = 0; /* static double eps; */ FI = EquationTerm_P->Case.LocalTerm.Active ; QuantityStorage_P = FI->QuantityStorageDof_P ; /* ---------------------------------------------------------------------- */ /* G e t F u n c t i o n V a l u e f o r t e s t f u n c t i o n s */ /* ---------------------------------------------------------------------- */ if (!(Nbr_Dof = QuantityStorage_P->NbrElementaryBasisFunction)) return; Get_FunctionValue(Nbr_Dof, (void (**)())xFunctionBFDof, EquationTerm_P->Case.LocalTerm.Term.TypeOperatorDof, QuantityStorage_P, &FI->Type_FormDof) ; for (j = 0 ; j < Nbr_Dof ; j++) for (k = 0 ; k < Current.NbrHar ; k+=2) Dof_GetComplexDofValue (QuantityStorage_P->FunctionSpace->DofData, QuantityStorage_P->BasisFunction[j].Dof + k/2*gCOMPLEX_INCREMENT, &Val_Dof[j][k], &Val_Dof[j][k+1]) ; /* printf("Type1 = %d\n", FI->Type_FormDof); */ nVal1 = NbrValues_Type (Type1 = Get_ValueFromForm(FI->Type_FormDof)) ; /* ------------------------------------------------------------------- */ /* G e t J a c o b i a n M e t h o d */ /* ------------------------------------------------------------------- */ i = 0 ; while ((i < FI->NbrJacobianCase) && ((j = (FI->JacobianCase_P0 + i)->RegionIndex) >= 0) && !List_Search (((struct Group *)List_Pointer(Problem_S.Group, j)) ->InitialList, &Element->Region, fcmp_int) ) i++ ; if (i == FI->NbrJacobianCase) Message::Error("Undefined Jacobian in Region %d", Element->Region); Element->JacobianCase = FI->JacobianCase_P0 + i ; Get_Jacobian = (double (*)(struct Element*, MATRIX3x3*)) Get_JacobianFunction(Element->JacobianCase->TypeJacobian, Element->Type, &Type_Dimension) ; if (FI->Flag_ChangeCoord) Get_NodesCoordinatesOfElement(Element) ; /* integration in space */ IntegrationCase_P = Get_IntegrationCase(Element, FI->IntegrationCase_L, FI->CriterionIndex); switch (IntegrationCase_P->Type) { case ANALYTIC : Message::Error("Analytical integration not implemented for MHJacNL"); } Quadrature_P = (struct Quadrature*) List_PQuery(IntegrationCase_P->Case, &Element->Type, fcmp_int); if(!Quadrature_P) Message::Error("Unknown type of Element (%s) for Integration method (%s)", Get_StringForDefine(Element_Type, Element->Type), ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, EquationTerm_P->Case.LocalTerm.IntegrationMethodIndex))->Name); Nbr_IntPoints = Quadrature_P->NumberOfPoints ; Get_IntPoint = (void(*)(int,int,double*,double*,double*,double*)) Quadrature_P->Function ; /* integration in fundamental time period */ NbrPointsX = FI->MHJacNL_NbrPointsX; HH = FI->MHJacNL_HH; H = FI->MHJacNL_H ; Expression_P = (struct Expression*)List_Pointer(Problem_S.Expression, FI->MHJacNL_Index); OffSet = FI->MHJacNL_HarOffSet; Factor = FI->MHJacNL_Factor; /* ------------------------------------------------------------------------ */ /* ------------------------------------------------------------------------ */ /* C o m p u t a t i o n o f E l e m e n t a r y m a t r i x */ /* ------------------------------------------------------------------------ */ /* ------------------------------------------------------------------------ */ NbrHar = Current.NbrHar ; /* special treatment of DC-term and associated dummy sinus-term */ DcHarmonic = NbrHar; ZeroHarmonic = 0; for (iPul = 0 ; iPul < NbrHar/2 ; iPul++) if (!Current.DofData->Val_Pulsation[iPul]){ DcHarmonic = 2*iPul ; ZeroHarmonic = 2*iPul+1 ; break; } /* resetting elementary matrix */ for (iDof = 0 ; iDof < Nbr_Dof ; iDof++) for (jDof = 0 ; jDof <= iDof ; jDof++) for (iHar = 0 ; iHar < NbrHar ; iHar++) for (jHar = OFFSET ; jHar <= iHar ; jHar++) E_MH[iDof][jDof][iHar][jHar] = 0. ; /* volume integration over element */ for (i_IntPoint = 0 ; i_IntPoint < Nbr_IntPoints ; i_IntPoint++) { Get_IntPoint(Nbr_IntPoints, i_IntPoint, &Current.u, &Current.v, &Current.w, &weightIntPoint) ; if (FI->Flag_ChangeCoord) { Get_BFGeoElement(Element, Current.u, Current.v, Current.w) ; Element->DetJac = Get_Jacobian(Element, &Element->Jac) ; weightIntPoint *= fabs(Element->DetJac) ; if (FI->Flag_InvJac) Get_InverseMatrix(Type_Dimension, Element->Type, Element->DetJac, &Element->Jac, &Element->InvJac) ; } /* Test and shape Functions (are the same) */ for (i = 0 ; i < Nbr_Dof ; i++) { xFunctionBFDof[i] (Element, QuantityStorage_P->BasisFunction[i].NumEntityInElement+1, Current.u, Current.v, Current.w, vBFuDof[i]) ; ((void (*)(struct Element*, double*, double*)) FI->xChangeOfCoordinatesEqu) (Element, vBFuDof[i], vBFxDof[i]) ; } switch (Type1) { case SCALAR : for (k = 0 ; k < NbrHar ; k++){ Val[k] = 0.; for (j = 0 ; j < Nbr_Dof ; j++) Val[k] += vBFxDof[j][0] * Val_Dof[j][k] ; } break ; case VECTOR : for (k = 0 ; k < NbrHar ; k++){ Val[3*k] = Val[3*k+1] = Val[3*k+2] = 0.; for (j = 0 ; j < Nbr_Dof ; j++){ Val[3*k ] += vBFxDof[j][0] * Val_Dof[j][k] ; Val[3*k+1] += vBFxDof[j][1] * Val_Dof[j][k] ; Val[3*k+2] += vBFxDof[j][2] * Val_Dof[j][k] ; } } break ; } Current.NbrHar = 1; /* evaluation in time domain */ /* time integration over fundamental period */ for (iTime = 0 ; iTime < NbrPointsX ; iTime++) { t_Value.Type = Type1 ; for (iVal1 = 0 ; iVal1 < nVal1 ; iVal1++){ t_Value.Val[iVal1] = 0; for (iHar = 0 ; iHar < NbrHar ; iHar++) t_Value.Val[iVal1] += H[iTime][iHar] * Val[iHar*nVal1+iVal1] ; } Get_ValueOfExpression(Expression_P, QuantityStorage_P0, Current.u, Current.v, Current.w, &t_Value); if (!iTime){ if (!i_IntPoint){ nVal2 = NbrValues_Type (t_Value.Type) ; Get_Product = (double(*)(double*,double*,double*)) Get_RealProductFunction_Type1xType2xType1 (Type1, t_Value.Type) ; } for (iHar = 0 ; iHar < NbrHar ; iHar++) for (jHar = OFFSET ; jHar <= iHar ; jHar++) for (iVal2 = 0 ; iVal2 < nVal2 ; iVal2++) E_D[iHar][jHar][iVal2] = 0. ; } for (iHar = 0 ; iHar < NbrHar ; iHar++) for (jHar = OFFSET ; jHar <= iHar ; jHar++){ for (iVal2 = 0 ; iVal2 < nVal2 ; iVal2++) E_D[iHar][jHar][iVal2] += HH[iTime][iHar][jHar] * t_Value.Val[iVal2] ; } } /* for iTime ... */ /* if (!eps) { printf("enter value for eps\n"); scanf("%lf",&eps); printf("eps = %f\n",eps); } for (iHar = 0 ; iHar < NbrHar ; iHar++) for (jHar = OFFSET ; jHar <= iHar ; jHar++){ for (iVal2 = 0 ; iVal2 < nVal2 ; iVal2++) if ( E_D[iHar][jHar][iVal2] * E_D[iHar][jHar][iVal2] < eps * eps * fabs(E_D[iHar][iHar][iVal2] * E_D[jHar][jHar][iVal2]) ) E_D[iHar][jHar][iVal2]=0 ; } */ for (iDof = 0 ; iDof < Nbr_Dof ; iDof++) for (jDof = 0 ; jDof <= iDof ; jDof++) for (iHar = 0 ; iHar < NbrHar ; iHar++) for (jHar = OFFSET ; jHar <= iHar ; jHar++){ E_MH[iDof][jDof][iHar][jHar] += weightIntPoint * Get_Product(vBFxDof[iDof], E_D[iHar][jHar], vBFxDof[jDof]) ; /* printf("%d %d %d %d %e\n", iDof, jDof, iHar, jHar, E_MH[iDof][jDof][iHar][jHar]) ; */ } Current.NbrHar = NbrHar ; } /* for i_IntPoint ... */ /* -------------------------------------------------------------------- */ /* A d d c o n t r i b u t i o n t o J a c o b i a n M a t r i x */ /* -------------------------------------------------------------------- */ Jac = &Current.DofData->Jac; for (iDof = 0 ; iDof < Nbr_Dof ; iDof++){ Dofi = QuantityStorage_P->BasisFunction[iDof].Dof ; for (jDof = 0 ; jDof <= iDof ; jDof++){ Dofj = QuantityStorage_P->BasisFunction[jDof].Dof ; for (iHar = 0 ; iHar < NbrHar ; iHar++) for (jHar = OFFSET ; jHar <= iHar ; jHar++){ plus = plus0 = Factor * E_MH [iDof][jDof] [iHar][jHar] ; if(jHar==DcHarmonic && iHar!=DcHarmonic) { plus0 *= 1. ; plus *= 2. ;} Dof_AssembleInMat(Dofi+iHar, Dofj+jHar, 1, &plus, Jac, NULL) ; if(iHar != jHar) Dof_AssembleInMat(Dofi+jHar, Dofj+iHar, 1, &plus0, Jac, NULL) ; if(iDof != jDof){ Dof_AssembleInMat(Dofj+iHar, Dofi+jHar, 1, &plus, Jac, NULL) ; if(iHar != jHar) Dof_AssembleInMat(Dofj+jHar, Dofi+iHar, 1, &plus0, Jac, NULL) ; } } } } /* dummy 1's on the diagonal for sinus-term of dc-component */ if (ZeroHarmonic) { for (iDof = 0 ; iDof < Nbr_Dof ; iDof++){ Dofi = QuantityStorage_P->BasisFunction[iDof].Dof + ZeroHarmonic ; Dof_AssembleInMat(Dofi, Dofi, 1, &one, Jac, NULL) ; } } } #undef OFFSET getdp-2.4.2-source/Legacy/F_Gmsh.cpp000644 001750 001750 00000013243 12140252171 020651 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "GetDPConfig.h" #include "ProData.h" #include "F.h" #include "Message.h" extern struct CurrentData Current ; #if defined(HAVE_GMSH) #include #include #include void F_Field(F_ARG) { if(A->Type != VECTOR){ Message::Error("Field[] expects XYZ coordinates as argument"); return; } if(PView::list.empty()){ Message::Error("No views available to interpolate from"); return; } double x = A->Val[0]; double y = A->Val[1]; double z = A->Val[2]; for (int k = 0; k < Current.NbrHar; k++) for (int j = 0; j < 9; j++) V->Val[MAX_DIM * k + j] = 0. ; V->Type = SCALAR; std::vector iview; if(!Fct->NbrParameters){ // use last view by default iview.push_back(PView::list.back()->getTag()); } else{ for(int i = 0; i < Fct->NbrParameters; i++) iview.push_back(Fct->Para[i]); } // add the values from all specified views for(unsigned int i = 0; i < iview.size(); i++){ PView *v = PView::getViewByTag(iview[i]); if(!v){ Message::Error("View with tag %d does not exist", iview[i]); return; } PViewData *data = v->getData(); std::vector val(9 * data->getNumTimeSteps()); if(data->searchScalar(x, y, z, &val[0])){ V->Val[0] += val[0]; if(Current.NbrHar == 2 && data->getNumTimeSteps() > 1) V->Val[MAX_DIM] += val[1]; V->Type = SCALAR; } else if(data->searchVector(x, y, z, &val[0])){ for(int j = 0; j < 3; j++) V->Val[j] += val[j]; if(Current.NbrHar == 2 && data->getNumTimeSteps() > 1){ for(int j = 0; j < 3; j++) V->Val[MAX_DIM + j] += val[3 + j]; } V->Type = VECTOR; } else if(data->searchTensor(x, y, z, &val[0])){ for(int j = 0; j < 9; j++) V->Val[j] += val[j]; if(Current.NbrHar == 2 && data->getNumTimeSteps() > 1){ for(int j = 0; j < 9; j++) V->Val[MAX_DIM + j] += val[9 + j]; } V->Type = TENSOR; } else{ Message::Error("Did not find data at point (%g,%g,%g) in View with tag %d", x, y, z, iview[i]); } } } static void F_X_Field(F_ARG, int type, bool complex) { if(A->Type != VECTOR){ Message::Error("Field[] expects XYZ coordinates as argument"); return; } if(PView::list.empty()){ Message::Error("No views available to interpolate from"); return; } double x = A->Val[0]; double y = A->Val[1]; double z = A->Val[2]; int numComp = (type == SCALAR) ? 1 : (type == VECTOR) ? 3 : 9; int NbrArg = Fct->NbrArguments ; int TimeStep = 0; if(NbrArg == 2){ if((A+1)->Type != SCALAR){ Message::Error("Expected scalar second argument"); return; } TimeStep = (int)(A+1)->Val[0]; } // Complex{Scalar,Vector,Tensor}Field assume that the Gmsh view contains real // and imaginary parts for each step if(complex) TimeStep *= 2; for (int k = 0; k < Current.NbrHar; k++) for (int j = 0; j < numComp; j++) V->Val[MAX_DIM * k + j] = 0. ; V->Type = type; std::vector iview; if(!Fct->NbrParameters){ // use last view by default iview.push_back(PView::list.back()->getTag()); } else{ for(int i = 0; i < Fct->NbrParameters; i++) iview.push_back(Fct->Para[i]); } // add the values from all specified views for(unsigned int i = 0; i < iview.size(); i++){ PView *v = PView::getViewByTag(iview[i]); if(!v){ Message::Error("View with tag %d does not exist", iview[i]); return; } PViewData *data = v->getData(); if(TimeStep < 0 || TimeStep >= data->getNumTimeSteps()){ Message::Error("Invalid step %d in View with tag %d", TimeStep, iview[i]); continue; } std::vector val(numComp * data->getNumTimeSteps()); switch(type){ case SCALAR : if(data->searchScalar(x, y, z, &val[0])){ V->Val[0] += val[TimeStep]; if(complex && Current.NbrHar == 2 && data->getNumTimeSteps() > TimeStep + 1) V->Val[MAX_DIM] += val[TimeStep + 1]; } break; case VECTOR : if(data->searchVector(x, y, z, &val[0])){ for(int j = 0; j < 3; j++) V->Val[j] += val[3 * TimeStep + j]; if(complex && Current.NbrHar == 2 && data->getNumTimeSteps() > TimeStep + 1){ for(int j = 0; j < 3; j++) V->Val[MAX_DIM + j] += val[3 * (TimeStep + 1) + j]; } } break; case TENSOR : if(data->searchTensor(x, y, z, &val[0])){ for(int j = 0; j < 9; j++) V->Val[j] += val[9 * TimeStep + j]; if(complex && Current.NbrHar == 2 && data->getNumTimeSteps() > TimeStep + 1){ for(int j = 0; j < 9; j++) V->Val[MAX_DIM + j] += val[9 * (TimeStep + 1) + j]; } } break; } } } #else void F_Field(F_ARG) { Message::Error("You need to compile GetDP with Gmsh support to use 'Field'"); V->Val[0] = 0. ; V->Type = SCALAR ; } static void F_X_Field(F_ARG, int type, bool complex) { Message::Error("You need to compile GetDP with Gmsh support to use 'Field'"); V->Val[0] = 0. ; V->Type = SCALAR ; } #endif void F_ScalarField(F_ARG){ F_X_Field(Fct, A, V, SCALAR, false); } void F_VectorField(F_ARG){ F_X_Field(Fct, A, V, VECTOR, false); } void F_TensorField(F_ARG){ F_X_Field(Fct, A, V, TENSOR, false); } void F_ComplexScalarField(F_ARG){ F_X_Field(Fct, A, V, SCALAR, true); } void F_ComplexVectorField(F_ARG){ F_X_Field(Fct, A, V, VECTOR, true); } void F_ComplexTensorField(F_ARG){ F_X_Field(Fct, A, V, TENSOR, true); } getdp-2.4.2-source/Legacy/Get_ConstraintOfElement.cpp000644 001750 001750 00000131446 12166744450 024254 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "ProData.h" #include "GeoData.h" #include "Get_DofOfElement.h" #include "Get_ConstraintOfElement.h" #include "ExtendedGroup.h" #include "Cal_Quantity.h" #include "Cal_Value.h" #include "MallocUtils.h" #include "Message.h" extern struct Problem Problem_S ; extern struct CurrentData Current ; extern List_T *PreResolutionIndex_L ; extern int Nbr_ElementaryBF ; /* ------------------------------------------------------------------------ */ /* T r e a t m e n t _ C o n s t r a i n t F o r E l e m e n t */ /* ------------------------------------------------------------------------ */ void Treatment_ConstraintForElement(struct FunctionSpace * FunctionSpace_P, struct QuantityStorage * QuantityStorage_P, int Num_Entity[], int i_Entity, int i_BFunction, int TypeConstraint) { int Nbr_Constraint, i_Constraint, k, Index_GeoElement ; List_T * Constraint_L ; struct ConstraintInFS * Constraint_P ; struct ConstraintPerRegion * ConstraintPerRegion_P ; struct GlobalQuantity * GlobalQuantity_P ; struct Group * GroupEntity_Pr ; QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Constraint = NONE ; QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Constraint_Index = -1; Constraint_L = FunctionSpace_P->Constraint ; Nbr_Constraint = List_Nbr(Constraint_L) ; for (i_Constraint = 0 ; i_Constraint < Nbr_Constraint && ! QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Constraint ; i_Constraint++) { Constraint_P = (struct ConstraintInFS*)List_Pointer(Constraint_L, i_Constraint) ; ConstraintPerRegion_P = Constraint_P->ConstraintPerRegion ; switch(ConstraintPerRegion_P->Type) { case ASSIGN : case INIT : case ASSIGNFROMRESOLUTION : case INITFROMRESOLUTION : case CST_LINK : case CST_LINKCPLX : switch(Constraint_P->QuantityType) { case LOCALQUANTITY : if(Constraint_P->ReferenceIndex == i_BFunction) { GroupEntity_Pr = (struct Group*) List_Pointer(Problem_S.Group, Constraint_P->EntityIndex) ; if(Check_IsEntityInExtendedGroup(GroupEntity_Pr, abs(Num_Entity[i_Entity]), 1)) { QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Constraint = ConstraintPerRegion_P->Type ; QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Constraint_Index = i_Constraint; if (ConstraintPerRegion_P->Type == ASSIGN || ConstraintPerRegion_P->Type == INIT) { switch (TypeConstraint) { case NODESOF : case GROUPSOFEDGESONNODESOF : Current.NumEntity = abs(Num_Entity[i_Entity]) ; // Note: Current.Element will be set to 0 in Get_ValueForConstraint // so that Current.{x,y,z} will be used in CoordXYZ[] functions Geo_GetNodesCoordinates(1, &Current.NumEntity, &Current.x, &Current.y, &Current.z) ; break ; case EDGESOF : Current.NumEntity = abs(Num_Entity[i_Entity]) ; Current.NumEntityInElement = i_Entity ; break ; } Get_ValueForConstraint (Constraint_P, QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Value, QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Value2, &QuantityStorage_P->BasisFunction[Nbr_ElementaryBF]. TimeFunctionIndex) ; } else if (ConstraintPerRegion_P->Type == ASSIGN_LOCALPROJ || ConstraintPerRegion_P->Type == INIT_LOCALPROJ) { // nothing to do now (per entity): we will do the projection // later, per element } else if (ConstraintPerRegion_P->Type == CST_LINK || ConstraintPerRegion_P->Type == CST_LINKCPLX) { Get_LinkForConstraint (Constraint_P, abs(Num_Entity[i_Entity]), &QuantityStorage_P->BasisFunction[Nbr_ElementaryBF]. CodeEntity_Link, QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].BasisFunction->Orient, QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Value) ; if (abs(Num_Entity[i_Entity]) == QuantityStorage_P->BasisFunction[Nbr_ElementaryBF]. CodeEntity_Link) QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Constraint = NONE ; // Code linked with itself not allowed } else { Get_PreResolutionForConstraint (Constraint_P, &QuantityStorage_P->BasisFunction[Nbr_ElementaryBF]. TimeFunctionIndex) ; } } } break ; /* LOCALQUANTITY */ case GLOBALQUANTITY : GlobalQuantity_P = (struct GlobalQuantity*) List_Pointer(FunctionSpace_P->GlobalQuantity, Constraint_P->ReferenceIndex) ; if ((GlobalQuantity_P->Type == ALIASOF) && (GlobalQuantity_P->ReferenceIndex == i_BFunction)) { GroupEntity_Pr = (struct Group*) List_Pointer(Problem_S.Group, Constraint_P->EntityIndex) ; if (List_Search(GroupEntity_Pr->InitialList, &Num_Entity[i_Entity], fcmp_int)) { QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Constraint = ConstraintPerRegion_P->Type ; if (ConstraintPerRegion_P->Type == ASSIGN || ConstraintPerRegion_P->Type == INIT) { Get_ValueForConstraint (Constraint_P, QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Value, QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Value2, &QuantityStorage_P->BasisFunction[Nbr_ElementaryBF]. TimeFunctionIndex) ; } else if (ConstraintPerRegion_P->Type == CST_LINK || ConstraintPerRegion_P->Type == CST_LINKCPLX) { // Message::Error("CST_LINK for GlobalQuantity not done yet") ; // FIXME: to be validated Get_LinkForConstraint (Constraint_P, abs(Num_Entity[i_Entity]), &QuantityStorage_P->BasisFunction[Nbr_ElementaryBF]. CodeEntity_Link, QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].BasisFunction->Orient, QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Value) ; if (abs(Num_Entity[i_Entity]) == QuantityStorage_P->BasisFunction[Nbr_ElementaryBF]. CodeEntity_Link) QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Constraint = NONE ; } else { Get_PreResolutionForConstraint (Constraint_P, &QuantityStorage_P->BasisFunction[Nbr_ElementaryBF]. TimeFunctionIndex) ; } } } break ; /* GLOBALQUANTITY */ default : Message::Error("Unknown type of Quantity in Constraint of type Fixed"); break; } break ; /* ASSIGN || INIT || ASSIGN_LOCALPROJ || INIT_LOCALPROJ || ASSIGNFROMRESOLUTION || INITFROMRESOLUTION */ default : Message::Error("Unknown type of Constraint"); break; } } /* for i_Constraint ... */ /* Constraints due to P-refinement */ if(Current.GeoData->P) { Index_GeoElement = Geo_GetGeoElementIndex(Current.Element->GeoElement) ; if (Current.GeoData->P[Index_GeoElement+1] >= 0 && Current.GeoData->P[Index_GeoElement+1] < QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].BasisFunction->Order){ QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Constraint = ASSIGN ; for (k = 0 ; k < Current.NbrHar ; k++) QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Value[k] = 0. ; QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].TimeFunctionIndex = -1 ; } } } /* ------------------------------------------------------------------------ */ /* G e t _ V a l u e F o r C o n s t r a i n t */ /* ------------------------------------------------------------------------ */ void Get_ValueForConstraint(struct ConstraintInFS * Constraint_P, double Value[], double Value2[], int * Index_TimeFunction) { int k ; struct Value Val_Modulus, Val_Modulus2, Val_TimeFunction ; // Note: Current.{u,v,w} is not defined, so we cannot interpolate expressions // in the reference element. We thus set Current.Element=0 and rely on // Current.{x,y,z}. struct Element *old = Current.Element; Current.Element = 0; Get_ValueOfExpression ((struct Expression *) List_Pointer(Problem_S.Expression, Constraint_P->ConstraintPerRegion->Case.Fixed.ExpressionIndex), NULL, 0., 0., 0., &Val_Modulus) ; int idx2 = Constraint_P->ConstraintPerRegion->Case.Fixed.ExpressionIndex2; if(idx2 >= 0){ Get_ValueOfExpression ((struct Expression *) List_Pointer(Problem_S.Expression, idx2), NULL, 0., 0., 0., &Val_Modulus2) ; } else{ Cal_ZeroValue(&Val_Modulus2); } *Index_TimeFunction = Constraint_P->ConstraintPerRegion->TimeFunctionIndex ; if (Current.NbrHar > 1) { if (*Index_TimeFunction >= 0) { Get_ValueOfExpression ((struct Expression *) List_Pointer(Problem_S.Expression, Constraint_P->ConstraintPerRegion->TimeFunctionIndex), NULL, 0., 0., 0., &Val_TimeFunction) ; Cal_ProductValue(&Val_Modulus, &Val_TimeFunction, &Val_Modulus) ; } for (k = 0 ; k < Current.NbrHar ; k++){ Value[k] = Val_Modulus.Val[MAX_DIM*k] ; Value2[k] = Val_Modulus2.Val[MAX_DIM*k] ; } } else{ Value[0] = Val_Modulus.Val[0] ; Value2[0] = Val_Modulus2.Val[0] ; // Set this to zero to avoid having an uninitialized imaginary part if you // use a complex arithmetic solver (on a real matrix) -- // cf. LinAlg_SetScalar() calls in DofData.cpp Value[1] = 0. ; Value2[1] = 0. ; } Current.Element = old; } /* ------------------------------------------------------------------------ */ /* T r e a t m e n t _ C o n s t r a i n t F o r R e g i o n */ /* ------------------------------------------------------------------------ */ void Treatment_ConstraintForRegion(struct GlobalQuantity * GlobalQuantity_P, struct FunctionSpace * FunctionSpace_P, struct QuantityStorage * QuantityStorage_P) { int Nbr_Constraint, i_Constraint ; List_T * Constraint_L ; struct ConstraintInFS * Constraint_P ; struct ConstraintPerRegion * ConstraintPerRegion_P ; struct Group * GroupEntity_Pr ; struct GlobalQuantity * GlobalQuantity_Pr ; QuantityStorage_P->BasisFunction[0].Constraint = NONE ; Constraint_L = FunctionSpace_P->Constraint ; Nbr_Constraint = List_Nbr(Constraint_L) ; for (i_Constraint = 0 ; i_Constraint < Nbr_Constraint && ! QuantityStorage_P->BasisFunction[0].Constraint ; i_Constraint++) { Constraint_P = (struct ConstraintInFS*)List_Pointer(Constraint_L, i_Constraint) ; ConstraintPerRegion_P = Constraint_P->ConstraintPerRegion ; if (Constraint_P->QuantityType == GLOBALQUANTITY) { switch(ConstraintPerRegion_P->Type) { case ASSIGN : case INIT : case ASSIGNFROMRESOLUTION : case INITFROMRESOLUTION : case CST_LINK : case CST_LINKCPLX : GlobalQuantity_Pr = (struct GlobalQuantity*) List_Pointer(FunctionSpace_P->GlobalQuantity, Constraint_P->ReferenceIndex) ; if (GlobalQuantity_Pr == GlobalQuantity_P) { GroupEntity_Pr = (struct Group*) List_Pointer(Problem_S.Group, Constraint_P->EntityIndex) ; if (/*(GroupEntity_Pr->FunctionType == ((struct Group *)List_Pointer(Problem_S.Group, BasisFunction_P->EntityIndex)) ->FunctionType) && */ List_Search (GroupEntity_Pr->InitialList, &QuantityStorage_P->BasisFunction[0].CodeEntity, fcmp_int) ) { QuantityStorage_P->BasisFunction[0].Constraint = ConstraintPerRegion_P->Type ; if (ConstraintPerRegion_P->Type == ASSIGN || ConstraintPerRegion_P->Type == INIT) Get_ValueForConstraint (Constraint_P, QuantityStorage_P->BasisFunction[0].Value, QuantityStorage_P->BasisFunction[0].Value2, &QuantityStorage_P->BasisFunction[0].TimeFunctionIndex) ; else if (ConstraintPerRegion_P->Type == CST_LINK || ConstraintPerRegion_P->Type == CST_LINKCPLX) { Get_LinkForConstraint (Constraint_P, QuantityStorage_P->BasisFunction[0].CodeEntity, &QuantityStorage_P->BasisFunction[0].CodeEntity_Link, QuantityStorage_P->BasisFunction[0].BasisFunction->Orient, QuantityStorage_P->BasisFunction[0].Value) ; if (QuantityStorage_P->BasisFunction[0].CodeEntity == QuantityStorage_P->BasisFunction[0].CodeEntity_Link) QuantityStorage_P->BasisFunction[0].Constraint = NONE ; /* Code linked with itself not allowed */ } else Get_PreResolutionForConstraint (Constraint_P, &QuantityStorage_P->BasisFunction[0].TimeFunctionIndex) ; } } break ; /* ASSIGN || INIT || ASSIGNFROMRESOLUTION || INITFROMRESOLUTION */ default : Message::Error("Unknown type of Constraint"); break; } } /* if (GLOBALQUANTITY) ... */ } /* for i_Constraint ... */ } /* ------------------------------------------------------------------------ */ /* G e t _ P r e R e s o l u t i o n F o r C o n s t r a i n t */ /* ------------------------------------------------------------------------ */ void Get_PreResolutionForConstraint(struct ConstraintInFS * Constraint_P, int * Index_TimeFunction) { struct PreResolutionInfo PreResolutionInfo_S ; int fcmp_Resolution_Name(const void * a, const void * b) ; *Index_TimeFunction = Constraint_P->ConstraintPerRegion->TimeFunctionIndex ; if (Constraint_P->Active.ResolutionIndex < 0) if ((Constraint_P->Active.ResolutionIndex = List_ISearchSeq(Problem_S.Resolution, Constraint_P->ConstraintPerRegion-> Case.Solve.ResolutionName, fcmp_Resolution_Name)) < 0) { Message::Error("Unknown ResolutionName '%s' in Constraint", Constraint_P->ConstraintPerRegion->Case.Solve.ResolutionName) ; } if(List_ISearchSeq(PreResolutionIndex_L, &Constraint_P->Active.ResolutionIndex, fcmp_int) < 0) { PreResolutionInfo_S.Index = Constraint_P->Active.ResolutionIndex ; PreResolutionInfo_S.Type = PR_CONSTRAINT ; List_Add(PreResolutionIndex_L, &PreResolutionInfo_S) ; Message::Info(" Adding Resolution '%s' for Pre-Resolution (Constraint)", Constraint_P->ConstraintPerRegion->Case.Solve.ResolutionName) ; } } /* ------------------------------------------------------------------------ */ /* ------------------------------------------------------------------------ */ /* G e t _ L i n k F o r C o n s t r a i n t & C o */ /* ------------------------------------------------------------------------ */ struct TwoIntOneDouble { int Int1, Int2 ; double Double, Double2 ; } ; void Get_LinkForConstraint(struct ConstraintInFS * Constraint_P, int Num_Entity, int * CodeEntity_Link, int Orient, double Value[]) { // Note: Current.{u,v,w} is not defined, so we cannot interpolate expressions // in the reference element. We thus set Current.Element=0 and rely on // Current.{x,y,z}. struct Element *old = Current.Element; Current.Element = 0; struct TwoIntOneDouble * TwoIntOneDouble_P ; List_T * Couples_L ; void Generate_Link(struct ConstraintInFS * Constraint_P, int Flag_New) ; if (!Constraint_P->Active.Active) Generate_Link(Constraint_P, 1) ; else if (Constraint_P->Active.Active->TimeStep != (int)Current.TimeStep) Generate_Link(Constraint_P, 0) ; else if (Constraint_P->Active.Active->SubTimeStep != Current.SubTimeStep) Generate_Link(Constraint_P, 0) ; /* +++ */ TwoIntOneDouble_P = (struct TwoIntOneDouble *) ((Couples_L = Constraint_P->Active.Active->Case.Link.Couples)? List_PQuery(Couples_L, &Num_Entity, fcmp_absint) : NULL) ; if (TwoIntOneDouble_P) { *CodeEntity_Link = abs(TwoIntOneDouble_P->Int2) ; Value[0] = TwoIntOneDouble_P->Double ; if (Orient && TwoIntOneDouble_P->Int1 < 0) Value[0] *= -1. ; Value[1] = TwoIntOneDouble_P->Double2 ; /* LinkCplx */ if (Orient && TwoIntOneDouble_P->Int1 < 0) Value[1] *= -1. ; } Current.Element = old; } /* Data... */ struct NodeXYZ { int NumNode ; double x, y, z ; } ; struct EdgeNN { int NumEdge ; int Node1, Node2 ; double Coef, Coef2 ; } ; struct FacetNNN { int NumFacet ; int Node1, Node2, Node3 ; double Coef, Coef2 ; } ; void Generate_LinkNodes(struct ConstraintInFS * Constraint_P, List_T * ExtendedList_L, List_T * ExtendedSuppList_L, struct Group * RegionRef_P, struct Group * SubRegionRef_P, int Index_Filter, int Index_Function, int Index_Coef, List_T * Couples_L) ; void Generate_LinkEdges(struct ConstraintInFS * Constraint_P, struct Group * Group_P, struct Group * RegionRef_P, struct Group * SubRegionRef_P, List_T * Couples_L) ; void Generate_LinkFacets(struct ConstraintInFS * Constraint_P, struct Group * Group_P, struct Group * RegionRef_P, struct Group * SubRegionRef_P, List_T * Couples_L) ; int fcmp_XYZ(const void * a, const void * b) ; int fcmp_NN(const void * a, const void * b) ; int fcmp_NNN(const void * a, const void * b) ; void Generate_LinkRegions(struct ConstraintInFS * Constraint_P, List_T * Region_L, List_T * RegionRef_L, int Index_Coef, List_T * Couples_L) ; void Generate_ElementaryEntities_EdgeNN (List_T * InitialList, List_T ** ExtendedList, int Type_Entity) ; void Generate_ElementaryEntities_FacetNNN (List_T * InitialList, List_T ** ExtendedList, int Type_Entity) ; /* ----- */ void Generate_Link(struct ConstraintInFS * Constraint_P, int Flag_New) { struct ConstraintActive * Active ; struct Group * Group_P, * RegionRef_P, * SubRegionRef_P ; int Nbr_Entity ; Message::Debug("C o n s t r a i n t ( L i n k )") ; if (Flag_New) Constraint_P->Active.Active = (struct ConstraintActive *)Malloc(sizeof(struct ConstraintActive)) ; Active = Constraint_P->Active.Active ; Active->TimeStep = (int)Current.TimeStep ; Active->SubTimeStep = Current.SubTimeStep ; Group_P = (struct Group*) List_Pointer(Problem_S.Group, Constraint_P->EntityIndex) ; RegionRef_P = (struct Group*) List_Pointer(Problem_S.Group, Constraint_P->ConstraintPerRegion->Case.Link.RegionRefIndex) ; SubRegionRef_P = (Constraint_P->ConstraintPerRegion->Case.Link.SubRegionRefIndex >= 0)? (struct Group*) List_Pointer(Problem_S.Group, Constraint_P->ConstraintPerRegion->Case.Link.SubRegionRefIndex) : NULL ; if (Group_P->FunctionType == REGION){ Nbr_Entity = List_Nbr(Group_P->InitialList) ; } else{ Nbr_Entity = List_Nbr(Group_P->ExtendedList) ; } if (Nbr_Entity) { if (Flag_New) Active->Case.Link.Couples = List_Create(Nbr_Entity, 1, sizeof(struct TwoIntOneDouble)) ; else List_Reset(Active->Case.Link.Couples) ; } else { Active->Case.Link.Couples = NULL ; return ; } switch (Group_P->FunctionType) { case NODESOF : Generate_LinkNodes(Constraint_P, Group_P->ExtendedList, Group_P->ExtendedSuppList, RegionRef_P, SubRegionRef_P, Constraint_P->ConstraintPerRegion->Case.Link.FilterIndex, Constraint_P->ConstraintPerRegion->Case.Link.FunctionIndex, Constraint_P->ConstraintPerRegion->Case.Link.CoefIndex, Active->Case.Link.Couples) ; break ; case EDGESOF : Generate_LinkEdges(Constraint_P, Group_P, RegionRef_P, SubRegionRef_P, Active->Case.Link.Couples) ; break ; case FACETSOF : Generate_LinkFacets(Constraint_P, Group_P, RegionRef_P, SubRegionRef_P, Active->Case.Link.Couples) ; /*Message::Error("Link not yet implemented for FACETSOF") ;*/ break ; case REGION : Generate_LinkRegions(Constraint_P, Group_P->InitialList, RegionRef_P->InitialList, Constraint_P->ConstraintPerRegion->Case.Link.CoefIndex, Active->Case.Link.Couples) ; break ; default : Message::Error("Bad function type for Constraint Link: %d", Group_P->FunctionType) ; break ; } } /* G e n e r a t e _ L i n k N o d e s */ void Generate_LinkNodes(struct ConstraintInFS * Constraint_P, List_T * ExtendedList_L, List_T * ExtendedSuppList_L, struct Group * RegionRef_P, struct Group * SubRegionRef_P, int Index_Filter, int Index_Function, int Index_Coef, List_T * Couples_L) { int Nbr_Entity, i, Nbr_EntityRef, Flag_Filter ; double TOL = Current.GeoData->CharacteristicLength * 1.e-8; struct TwoIntOneDouble TwoIntOneDouble ; struct NodeXYZ NodeXYZ, NodeXYZRef ; List_T * NodeXYZ_L, * NodeXYZRef_L ; List_T * ExtendedListRef_L, * ExtendedSuppListRef_L ; struct Value Value ; /* Nodes with Constraint */ Nbr_Entity = List_Nbr(ExtendedList_L) ; NodeXYZ_L = List_Create(Nbr_Entity, 1, sizeof(struct NodeXYZ)) ; for (i = 0 ; i < Nbr_Entity ; i++) { List_Read(ExtendedList_L, i, &NodeXYZ.NumNode) ; if (!(ExtendedSuppList_L && List_Search(ExtendedSuppList_L, &NodeXYZ.NumNode, fcmp_int))) { Geo_GetNodesCoordinates( 1, &NodeXYZ.NumNode, &Current.x, &Current.y, &Current.z) ; Get_ValueOfExpressionByIndex(Index_Function, NULL, 0., 0., 0., &Value) ; Current.x = Value.Val[0] ; Current.y = Value.Val[1] ; Current.z = Value.Val[2] ; if (Index_Filter < 0) Flag_Filter = 1 ; else { Get_ValueOfExpressionByIndex(Index_Filter, NULL, 0., 0., 0., &Value) ; Flag_Filter = (int)Value.Val[0] ; } if (Flag_Filter) { NodeXYZ.x = Current.x ; NodeXYZ.y = Current.y ; NodeXYZ.z = Current.z ; List_Add(NodeXYZ_L, &NodeXYZ) ; } } } Nbr_Entity = List_Nbr(NodeXYZ_L) ; /* Nodes of reference (Link) */ Generate_ElementaryEntities (RegionRef_P->InitialList, &ExtendedListRef_L, NODESOF) ; if (SubRegionRef_P) Generate_ElementaryEntities (SubRegionRef_P->InitialList, &ExtendedSuppListRef_L, NODESOF) ; else ExtendedSuppListRef_L = NULL ; Nbr_EntityRef = List_Nbr(ExtendedListRef_L) ; NodeXYZRef_L = List_Create(Nbr_EntityRef, 1, sizeof(struct NodeXYZ)) ; for (i = 0 ; i < Nbr_EntityRef ; i++) { List_Read(ExtendedListRef_L, i, &NodeXYZRef.NumNode) ; if (!(ExtendedSuppListRef_L && List_Search(ExtendedSuppListRef_L, &NodeXYZRef.NumNode, fcmp_int))) { Geo_GetNodesCoordinates( 1, &NodeXYZRef.NumNode, &Current.x, &Current.y, &Current.z) ; if (Index_Filter < 0) Flag_Filter = 1 ; else { Get_ValueOfExpressionByIndex(Index_Filter, NULL, 0., 0., 0., &Value) ; Flag_Filter = (int)Value.Val[0] ; } if (Flag_Filter) { NodeXYZRef.x = Current.x ; NodeXYZRef.y = Current.y ; NodeXYZRef.z = Current.z ; List_Add(NodeXYZRef_L, &NodeXYZRef) ; } } } Nbr_EntityRef = List_Nbr(NodeXYZRef_L) ; List_Sort(NodeXYZ_L , fcmp_XYZ) ; List_Sort(NodeXYZRef_L, fcmp_XYZ) ; if (Nbr_EntityRef != Nbr_Entity){ Message::Error("Constraint Link: bad correspondance of number of Nodes (%d, %d)", Nbr_Entity, Nbr_EntityRef) ; return; } Message::Debug("==> List of link for nodes") ; for (i = 0 ; i < Nbr_Entity ; i++) { List_Read(NodeXYZ_L, i, &NodeXYZ) ; List_Read(NodeXYZRef_L, i, &NodeXYZRef) ; /* Attention: tolerance !!! */ if ((fabs(NodeXYZ.x-NodeXYZRef.x) > TOL) || (fabs(NodeXYZ.y-NodeXYZRef.y) > TOL) || (fabs(NodeXYZ.z-NodeXYZRef.z) > TOL)){ Message::Error("Constraint Link: bad correspondance of Nodes (%d, %d)" " (%e %e %e), TOL=%g", NodeXYZ.NumNode, NodeXYZRef.NumNode, fabs(NodeXYZ.x-NodeXYZRef.x), fabs(NodeXYZ.y-NodeXYZRef.y), fabs(NodeXYZ.z-NodeXYZRef.z), TOL) ; return; } TwoIntOneDouble.Int1 = NodeXYZ.NumNode ; TwoIntOneDouble.Int2 = NodeXYZRef.NumNode ; /* Calcul du coefficient base sur les coordonnees du noeud de ref ... */ Geo_GetNodesCoordinates(1, &NodeXYZRef.NumNode, &Current.x, &Current.y, &Current.z) ; Get_ValueOfExpressionByIndex(Index_Coef, NULL, 0., 0., 0., &Value) ; TwoIntOneDouble.Double = Value.Val[0] ; if (Current.NbrHar == 1) TwoIntOneDouble.Double2 = 0. ; else TwoIntOneDouble.Double2 = Value.Val[MAX_DIM] ; /* LinkCplx */ List_Add(Couples_L, &TwoIntOneDouble) ; Message::Debug("%d %d : coef %e %e", NodeXYZ.NumNode, NodeXYZRef.NumNode, TwoIntOneDouble.Double, TwoIntOneDouble.Double2) ; } List_Delete(NodeXYZ_L) ; List_Delete(NodeXYZRef_L) ; } int fcmp_XYZ(const void * a, const void * b) { double Result, TOL=Current.GeoData->CharacteristicLength * 1.e-8 ; if (fabs(Result = ((struct NodeXYZ *)a)->x - ((struct NodeXYZ *)b)->x) > TOL) return (Result > 0.)? 1 : -1 ; if (fabs(Result = ((struct NodeXYZ *)a)->y - ((struct NodeXYZ *)b)->y) > TOL) return (Result > 0.)? 1 : -1 ; if (fabs(Result = ((struct NodeXYZ *)a)->z - ((struct NodeXYZ *)b)->z) > TOL) return (Result > 0.)? 1 : -1 ; return 0 ; } /* G e n e r a t e _ L i n k E d g e s */ void Generate_LinkEdges(struct ConstraintInFS * Constraint_P, struct Group * Group_P, struct Group * RegionRef_P, struct Group * SubRegionRef_P, List_T * Couples_L) { int Nbr_Entity, Nbr_EntityRef ; List_T * ExtendedListNodes_L ; List_T * CouplesOfNodes_L, * CouplesOfNodes2_L ; struct EdgeNN EdgeNN, EdgeNNRef ; List_T * EdgeNN_L, * EdgeNNRef_L ; List_T * ExtendedListRef_L, * ExtendedSuppListRef_L ; int i ; struct TwoIntOneDouble *TwoIntOneDouble_P, *TwoIntOneDouble2_P, TwoIntOneDouble ; List_T * ExtendedList_L ; int Save_Num, Flag_Filter ; /* Couples of nodes */ Generate_ElementaryEntities (Group_P->InitialList, &ExtendedListNodes_L, NODESOF) ; if ((Nbr_Entity = List_Nbr(ExtendedListNodes_L))) CouplesOfNodes_L = List_Create(Nbr_Entity, 1, sizeof(struct TwoIntOneDouble)) ; else { return ; /* situation impossible... */ } if (Constraint_P->ConstraintPerRegion->Case.Link.FilterIndex2 < 0) { Flag_Filter = 0 ; CouplesOfNodes2_L = NULL ; Generate_LinkNodes(Constraint_P, ExtendedListNodes_L, NULL, RegionRef_P, NULL, Constraint_P->ConstraintPerRegion->Case.Link.FilterIndex, Constraint_P->ConstraintPerRegion->Case.Link.FunctionIndex, Constraint_P->ConstraintPerRegion->Case.Link.CoefIndex, CouplesOfNodes_L) ; } else { Flag_Filter = 1 ; CouplesOfNodes2_L = List_Create(Nbr_Entity, 1, sizeof(struct TwoIntOneDouble)) ; Generate_LinkNodes(Constraint_P, ExtendedListNodes_L, NULL, RegionRef_P, NULL, Constraint_P->ConstraintPerRegion->Case.Link.FilterIndex, Constraint_P->ConstraintPerRegion->Case.Link.FunctionIndex, Constraint_P->ConstraintPerRegion->Case.Link.CoefIndex, CouplesOfNodes_L) ; Generate_LinkNodes(Constraint_P, ExtendedListNodes_L, NULL, RegionRef_P, NULL, Constraint_P->ConstraintPerRegion->Case.Link.FilterIndex2, Constraint_P->ConstraintPerRegion->Case.Link.FunctionIndex2, Constraint_P->ConstraintPerRegion->Case.Link.CoefIndex2, CouplesOfNodes2_L) ; } /* Couples of edges */ Message::Info("== Couples of edges ==") ; /* Edges with Constraint */ Nbr_Entity = List_Nbr(Group_P->ExtendedList) ; Generate_ElementaryEntities_EdgeNN (Group_P->InitialList, &ExtendedList_L, EDGESOF) ; if (Group_P->InitialSuppList) Generate_ElementaryEntities_EdgeNN (Group_P->InitialSuppList, &ExtendedSuppListRef_L, EDGESOF) ; else ExtendedSuppListRef_L = NULL ; EdgeNN_L = List_Create(Nbr_Entity, 1, sizeof(struct EdgeNN)) ; if (Nbr_Entity != List_Nbr(ExtendedList_L)){ Message::Error("Constraint Link: strange...") ; return; } for (i = 0 ; i < Nbr_Entity ; i++) { List_Read(ExtendedList_L, i, &EdgeNN) ; if (!(ExtendedSuppListRef_L && List_Search(ExtendedSuppListRef_L, &EdgeNN.NumEdge, fcmp_int))) { if (EdgeNN.Node2 < EdgeNN.Node1) { Save_Num = EdgeNN.Node2 ; EdgeNN.Node2 = EdgeNN.Node1 ; EdgeNN.Node1 = Save_Num ; } Message::Debug("Image %d: a%d, n%d - n%d", i, EdgeNN.NumEdge, EdgeNN.Node1, EdgeNN.Node2) ; TwoIntOneDouble_P = (struct TwoIntOneDouble *) List_PQuery(CouplesOfNodes_L, &EdgeNN.Node1, fcmp_int) ; TwoIntOneDouble2_P = (struct TwoIntOneDouble *) List_PQuery(CouplesOfNodes_L, &EdgeNN.Node2, fcmp_int) ; if (!(TwoIntOneDouble_P && TwoIntOneDouble2_P)) { if (Flag_Filter) { TwoIntOneDouble_P = (struct TwoIntOneDouble *) List_PQuery(CouplesOfNodes2_L, &EdgeNN.Node1, fcmp_int) ; TwoIntOneDouble2_P = (struct TwoIntOneDouble *) List_PQuery(CouplesOfNodes2_L, &EdgeNN.Node2, fcmp_int) ; if (!TwoIntOneDouble_P) Message::Error("Constraint Link: unknown node (%d)", EdgeNN.Node1) ; if (!TwoIntOneDouble2_P) Message::Error("Constraint Link: unknown node (%d)", EdgeNN.Node2) ; } else Message::Error("Constraint Link: bad correspondance for edges") ; } EdgeNN.Node1 = TwoIntOneDouble_P->Int2 ; EdgeNN.Node2 = TwoIntOneDouble2_P->Int2 ; if (fabs(TwoIntOneDouble_P->Double - TwoIntOneDouble2_P->Double) > 1.e-18){ Message::Error("Constraint Link: Bad Coefficient for Edges") ; return; } EdgeNN.Coef = TwoIntOneDouble_P->Double ; EdgeNN.Coef2 = TwoIntOneDouble_P->Double2 ; /* LinkCplx */ if (EdgeNN.Node2 < EdgeNN.Node1) { Save_Num = EdgeNN.Node2 ; EdgeNN.Node2 = EdgeNN.Node1 ; EdgeNN.Node1 = Save_Num ; EdgeNN.NumEdge *= -1 ; } List_Add(EdgeNN_L, &EdgeNN) ; Message::Debug(" --- (whose source is) ---> a%d, n%d - n%d", EdgeNN.NumEdge, EdgeNN.Node1, EdgeNN.Node2) ; } } Nbr_Entity = List_Nbr(EdgeNN_L) ; /* Edges of reference (Link) */ Generate_ElementaryEntities_EdgeNN (RegionRef_P->InitialList, &ExtendedListRef_L, EDGESOF) ; if (SubRegionRef_P) Generate_ElementaryEntities_EdgeNN (SubRegionRef_P->InitialList, &ExtendedSuppListRef_L, EDGESOF) ; else ExtendedSuppListRef_L = NULL ; Nbr_EntityRef = List_Nbr(ExtendedListRef_L) ; EdgeNNRef_L = List_Create(Nbr_EntityRef, 1, sizeof(struct EdgeNN)) ; for (i = 0 ; i < Nbr_EntityRef ; i++) { List_Read(ExtendedListRef_L, i, &EdgeNNRef.NumEdge) ; if (!(ExtendedSuppListRef_L && List_Search(ExtendedSuppListRef_L, &EdgeNNRef.NumEdge, fcmp_int))) { if (EdgeNNRef.Node2 < EdgeNNRef.Node1) { Save_Num = EdgeNNRef.Node2 ; EdgeNNRef.Node2 = EdgeNNRef.Node1 ; EdgeNNRef.Node1 = Save_Num ; } List_Add(EdgeNNRef_L, &EdgeNNRef) ; Message::Debug("Ref %d: a%d, n%d - n%d", i, EdgeNNRef.NumEdge, EdgeNNRef.Node1, EdgeNNRef.Node2) ; } } Nbr_EntityRef = List_Nbr(EdgeNNRef_L) ; if (Nbr_EntityRef != Nbr_Entity){ Message::Error("Constraint Link: bad correspondance of number of Edges (%d, %d)", Nbr_Entity, Nbr_EntityRef) ; return; } List_Sort(EdgeNN_L , fcmp_NN) ; List_Sort(EdgeNNRef_L, fcmp_NN) ; for (i = 0 ; i < Nbr_Entity ; i++) { List_Read(EdgeNN_L, i, &EdgeNN) ; List_Read(EdgeNNRef_L, i, &EdgeNNRef) ; Message::Debug("Final : %d: a%d, n%d - n%d (%.16g + %.16g i) / a%d, n%d - n%d", i, EdgeNN.NumEdge, EdgeNN.Node1, EdgeNN.Node2, EdgeNN.Coef, EdgeNN.Coef2, EdgeNNRef.NumEdge, EdgeNNRef.Node1, EdgeNNRef.Node2) ; if (EdgeNN.Node1 != EdgeNNRef.Node1 || EdgeNN.Node2 != EdgeNNRef.Node2){ Message::Error("Constraint Link: bad correspondance of Edges (%d, %d)", EdgeNN.NumEdge, EdgeNNRef.NumEdge) ; return; } TwoIntOneDouble.Int1 = EdgeNN.NumEdge ; TwoIntOneDouble.Int2 = EdgeNNRef.NumEdge ; TwoIntOneDouble.Double = EdgeNN.Coef ; TwoIntOneDouble.Double2 = EdgeNN.Coef2 ; /* LinkCplx */ List_Add(Couples_L, &TwoIntOneDouble) ; } List_Delete(EdgeNN_L) ; List_Delete(EdgeNNRef_L) ; List_Delete(CouplesOfNodes_L) ; List_Delete(CouplesOfNodes2_L) ; Message::Info("====> End Link Edge") ; } int fcmp_NN(const void * a, const void * b) { int Result ; if ((Result = ((struct EdgeNN *)a)->Node1 - ((struct EdgeNN *)b)->Node1) != 0) return Result ; return ((struct EdgeNN *)a)->Node2 - ((struct EdgeNN *)b)->Node2 ; } void Generate_ElementaryEntities_EdgeNN (List_T * InitialList, List_T ** ExtendedList, int Type_Entity) { Tree_T * Entity_Tr ; struct Geo_Element * GeoElement ; int Nbr_Element, i_Element ; int Nbr_Entity = 0, i_Entity, * Num_Entities = NULL; struct EdgeNN EdgeNN ; int * Num_Nodes ; if (InitialList != NULL) { Entity_Tr = Tree_Create(sizeof (struct EdgeNN), fcmp_int) ; Nbr_Element = Geo_GetNbrGeoElements() ; for (i_Element = 0 ; i_Element < Nbr_Element ; i_Element++) { GeoElement = Geo_GetGeoElement(i_Element) ; if (List_Search(InitialList, &GeoElement->Region, fcmp_int) ) { switch (Type_Entity) { case EDGESOF : if (GeoElement->NbrEdges == 0) Geo_CreateEdgesOfElement(GeoElement) ; Nbr_Entity = GeoElement->NbrEdges ; Num_Entities = GeoElement->NumEdges ; break ; } for (i_Entity = 0; i_Entity < Nbr_Entity ; i_Entity++) { EdgeNN.NumEdge = abs(Num_Entities[i_Entity]) ; Num_Nodes = Geo_GetNodesOfEdgeInElement(GeoElement, i_Entity) ; EdgeNN.Node1 = GeoElement->NumNodes[abs(Num_Nodes[0])-1] ; EdgeNN.Node2 = GeoElement->NumNodes[abs(Num_Nodes[1])-1] ; if ( ! Tree_Search(Entity_Tr, &EdgeNN) ) Tree_Add(Entity_Tr, &EdgeNN) ; } } } *ExtendedList = Tree2List(Entity_Tr) ; Tree_Delete(Entity_Tr) ; } else *ExtendedList = NULL ; } /*-----------------------------------------*/ /*| G e n e r a t e _ L i n k F a c e t s |*/ /*-----------------------------------------*/ void Generate_LinkFacets(struct ConstraintInFS * Constraint_P, struct Group * Group_P, struct Group * RegionRef_P, struct Group * SubRegionRef_P, List_T * Couples_L) { int Nbr_Entity, Nbr_EntityRef ; List_T * ExtendedListNodes_L ; List_T * CouplesOfNodes_L, * CouplesOfNodes2_L ; struct FacetNNN FacetNNN, FacetNNNRef ; List_T * FacetNNN_L, * FacetNNNRef_L ; List_T * ExtendedListRef_L, * ExtendedSuppListRef_L ; int i ; struct TwoIntOneDouble *TwoIntOneDouble_P, *TwoIntOneDouble2_P; struct TwoIntOneDouble *TwoIntOneDouble3_P, TwoIntOneDouble ; List_T * ExtendedList_L ; // int Save_Num1, Save_Num2, Save_Num3; int Flag_Filter ; /* Couples of nodes */ Generate_ElementaryEntities (Group_P->InitialList, &ExtendedListNodes_L, NODESOF) ; if ((Nbr_Entity = List_Nbr(ExtendedListNodes_L))) CouplesOfNodes_L = List_Create(Nbr_Entity, 1, sizeof(struct TwoIntOneDouble)) ; else { return ; /* situation impossible... */ } if (Constraint_P->ConstraintPerRegion->Case.Link.FilterIndex2 < 0) { Flag_Filter = 0 ; CouplesOfNodes2_L = NULL ; Generate_LinkNodes(Constraint_P, ExtendedListNodes_L, NULL, RegionRef_P, NULL, Constraint_P->ConstraintPerRegion->Case.Link.FilterIndex, Constraint_P->ConstraintPerRegion->Case.Link.FunctionIndex, Constraint_P->ConstraintPerRegion->Case.Link.CoefIndex, CouplesOfNodes_L) ; } else { Flag_Filter = 1 ; CouplesOfNodes2_L = List_Create(Nbr_Entity, 1, sizeof(struct TwoIntOneDouble)) ; Generate_LinkNodes(Constraint_P, ExtendedListNodes_L, NULL, RegionRef_P, NULL, Constraint_P->ConstraintPerRegion->Case.Link.FilterIndex, Constraint_P->ConstraintPerRegion->Case.Link.FunctionIndex, Constraint_P->ConstraintPerRegion->Case.Link.CoefIndex, CouplesOfNodes_L) ; Generate_LinkNodes(Constraint_P, ExtendedListNodes_L, NULL, RegionRef_P, NULL, Constraint_P->ConstraintPerRegion->Case.Link.FilterIndex2, Constraint_P->ConstraintPerRegion->Case.Link.FunctionIndex2, Constraint_P->ConstraintPerRegion->Case.Link.CoefIndex2, CouplesOfNodes2_L) ; } /* Couples of facets */ Message::Info("== Couples of facets ==") ; /* Facets with Constraint */ Nbr_Entity = List_Nbr(Group_P->ExtendedList) ; Generate_ElementaryEntities_FacetNNN (Group_P->InitialList, &ExtendedList_L, FACETSOF) ; if (Group_P->InitialSuppList) Generate_ElementaryEntities_FacetNNN (Group_P->InitialSuppList, &ExtendedSuppListRef_L, FACETSOF) ; else ExtendedSuppListRef_L = NULL ; FacetNNN_L = List_Create(Nbr_Entity, 1, sizeof(struct FacetNNN)) ; if (Nbr_Entity != List_Nbr(ExtendedList_L)){ Message::Error("Constraint Link: strange...") ; return; } Message::Debug("(ajout) Image: f%d, n%d - n%d - n%d", FacetNNN.NumFacet, FacetNNN.Node1, FacetNNN.Node2, FacetNNN.Node3) ; for (i = 0 ; i < Nbr_Entity ; i++) { List_Read(ExtendedList_L, i, &FacetNNN) ; if (!(ExtendedSuppListRef_L && List_Search(ExtendedSuppListRef_L, &FacetNNN.NumFacet, fcmp_int))) { // FIXME TODO /*if (FacetNNN.Node3 < FacetNNN.Node2) { Save_Num1 = FacetNNN.Node3 ; FacetNNN.Node3 = FacetNNN.Node2 ; FacetNNN.Node2 = Save_Num1 ; } if (FacetNNN.Node3 < FacetNNN.Node1) { Save_Num3 = FacetNNN.Node3 ; FacetNNN.Node3 = FacetNNN.Node1 ; FacetNNN.Node1 = Save_Num2 ; } if (FacetNNN.Node2 < FacetNNN.Node1) { Save_Num3 = FacetNNN.Node2 ; FacetNNN.Node2 = FacetNNN.Node1 ; FacetNNN.Node1 = Save_Num3 ; }*/ Message::Debug("Image %d: f%d, n%d - n%d - n%d", i, FacetNNN.NumFacet, FacetNNN.Node1, FacetNNN.Node2, FacetNNN.Node3) ; TwoIntOneDouble_P = (struct TwoIntOneDouble *) List_PQuery(CouplesOfNodes_L, &FacetNNN.Node1, fcmp_int) ; TwoIntOneDouble2_P = (struct TwoIntOneDouble *) List_PQuery(CouplesOfNodes_L, &FacetNNN.Node2, fcmp_int) ; TwoIntOneDouble3_P = (struct TwoIntOneDouble *) List_PQuery(CouplesOfNodes_L, &FacetNNN.Node3, fcmp_int) ; if (!(TwoIntOneDouble_P && TwoIntOneDouble2_P && TwoIntOneDouble3_P)) { if (Flag_Filter) { TwoIntOneDouble_P = (struct TwoIntOneDouble *) List_PQuery(CouplesOfNodes2_L, &FacetNNN.Node1, fcmp_int) ; TwoIntOneDouble2_P = (struct TwoIntOneDouble *) List_PQuery(CouplesOfNodes2_L, &FacetNNN.Node2, fcmp_int) ; TwoIntOneDouble3_P = (struct TwoIntOneDouble *) List_PQuery(CouplesOfNodes2_L, &FacetNNN.Node3, fcmp_int) ; if (!TwoIntOneDouble_P) Message::Error("1-Constraint Link: unknown node (%d)", FacetNNN.Node1) ; if (!TwoIntOneDouble2_P) Message::Error("2-Constraint Link: unknown node (%d)", FacetNNN.Node2) ; if (!TwoIntOneDouble3_P) Message::Error("3-Constraint Link: unknown node (%d)", FacetNNN.Node3) ; } else Message::Error("4-Constraint Link: bad correspondance for facets") ; } FacetNNN.Node1 = TwoIntOneDouble_P->Int2 ; FacetNNN.Node2 = TwoIntOneDouble2_P->Int2 ; FacetNNN.Node3 = TwoIntOneDouble3_P->Int2 ; if ( (fabs(TwoIntOneDouble_P->Double - TwoIntOneDouble2_P->Double) > 1.e-18) || (fabs(TwoIntOneDouble2_P->Double - TwoIntOneDouble3_P->Double) > 1.e-18) || (fabs(TwoIntOneDouble3_P->Double - TwoIntOneDouble_P->Double ) > 1.e-18) ) Message::Error("5-Constraint Link: Bad Coefficient for Facets") ; FacetNNN.Coef = TwoIntOneDouble_P->Double ; FacetNNN.Coef2 = TwoIntOneDouble_P->Double2 ; /* LinkCplx */ // FIXME TODO /*if (FacetNNN.Node3 < FacetNNN.Node2) { Save_Num1 = FacetNNN.Node3 ; FacetNNN.Node3 = FacetNNN.Node2 ; FacetNNN.Node2 = Save_Num1 ; FacetNNN.NumFacet *= -1 ; } if (FacetNNN.Node3 < FacetNNN.Node1) { Save_Num2 = FacetNNN.Node3 ; FacetNNN.Node3 = FacetNNN.Node1 ; FacetNNN.Node1 = Save_Num2 ; FacetNNN.NumFacet *= -1 ; } if (FacetNNN.Node2 < FacetNNN.Node1) { Save_Num3 = FacetNNN.Node2 ; FacetNNN.Node2 = FacetNNN.Node1 ; FacetNNN.Node1 = Save_Num3 ; FacetNNN.NumFacet *= -1 ; } */ List_Add(FacetNNN_L, &FacetNNN) ; Message::Debug(" --- (whose source is) ---> f%d, n%d - n%d - n%d", FacetNNN.NumFacet, FacetNNN.Node1, FacetNNN.Node2, FacetNNN.Node3) ; } } Nbr_Entity = List_Nbr(FacetNNN_L) ; /* Facets of reference (Link) */ Generate_ElementaryEntities_FacetNNN (RegionRef_P->InitialList, &ExtendedListRef_L, FACETSOF) ; if (SubRegionRef_P) Generate_ElementaryEntities_FacetNNN (SubRegionRef_P->InitialList, &ExtendedSuppListRef_L, FACETSOF) ; else ExtendedSuppListRef_L = NULL ; Nbr_EntityRef = List_Nbr(ExtendedListRef_L) ; FacetNNNRef_L = List_Create(Nbr_EntityRef, 1, sizeof(struct FacetNNN)) ; for (i = 0 ; i < Nbr_EntityRef ; i++) { List_Read(ExtendedListRef_L, i, &FacetNNNRef.NumFacet) ; if (!(ExtendedSuppListRef_L && List_Search(ExtendedSuppListRef_L, &FacetNNNRef.NumFacet, fcmp_int))) { // FIXME TODO /*if (FacetNNNRef.Node3 < FacetNNNRef.Node2) { Save_Num1 = FacetNNNRef.Node3 ; FacetNNNRef.Node3 = FacetNNNRef.Node2 ; FacetNNNRef.Node2 = Save_Num1 ; } if (FacetNNNRef.Node3 < FacetNNNRef.Node1) { Save_Num2 = FacetNNNRef.Node3 ; FacetNNNRef.Node3 = FacetNNNRef.Node1 ; FacetNNNRef.Node1 = Save_Num2 ; } if (FacetNNNRef.Node2 < FacetNNNRef.Node1) { Save_Num3 = FacetNNNRef.Node2 ; FacetNNNRef.Node2 = FacetNNNRef.Node1 ; FacetNNNRef.Node1 = Save_Num3 ; } */ List_Add(FacetNNNRef_L, &FacetNNNRef) ; /* -- */ Message::Debug("Ref %d: f%d, n%d - n%d - n%d ", i, FacetNNNRef.NumFacet, FacetNNNRef.Node1, FacetNNNRef.Node2, FacetNNNRef.Node3) ; } } Nbr_EntityRef = List_Nbr(FacetNNNRef_L) ; if (Nbr_EntityRef != Nbr_Entity){ Message::Error("6-Constraint Link: bad correspondance of number of facets (%d, %d)", Nbr_Entity, Nbr_EntityRef) ; return; } List_Sort(FacetNNN_L , fcmp_NNN) ; List_Sort(FacetNNNRef_L, fcmp_NNN) ; for (i = 0 ; i < Nbr_Entity ; i++) { List_Read(FacetNNN_L, i, &FacetNNN) ; List_Read(FacetNNNRef_L, i, &FacetNNNRef) ; Message::Debug("Final : %d: a%d, n%d - n%d - n%d (%.16g + %.16g i) / a%d, n%d - n%d - n%d", i, FacetNNN.NumFacet, FacetNNN.Node1, FacetNNN.Node2, FacetNNN.Node3, FacetNNN.Coef, FacetNNN.Coef2, FacetNNNRef.NumFacet, FacetNNNRef.Node1, FacetNNNRef.Node2, FacetNNNRef.Node3) ; if (FacetNNN.Node1 != FacetNNNRef.Node1 || FacetNNN.Node2 != FacetNNNRef.Node2 || FacetNNN.Node3 != FacetNNNRef.Node3 ){ Message::Error("7-Constraint Link: bad correspondance of facets (%d, %d)", FacetNNN.NumFacet, FacetNNNRef.NumFacet) ; return; } TwoIntOneDouble.Int1 = FacetNNN.NumFacet ; TwoIntOneDouble.Int2 = FacetNNNRef.NumFacet ; TwoIntOneDouble.Double = FacetNNN.Coef ; TwoIntOneDouble.Double2 = FacetNNN.Coef2 ; /* LinkCplx */ List_Add(Couples_L, &TwoIntOneDouble) ; } List_Delete(FacetNNN_L) ; List_Delete(FacetNNNRef_L) ; List_Delete(CouplesOfNodes_L) ; List_Delete(CouplesOfNodes2_L) ; Message::Info("====> End Link Facet") ; } int fcmp_NNN(const void * a, const void * b) { int Result ; if ((Result = ((struct FacetNNN *)a)->Node1 - ((struct FacetNNN *)b)->Node1) != 0) return Result ; if ((Result = ((struct FacetNNN *)a)->Node2 - ((struct FacetNNN *)b)->Node2) != 0) return Result ; return ((struct FacetNNN *)a)->Node3 - ((struct FacetNNN *)b)->Node3 ; } void Generate_ElementaryEntities_FacetNNN (List_T * InitialList, List_T ** ExtendedList, int Type_Entity) { Tree_T * Entity_Tr ; struct Geo_Element * GeoElement ; int Nbr_Element, i_Element ; int Nbr_Entity = 0, i_Entity, * Num_Entities = NULL; struct FacetNNN FacetNNN ; int * Num_Nodes ; if (InitialList != NULL) { Entity_Tr = Tree_Create(sizeof (struct FacetNNN), fcmp_int) ; Nbr_Element = Geo_GetNbrGeoElements() ; for (i_Element = 0 ; i_Element < Nbr_Element ; i_Element++) { GeoElement = Geo_GetGeoElement(i_Element) ; if (List_Search(InitialList, &GeoElement->Region, fcmp_int) ) { switch (Type_Entity) { case FACETSOF : if (GeoElement->NbrFacets == 0) Geo_CreateFacetsOfElement(GeoElement) ; Nbr_Entity = GeoElement->NbrFacets ; Num_Entities = GeoElement->NumFacets ; break ; } for (i_Entity = 0; i_Entity < Nbr_Entity ; i_Entity++) { FacetNNN.NumFacet = abs(Num_Entities[i_Entity]) ; Num_Nodes = Geo_GetNodesOfFacetInElement(GeoElement, i_Entity) ; FacetNNN.Node1 = GeoElement->NumNodes[abs(Num_Nodes[0])-1] ; FacetNNN.Node2 = GeoElement->NumNodes[abs(Num_Nodes[1])-1] ; FacetNNN.Node3 = GeoElement->NumNodes[abs(Num_Nodes[2])-1] ; if ( ! Tree_Search(Entity_Tr, &FacetNNN) ) Tree_Add(Entity_Tr, &FacetNNN) ; } } } *ExtendedList = Tree2List(Entity_Tr) ; Tree_Delete(Entity_Tr) ; } else *ExtendedList = NULL ; } /* G e n e r a t e _ L i n k R e g i o n s */ void Generate_LinkRegions(struct ConstraintInFS * Constraint_P, List_T * Region_L, List_T * RegionRef_L, int Index_Coef, List_T * Couples_L) { struct TwoIntOneDouble TwoIntOneDouble ; struct Value Value ; if (List_Nbr(Region_L) > 1 || List_Nbr(RegionRef_L) > 1){ Message::Error("More than one region for link type constraint") ; return; } List_Read(Region_L, 0, &TwoIntOneDouble.Int1) ; List_Read(RegionRef_L, 0, &TwoIntOneDouble.Int2) ; Get_ValueOfExpressionByIndex(Index_Coef, NULL, 0., 0., 0., &Value) ; TwoIntOneDouble.Double = Value.Val[0] ; if (Current.NbrHar == 1) TwoIntOneDouble.Double2 = 0. ; else TwoIntOneDouble.Double2 = Value.Val[MAX_DIM] ; /* LinkCplx */ List_Add(Couples_L, &TwoIntOneDouble) ; } getdp-2.4.2-source/Legacy/Gauss_Point.cpp000644 001750 001750 00000000575 12116424202 021744 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . /* Gauss integration over a point (!) */ void Gauss_Point(int Nbr_Points, int Num, double *u, double *v, double *w, double *wght) { *u = 0. ; *v = 0. ; *w = 0. ; *wght = 1. ; } getdp-2.4.2-source/Legacy/Pos_Format.cpp000644 001750 001750 00000152040 12142254330 021557 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include #include #include #include "GetDPVersion.h" #include "ProData.h" #include "ProDefine.h" #include "GeoData.h" #include "DofData.h" #include "Pos_Iso.h" #include "Pos_Format.h" #include "Pos_Element.h" #include "Pos_Formulation.h" #include "F.h" #include "Cal_Value.h" #include "Cal_Quantity.h" #include "MallocUtils.h" #include "Message.h" #if defined(HAVE_GMSH) #include #include #endif #define TWO_PI 6.2831853071795865 #define NBR_MAX_ISO 200 extern struct Problem Problem_S ; extern struct CurrentData Current ; extern int Flag_BIN, Flag_GMSH_VERSION; extern FILE *PostStream ; static List_T *PostElement_L = NULL ; static List_T *TimeValue_L = NULL ; /* ------------------------------------------------------------------------ */ /* Gmsh formats */ /* ------------------------------------------------------------------------ */ // global static lists for new-style Gmsh output (cannot be saved incrementally // for each element) static int Gmsh_StartNewView = 0 ; static int NbSP, NbVP, NbTP, NbSL, NbVL, NbTL, NbST, NbVT, NbTT; static int NbSQ, NbVQ, NbTQ, NbSS, NbVS, NbTS, NbSH, NbVH, NbTH; static int NbSI, NbVI, NbTI, NbSY, NbVY, NbTY; static int NbT2; static std::vector SP, VP, TP, SL, VL, TL, ST, VT, TT, SQ, VQ, TQ; static std::vector SS, VS, TS1 /* for petsc */, SH, VH, TH; static std::vector SI, VI, TI, SY, VY, TY, T2D; static std::vector T2C; static char CurrentName[256] = ""; static int CurrentPartitionNumber = 0; static void Gmsh_ResetStaticLists() { NbSP = NbVP = NbTP = NbSL = NbVL = NbTL = 0; NbST = NbVT = NbTT = NbSQ = NbVQ = NbTQ = 0; NbSS = NbVS = NbTS = NbSH = NbVH = NbTH = 0; NbSI = NbVI = NbTI = NbSY = NbVY = NbTY = 0; NbT2 = 0; SP.clear(); VP.clear(); TP.clear(); SL.clear(); VL.clear(); TL.clear(); ST.clear(); VT.clear(); TT.clear(); SQ.clear(); VQ.clear(); TQ.clear(); SS.clear(); VS.clear(); TS1.clear(); SH.clear(); VH.clear(); TH.clear(); SI.clear(); VI.clear(); TI.clear(); SY.clear(); VY.clear(); TY.clear(); T2D.clear(); T2C.clear(); if(!TimeValue_L) TimeValue_L = List_Create(100,1000000,sizeof(double)); else List_Reset(TimeValue_L); } static void Gmsh_StringStart(int Format, double x, double y, double style) { if(Flag_BIN){ /* bricolage: should use Format instead */ T2D.push_back(x); T2D.push_back(y); T2D.push_back(style); T2D.push_back(T2C.size()); NbT2++; } else{ fprintf(PostStream, "T2(%g,%g,%g){", x, y, style); } } static void Gmsh_StringAdd(int Format, int first, char *text) { int i; if(Flag_BIN){ /* bricolage: should use Format instead */ for(i = 0; i < (int)strlen(text)+1; i++) T2C.push_back(text[i]); } else{ if(!first) fprintf(PostStream, ","); fprintf(PostStream, "\"%s\"", text); } } static void Gmsh_StringEnd(int Format) { if(Flag_BIN){ /* bricolage: should use Format instead */ } else{ fprintf(PostStream, "};\n") ; } } static int Gmsh_GetElementType(int Type) { switch(Type){ case POINT : return(15) ; case LINE : return(1) ; case TRIANGLE : return(2) ; case QUADRANGLE : return(3) ; case TETRAHEDRON : return(4) ; case HEXAHEDRON : return(5) ; case PRISM : return(6) ; case PYRAMID : return(7) ; case LINE_2 : return(8) ; case TRIANGLE_2 : return(9) ; case QUADRANGLE_2 : return(10) ; case TETRAHEDRON_2 : return(11) ; case HEXAHEDRON_2 : return(12) ; case PRISM_2 : return(13) ; case PYRAMID_2 : return(14) ; case QUADRANGLE_2_8N : return(16) ; default : Message::Error("Unknown type of element in Gmsh format") ; return(-1) ; } } static void Gmsh_PrintElementNodeData(struct PostSubOperation *PSO_P, int numTimeStep, int numComp, int Nb[8], std::vector *L[8]) { int N = 0; for(int i = 0; i < 8; i++) N += Nb[i]; if(!N) return; int step = 0; for (int ts = 0; ts < numTimeStep; ts++) { Pos_InitAllSolutions(PSO_P->TimeStep_L, ts); for(int har = 0; har < Current.NbrHar; har++){ fprintf(PostStream, "$ElementNodeData\n"); fprintf(PostStream, "1\n"); fprintf(PostStream, "\"%s\"\n", CurrentName); fprintf(PostStream, "1\n"); fprintf(PostStream, "%.16g\n", Current.Time); fprintf(PostStream, "4\n"); fprintf(PostStream, "%d\n", (PSO_P->OverrideTimeStepValue >= 0) ? PSO_P->OverrideTimeStepValue : (Current.NbrHar > 1 ? step : (int)Current.TimeStep)); fprintf(PostStream, "%d\n", numComp); fprintf(PostStream, "%d\n", N); fprintf(PostStream, "%d\n", CurrentPartitionNumber); for(int i = 0; i < 8; i++){ if(!Nb[i]) continue; int stride = (*L[i]).size() / Nb[i]; for(unsigned int j = 0; j < (*L[i]).size(); j += stride){ double *tmp = &(*L[i])[j]; int num = (int)tmp[0]; int mult = (stride - 1) / numTimeStep / Current.NbrHar / numComp; if(Flag_BIN){ fwrite(&num, sizeof(int), 1, PostStream); fwrite(&mult, sizeof(int), 1, PostStream); fwrite(&tmp[1 + step * mult * numComp], sizeof(double), mult * numComp, PostStream); } else{ fprintf(PostStream, "%d %d", num, mult); for(int k = 0; k < mult * numComp; k++) fprintf(PostStream, " %.16g", tmp[1 + step * mult * numComp + k]); fprintf(PostStream, "\n"); } } } fprintf(PostStream, "$EndElementNodeData\n"); step++; } } } static void GmshParsed_PrintElement(double Time, int TimeStep, int NbTimeStep, int NbHarmonic, int HarmonicToTime, int Type, int NbrNodes, double *x, double *y, double *z, struct Value *Value) { int i,j,k,jj ; double TimeMH ; struct Value TmpValue ; int symIndex[9] = {0, 1, 2, 1, 3, 4, 2, 4, 5} ; int diagIndex[9] = {0, -1, -1, -1, 1, -1, -1, -1, 2} ; if(Gmsh_StartNewView){ Gmsh_StartNewView = 0 ; Gmsh_ResetStaticLists(); } if (HarmonicToTime == 1){ if(NbHarmonic == 2 && NbTimeStep == 1){ // classical complex case double zero = 0., one = 1.; List_Put(TimeValue_L, 0, &zero); List_Put(TimeValue_L, 1, &one); } else{ for(k = 0 ; k < NbHarmonic ; k++) List_Put(TimeValue_L, NbHarmonic*TimeStep+k, &Time); } } else for(k = 0 ; k < HarmonicToTime ; k++) List_Put(TimeValue_L, HarmonicToTime*TimeStep+k, &Time); switch (Value[0].Type) { case SCALAR : if(TimeStep == 0){ switch(Type){ case POINT : fprintf(PostStream, "SP("); break; case LINE : fprintf(PostStream, "SL("); break; case TRIANGLE : fprintf(PostStream, "ST("); break; case QUADRANGLE : fprintf(PostStream, "SQ("); break; case TETRAHEDRON : fprintf(PostStream, "SS("); break; case HEXAHEDRON : fprintf(PostStream, "SH("); break; case PRISM : fprintf(PostStream, "SI("); break; case PYRAMID : fprintf(PostStream, "SY("); break; case LINE_2 : fprintf(PostStream, "SL("); break; case TRIANGLE_2 : fprintf(PostStream, "ST("); break; case QUADRANGLE_2: fprintf(PostStream, "SQ("); break; case QUADRANGLE_2_8N: fprintf(PostStream, "SQ("); break; } for(i = 0 ; i < NbrNodes ; i++){ if(i) fprintf(PostStream, ","); fprintf(PostStream, "%.16g,%.16g,%.16g", x[i], y[i], z[i]); } fprintf(PostStream, "){"); } if (HarmonicToTime == 1) { for(k = 0 ; k < NbHarmonic ; k++) { if(k || TimeStep) fprintf(PostStream, ","); for(i = 0 ; i < NbrNodes ; i++){ if(i) fprintf(PostStream, ","); fprintf(PostStream, "%.16g", Value[i].Val[MAX_DIM*k]); } } } else { for(k = 0 ; k < HarmonicToTime ; k++){ if(k || TimeStep) fprintf(PostStream, ","); for(i = 0 ; i < NbrNodes ; i++){ if(i) fprintf(PostStream, ","); F_MHToTime0(k+i, &Value[i], &TmpValue, k, HarmonicToTime, &TimeMH) ; fprintf(PostStream, "%.16g", TmpValue.Val[0]); } } } if(TimeStep == NbTimeStep-1){ fprintf(PostStream, "};\n") ; } break ; case VECTOR : if(TimeStep == 0){ switch(Type){ case POINT : fprintf(PostStream, "VP("); break; case LINE : fprintf(PostStream, "VL("); break; case TRIANGLE : fprintf(PostStream, "VT("); break; case QUADRANGLE : fprintf(PostStream, "VQ("); break; case TETRAHEDRON : fprintf(PostStream, "VS("); break; case HEXAHEDRON : fprintf(PostStream, "VH("); break; case PRISM : fprintf(PostStream, "VI("); break; case PYRAMID : fprintf(PostStream, "VY("); break; case LINE_2 : fprintf(PostStream, "VL("); break; case TRIANGLE_2 : fprintf(PostStream, "VT("); break; case QUADRANGLE_2: fprintf(PostStream, "VQ("); break; case QUADRANGLE_2_8N: fprintf(PostStream, "VQ("); break; } for(i = 0 ; i < NbrNodes ; i++){ if(i) fprintf(PostStream, ","); fprintf(PostStream, "%.16g,%.16g,%.16g", x[i], y[i], z[i]); } fprintf(PostStream, "){"); } if (HarmonicToTime == 1) { for(k = 0 ; k < NbHarmonic ; k++) { if(k || TimeStep) fprintf(PostStream, ","); for(i = 0 ; i < NbrNodes ; i++){ if(i) fprintf(PostStream, ","); for(j = 0 ; j < 3 ; j++){ if(j) fprintf(PostStream, ","); fprintf(PostStream, "%.16g", Value[i].Val[MAX_DIM*k+j]); } } } } else { for(k = 0 ; k < HarmonicToTime ; k++){ if(k || TimeStep) fprintf(PostStream, ","); for(i = 0 ; i < NbrNodes ; i++){ if(i) fprintf(PostStream, ","); F_MHToTime0(k+i, &Value[i], &TmpValue, k, HarmonicToTime, &TimeMH) ; for(j = 0 ; j < 3 ; j++){ if(j) fprintf(PostStream, ","); fprintf(PostStream, "%.16g", TmpValue.Val[j]); } } } } if(TimeStep == NbTimeStep-1){ fprintf(PostStream, "};\n") ; } break ; case TENSOR_DIAG : case TENSOR_SYM : case TENSOR : if(TimeStep == 0){ switch(Type){ case POINT : fprintf(PostStream, "TP("); break; case LINE : fprintf(PostStream, "TL("); break; case TRIANGLE : fprintf(PostStream, "TT("); break; case QUADRANGLE : fprintf(PostStream, "TQ("); break; case TETRAHEDRON : fprintf(PostStream, "TS("); break; case HEXAHEDRON : fprintf(PostStream, "TH("); break; case PRISM : fprintf(PostStream, "TI("); break; case PYRAMID : fprintf(PostStream, "TY("); break; case LINE_2 : fprintf(PostStream, "TL("); break; case TRIANGLE_2 : fprintf(PostStream, "TT("); break; case QUADRANGLE_2: fprintf(PostStream, "TQ("); break; case QUADRANGLE_2_8N: fprintf(PostStream, "TQ("); break; } for(i = 0 ; i < NbrNodes ; i++){ if(i) fprintf(PostStream, ","); fprintf(PostStream, "%.16g,%.16g,%.16g", x[i], y[i], z[i]); } fprintf(PostStream, "){"); } if (HarmonicToTime == 1) { for(k = 0 ; k < NbHarmonic ; k++) { if(k || TimeStep) fprintf(PostStream, ","); for(i = 0 ; i < NbrNodes ; i++){ if(i) fprintf(PostStream, ","); for(j = 0 ; j < 9 ; j++){ if(j) fprintf(PostStream, ","); if(Value[0].Type != TENSOR_DIAG) { if(Value[0].Type == TENSOR_SYM) jj = symIndex[j]; else jj = j; fprintf(PostStream, "%.16g", Value[i].Val[MAX_DIM*k+jj]); } else { jj = diagIndex[j]; if(jj == -1) fprintf(PostStream, "%.16g", 0.); else fprintf(PostStream, "%.16g", Value[i].Val[MAX_DIM*k+jj]); } } } } } else { for(k = 0 ; k < HarmonicToTime ; k++){ if(k || TimeStep) fprintf(PostStream, ","); for(i = 0 ; i < NbrNodes ; i++){ if(i) fprintf(PostStream, ","); F_MHToTime0(k+i, &Value[i], &TmpValue, k, HarmonicToTime, &TimeMH) ; for(j = 0 ; j < 9 ; j++){ if(j) fprintf(PostStream, ","); if(Value[0].Type != TENSOR_DIAG) { if(Value[0].Type == TENSOR_SYM) jj = symIndex[j]; else jj = j; jj = symIndex[j]; fprintf(PostStream, "%.16g", TmpValue.Val[jj]); } else { jj = diagIndex[j]; if(jj == -1) fprintf(PostStream, "%.16g", 0.); else fprintf(PostStream, "%.16g", TmpValue.Val[jj]); } } } } } if(TimeStep == NbTimeStep-1){ fprintf(PostStream, "};\n") ; } break ; } } static void Gmsh_PrintElement(double Time, int TimeStep, int NbTimeStep, int NbHarmonic, int HarmonicToTime, int Type, int ElementNum, int NbrNodes, double *x, double *y, double *z, struct Value *Value, struct PostSubOperation *PSO_P, int Store) { int i,j,k,jj ; double TimeMH ; struct Value TmpValue ; static std::vector *Current_L ; int symIndex[9] = {0, 1, 2, 1, 3, 4, 2, 4, 5} ; int diagIndex[9] = {0, -1, -1, -1, 1, -1, -1, -1, 2} ; if(Gmsh_StartNewView){ Gmsh_StartNewView = 0 ; Gmsh_ResetStaticLists(); } switch (Value[0].Type) { case SCALAR : if(TimeStep == 0){ switch(Type){ case POINT : Current_L = &SP ; NbSP++ ; break ; case LINE : Current_L = &SL ; NbSL++ ; break ; case TRIANGLE : Current_L = &ST ; NbST++ ; break ; case QUADRANGLE : Current_L = &SQ ; NbSQ++ ; break ; case TETRAHEDRON : Current_L = &SS ; NbSS++ ; break ; case HEXAHEDRON : Current_L = &SH ; NbSH++ ; break ; case PRISM : Current_L = &SI ; NbSI++ ; break ; case PYRAMID : Current_L = &SY ; NbSY++ ; break ; case LINE_2 : Current_L = &SL ; NbSL++ ; break ; case TRIANGLE_2 : Current_L = &ST ; NbST++ ; break ; case QUADRANGLE_2: Current_L = &SQ ; NbSQ++ ; break ; case QUADRANGLE_2_8N: Current_L = &SQ ; NbSQ++ ; break ; } if(Flag_GMSH_VERSION != 2){ for(i = 0 ; i < NbrNodes ; i++) Current_L->push_back(x[i]); for(i = 0 ; i < NbrNodes ; i++) Current_L->push_back(y[i]); for(i = 0 ; i < NbrNodes ; i++) Current_L->push_back(z[i]); } else{ double tmp = ElementNum; Current_L->push_back(tmp); } } if (HarmonicToTime == 1) for(k = 0 ; k < NbHarmonic ; k++){ List_Put(TimeValue_L, NbHarmonic*TimeStep+k, &Time); for(i = 0 ; i < NbrNodes ; i++) Current_L->push_back(Value[i].Val[MAX_DIM*k]); } else for(k = 0 ; k < HarmonicToTime ; k++){ List_Put(TimeValue_L, HarmonicToTime*TimeStep+k, &Time); for(i = 0 ; i < NbrNodes ; i++){ F_MHToTime0(k+i, &Value[i], &TmpValue, k, HarmonicToTime, &TimeMH) ; Current_L->push_back(TmpValue.Val[0]); } } break ; case VECTOR : if(TimeStep == 0){ switch(Type){ case POINT : Current_L = &VP ; NbVP++ ; break ; case LINE : Current_L = &VL ; NbVL++ ; break ; case TRIANGLE : Current_L = &VT ; NbVT++ ; break ; case QUADRANGLE : Current_L = &VQ ; NbVQ++ ; break ; case TETRAHEDRON : Current_L = &VS ; NbVS++ ; break ; case HEXAHEDRON : Current_L = &VH ; NbVH++ ; break ; case PRISM : Current_L = &VI ; NbVI++ ; break ; case PYRAMID : Current_L = &VY ; NbVY++ ; break ; case LINE_2 : Current_L = &VL ; NbVL++ ; break ; case TRIANGLE_2 : Current_L = &VT ; NbVT++ ; break ; case QUADRANGLE_2: Current_L = &VQ ; NbVQ++ ; break ; case QUADRANGLE_2_8N: Current_L = &VQ ; NbVQ++ ; break ; } if(Flag_GMSH_VERSION != 2){ for(i = 0 ; i < NbrNodes ; i++) Current_L->push_back(x[i]); for(i = 0 ; i < NbrNodes ; i++) Current_L->push_back(y[i]); for(i = 0 ; i < NbrNodes ; i++) Current_L->push_back(z[i]); } else{ double tmp = ElementNum; Current_L->push_back(tmp); } } if (HarmonicToTime == 1) for(k = 0 ; k < NbHarmonic ; k++){ List_Put(TimeValue_L, NbHarmonic*TimeStep+k, &Time); for(i = 0 ; i < NbrNodes ; i++) for(j = 0 ; j < 3 ; j++) Current_L->push_back(Value[i].Val[MAX_DIM*k+j]); } else for(k = 0 ; k < HarmonicToTime ; k++){ List_Put(TimeValue_L, HarmonicToTime*TimeStep+k, &Time); for(i = 0 ; i < NbrNodes ; i++){ F_MHToTime0(k+i, &Value[i], &TmpValue, k, HarmonicToTime, &TimeMH) ; for(j = 0 ; j < 3 ; j++) Current_L->push_back(TmpValue.Val[j]); } } break ; case TENSOR_DIAG : case TENSOR_SYM : case TENSOR : if(TimeStep == 0){ switch(Type){ case POINT : Current_L = &TP ; NbTP++ ; break ; case LINE : Current_L = &TL ; NbTL++ ; break ; case TRIANGLE : Current_L = &TT ; NbTT++ ; break ; case QUADRANGLE : Current_L = &TQ ; NbTQ++ ; break ; case TETRAHEDRON : Current_L = &TS1 ; NbTS++ ; break ; case HEXAHEDRON : Current_L = &TH ; NbTH++ ; break ; case PRISM : Current_L = &TI ; NbTI++ ; break ; case PYRAMID : Current_L = &TY ; NbTY++ ; break ; case LINE_2 : Current_L = &TL ; NbTL++ ; break ; case TRIANGLE_2 : Current_L = &TT ; NbTT++ ; break ; case QUADRANGLE_2: Current_L = &TQ ; NbTQ++ ; break ; case QUADRANGLE_2_8N: Current_L = &TQ ; NbTQ++ ; break ; } if(Flag_GMSH_VERSION != 2){ for(i = 0 ; i < NbrNodes ; i++) Current_L->push_back(x[i]); for(i = 0 ; i < NbrNodes ; i++) Current_L->push_back(y[i]); for(i = 0 ; i < NbrNodes ; i++) Current_L->push_back(z[i]); } else{ double tmp = ElementNum; Current_L->push_back(tmp); } } if (HarmonicToTime == 1) for(k = 0 ; k < NbHarmonic ; k++){ List_Put(TimeValue_L, NbHarmonic*TimeStep+k, &Time); for(i = 0 ; i < NbrNodes ; i++){ for(j = 0 ; j < 9 ; j++){ if(Value[0].Type != TENSOR_DIAG) { if(Value[0].Type == TENSOR_SYM) jj = symIndex[j]; else jj = j; Current_L->push_back(Value[i].Val[MAX_DIM*k+jj]); } else { jj = diagIndex[j]; if(jj == -1) Current_L->push_back(0.); else Current_L->push_back(Value[i].Val[MAX_DIM*k+jj]); } } } } else for(k = 0 ; k < HarmonicToTime ; k++){ List_Put(TimeValue_L, HarmonicToTime*TimeStep+k, &Time); for(i = 0 ; i < NbrNodes ; i++){ F_MHToTime0(k+i, &Value[i], &TmpValue, k, HarmonicToTime, &TimeMH) ; for(j = 0 ; j < 9 ; j++) { if(Value[0].Type != TENSOR_DIAG) { if(Value[0].Type == TENSOR_SYM) jj = symIndex[j]; else jj = j; Current_L->push_back(TmpValue.Val[jj]); } else { jj = diagIndex[j]; if(jj == -1) Current_L->push_back(0.); else Current_L->push_back(TmpValue.Val[jj]); } } } } } // reduce memory requirements by automatically partitioning large // output views into chunks not larger than 1Gb if(Flag_GMSH_VERSION == 2 && TimeStep == NbTimeStep - 1 && Current_L->size() > (int)(1024 * 1024 * 1024 / sizeof(double))){ Format_PostFooter(PSO_P, Store); CurrentPartitionNumber++; Gmsh_StartNewView = 1; } } static void dVecWrite(std::vector &v, FILE *fp, bool binary) { if(v.empty()) return; if(binary) fwrite(&v[0], sizeof(double), v.size(), fp); else for(unsigned i = 0; i < v.size(); i++) fprintf(fp, " %.16g", v[i]); } static void cVecWrite(std::vector &v, FILE *fp, bool binary) { if(v.empty()) return; if(binary) fwrite(&v[0], sizeof(char), v.size(), fp); else for(unsigned i = 0; i < v.size(); i++) fputc(v[i], fp); } /* ------------------------------------------------------------------------ */ /* Gnuplot format */ /* ------------------------------------------------------------------------ */ static void Gnuplot_PrintElement(int Format, double Time, int TimeStep, int NbrTimeSteps, int NbrHarmonics, int HarmonicToTime, int ElementType, int NumElement, int NbrNodes, double *x, double *y, double *z, double *Dummy, struct Value *Value) { static int Size, TmpIndex ; static double * TmpValues ; int i, j, k, t, i2, k2 ; double TimeMH ; struct Value TmpValue ; if(TimeStep == 0){ switch(Value->Type){ case SCALAR : Size = 1 ; break ; case VECTOR : Size = 3 ; break ; case TENSOR_DIAG : Size = 3 ; break ; case TENSOR_SYM : Size = 6 ; break ; case TENSOR : Size = 9 ; break ; } TmpValues = (double*) Malloc(NbrTimeSteps*NbrNodes*NbrHarmonics*Size*sizeof(double)); TmpIndex = 0; } for(i = 0 ; i < NbrNodes ; i++) for(k = 0 ; k < NbrHarmonics ; k++) for(j = 0 ; j < Size ; j++) TmpValues[TmpIndex++] = Value[i].Val[MAX_DIM*k+j]; if(TimeStep == NbrTimeSteps-1){ for(i = 0 ; i <= NbrNodes ; i++){ /* New line for each node, closed loop for tri/qua */ if(i != NbrNodes) i2 = i ; else{ if(NbrNodes < 3) break ; else i2 = 0 ; } fprintf(PostStream, "%d %d ", Gmsh_GetElementType(ElementType), NumElement); fprintf(PostStream, " %.16g %.16g %.16g ", x[i2], y[i2], z[i2]); if(Dummy){ if(Dummy[3]<0){ if(!i) fprintf(PostStream, " %.16g %.16g 0 ", Dummy[0], Dummy[2]); else fprintf(PostStream, " %.16g %.16g 0 ", Dummy[1], Dummy[2]); } else fprintf(PostStream, " %.16g %.16g %.16g ", Dummy[0], Dummy[1], Dummy[2]); } else fprintf(PostStream, " 0 0 0 "); for(t = 0 ; t < NbrTimeSteps ; t++){ if (HarmonicToTime == 1) { for(k = 0 ; k < NbrHarmonics ; k++) { for(j = 0 ; j < Size ; j++){ fprintf(PostStream, " %.16g", TmpValues[ t*NbrNodes*NbrHarmonics*Size + i2*NbrHarmonics*Size + k*Size + j ]); } fprintf(PostStream, " "); } } else { TmpValue.Type = Value->Type ; for(k = 0 ; k < HarmonicToTime ; k++){ for(k2 = 0 ; k2 < NbrHarmonics ; k2++) for(j = 0 ; j < Size ; j++) TmpValue.Val[MAX_DIM*k2+j] = TmpValues[ t*NbrNodes*NbrHarmonics*Size + i2*NbrHarmonics*Size + k2*Size + j ] ; F_MHToTime0(k, &TmpValue, &TmpValue, k, HarmonicToTime, &TimeMH) ; for(j = 0 ; j < Size ; j++) fprintf(PostStream, "%.16g", TmpValue.Val[0]); fprintf(PostStream, " "); } } fprintf(PostStream, " "); } /* for t */ fprintf(PostStream, "\n"); } /* for i */ if(NbrNodes > 1) fprintf(PostStream, "\n"); Free(TmpValues); } } /* ------------------------------------------------------------------------ */ /* Tabular format */ /* ------------------------------------------------------------------------ */ static void Tabular_PrintElement(struct PostSubOperation *PSO_P, int Format, double Time, int TimeStep, int NbrTimeSteps, int NbrHarmonics, int HarmonicToTime, int ElementType, int NumElement, int NbrNodes, double *x, double *y, double *z, double *Dummy, struct Value *Value) { static int Size ; int i,j,k ; double TimeMH ; struct Value TmpValue ; if(TimeStep == 0){ switch(Value->Type){ case SCALAR : Size = 1 ; break ; case VECTOR : Size = 3 ; break ; case TENSOR_DIAG : Size = 3 ; break ; case TENSOR_SYM : Size = 6 ; break ; case TENSOR : Size = 9 ; break ; } } if(Format == FORMAT_SPACE_TABLE || Format == FORMAT_SIMPLE_SPACE_TABLE || Format == FORMAT_VALUE_ONLY){ if(TimeStep == 0){ if(Format != FORMAT_SIMPLE_SPACE_TABLE && Format != FORMAT_VALUE_ONLY) fprintf(PostStream, "%d %d ", Gmsh_GetElementType(ElementType), NumElement); if(Format != FORMAT_VALUE_ONLY) for(i=0 ; iValueName, j, PSO_P->ValueIndex, Value[i].Val[MAX_DIM*k+j]); if (j > NodeTable; static void NodeTable_PrintElement(int TimeStep, int NbTimeStep, int NbrHarmonics, struct PostElement *PE) { if(NodeTable_StartNew){ NodeTable_StartNew = 0 ; NodeTable.clear(); } for(int i = 0 ; i < PE->NbrNodes ; i++){ int n = PE->NumNodes[i]; int Size = 0; switch(PE->Value[0].Type){ case SCALAR : Size = 1 ; break ; case VECTOR : Size = 3 ; break ; case TENSOR_DIAG : Size = 3 ; break ; case TENSOR_SYM : Size = 6 ; break ; case TENSOR : Size = 9 ; break ; } if(n > 0 && Size){ // we have data on an actual node NodeTable[n].resize(NbTimeStep * NbrHarmonics * Size, 0.); for(int k = 0 ; k < NbrHarmonics ; k++){ for(int j = 0 ; j < Size ; j++){ double val = PE->Value[i].Val[MAX_DIM * k + j]; int idx = NbrHarmonics * Size * TimeStep + k * Size + j; NodeTable[n][idx] = val; } } } } } /* ------------------------------------------------------------------------ */ /* S t o r e P o s t O p R e s u l t */ /* ------------------------------------------------------------------------ */ static List_T *PostOpResults_L=NULL; static void StorePostOpResult(int NbrHarmonics, struct PostElement *PE) { int Size; double val; if(!PostOpResults_L) PostOpResults_L = List_Create(1000,1000,sizeof(double)); for(int i = 0 ; i < PE->NbrNodes ; i++){ Size = 0; switch(PE->Value[0].Type){ case SCALAR : Size = 1 ; break ; case VECTOR : Size = 3 ; break ; case TENSOR_DIAG : Size = 3 ; break ; case TENSOR_SYM : Size = 6 ; break ; case TENSOR : Size = 9 ; break ; } if(Size){ // we have data for(int k = 0 ; k < NbrHarmonics ; k++){ for(int j = 0 ; j < Size ; j++){ val = PE->Value[i].Val[MAX_DIM * k + j]; List_Add(PostOpResults_L, &val); } } } } } static void StorePostOpResult(int NbrHarmonics, struct Value *Value) { int Size; double val; if(!PostOpResults_L) PostOpResults_L = List_Create(1000,1000,sizeof(double)); Size = 0; switch(Value[0].Type){ case SCALAR : Size = 1 ; break ; case VECTOR : Size = 3 ; break ; case TENSOR_DIAG : Size = 3 ; break ; case TENSOR_SYM : Size = 6 ; break ; case TENSOR : Size = 9 ; break ; } if(Size){ // we have data for(int k = 0 ; k < NbrHarmonics ; k++){ for(int j = 0 ; j < Size ; j++){ val = Value[0].Val[MAX_DIM * k + j]; List_Add(PostOpResults_L, &val); } } } } /* ------------------------------------------------------------------------ */ /* UNV format */ /* ------------------------------------------------------------------------ */ #if !defined(HAVE_NX) #define NX { Message::Error("UNV export not available in this version"); } #else #define NX ; #endif void Unv_PrintHeader(FILE *PostStream, char *name, int SubType, double Time, int TimeStep) NX void Unv_PrintFooter(FILE *PostStream) NX void Unv_PrintElement(FILE *PostStream, int Num_Element, int NbrNodes, struct Value *Value) NX void Unv_PrintRegion(FILE *PostStream, int Flag_Comma, int numRegion, int NbrHarmonics, int Size, struct Value *Value) NX #undef NX /* ------------------------------------------------------------------------ */ /* F o r m a t _ P o s t F o r m a t */ /* ------------------------------------------------------------------------ */ void Format_PostFormat(struct PostSubOperation *PSO_P) { int Format = PSO_P->Format; int NoMesh = PSO_P->NoMesh; switch(Format){ case FORMAT_GMSH : if(PSO_P->StoreInField >= 0 && !PSO_P->FileOut) break; if(Flag_GMSH_VERSION == 2){ fprintf(PostStream, "$MeshFormat\n") ; fprintf(PostStream, "2.2 %d %d\n", Flag_BIN, (int)sizeof(double)) ; if(Flag_BIN){ int one=1; fwrite(&one, sizeof(int), 1, PostStream); fprintf(PostStream, "\n"); } fprintf(PostStream, "$EndMeshFormat\n") ; if(!NoMesh){ fprintf(PostStream, "$Nodes\n%d\n", List_Nbr(Current.GeoData->Nodes)); for (int i = 0 ; i < List_Nbr(Current.GeoData->Nodes) ; i++) { struct Geo_Node Geo_Node ; List_Read(Current.GeoData->Nodes, i, &Geo_Node) ; if(Flag_BIN){ fwrite(&Geo_Node.Num, sizeof(int), 1, PostStream); double data[3] = {Geo_Node.x, Geo_Node.y, Geo_Node.z}; fwrite(data, sizeof(double), 3, PostStream); } else{ fprintf(PostStream, "%d %.16g %.16g %.16g\n", Geo_Node.Num, Geo_Node.x, Geo_Node.y, Geo_Node.z) ; } } fprintf(PostStream, "$EndNodes\n$Elements\n%d\n", List_Nbr(Current.GeoData->Elements)); for (int i = 0 ; i < List_Nbr(Current.GeoData->Elements) ; i++) { struct Geo_Element Geo_Element ; List_Read(Current.GeoData->Elements, i, &Geo_Element) ; int Type = Geo_GetElementTypeInv(FORMAT_GMSH, Geo_Element.Type) ; if(Flag_BIN){ int blob[6] = {Type, 1, 2, Geo_Element.Num, Geo_Element.Region, Geo_Element.ElementaryRegion}; fwrite(blob, sizeof(int), 6, PostStream); std::vector verts(Geo_Element.NbrNodes); for (int j = 0 ; j < Geo_Element.NbrNodes ; j++) verts[j] = Geo_Element.NumNodes[j] ; fwrite(&verts[0], sizeof(int), Geo_Element.NbrNodes, PostStream); } else{ fprintf(PostStream, "%d %d 2 %d %d ", Geo_Element.Num, Type, Geo_Element.Region, Geo_Element.ElementaryRegion) ; for (int j = 0 ; j < Geo_Element.NbrNodes ; j++) fprintf(PostStream, "%d ", Geo_Element.NumNodes[j]) ; fprintf(PostStream, "\n") ; } } fprintf(PostStream, "$EndElements\n"); } } else if(Flag_BIN){/* bricolage */ fprintf(PostStream, "$PostFormat /* Gmsh 1.2, %s */\n", Flag_BIN ? "binary" : "ascii") ; fprintf(PostStream, "1.2 %d %d\n", Flag_BIN, (int)sizeof(double)) ; fprintf(PostStream, "$EndPostFormat\n") ; } break ; case FORMAT_GNUPLOT : fprintf(PostStream, "# GetDP %s, %s\n", GETDP_VERSION, Flag_BIN ? "binary" : "ascii") ; break ; } } /* ------------------------------------------------------------------------ */ /* F o r m a t _ P o s t H e a d e r */ /* ------------------------------------------------------------------------ */ void Format_PostHeader(struct PostSubOperation *PSO_P, int NbTimeStep, int Order, char *Name1, char *Name2) { int Format = PSO_P->Format; int SubType = PSO_P->SubType; double Time = Current.Time; int TimeStep = Current.TimeStep; int Contour = PSO_P->Iso; int Type = PSO_P->CombinationType; char name[256] ; CurrentPartitionNumber = 0; if(Contour){ if(!PostElement_L) PostElement_L = List_Create(20, 20, sizeof(struct PostElement*)); else List_Reset(PostElement_L); } if(Name1 && Name2) { strcpy(name, Order ? Name1 : Name2) ; strcat(name, Get_StringForDefine(PostSubOperation_CombinationType, Type)) ; strcat(name, Order ? Name2 : Name1) ; } else if(Name1) strcpy(name, Name1) ; else if(Name2) strcpy(name, Name2) ; else strcpy(name, "unnamed"); strcpy(CurrentName, name); switch(Format){ case FORMAT_GMSH_PARSED : fprintf(PostStream, "View \"%s\" {\n", name) ; Gmsh_StartNewView = 1 ; break ; case FORMAT_GMSH : Gmsh_StartNewView = 1 ; if(PSO_P->StoreInField >= 0 && !PSO_P->FileOut) break; if(Flag_GMSH_VERSION != 2){ if(Flag_BIN){ /* bricolage */ fprintf(PostStream, "$View /* %s */\n", name); fprintf(PostStream, "%s ", name); } else { fprintf(PostStream, "View \"%s\" {\n", name) ; } } break ; case FORMAT_UNV : Unv_PrintHeader(PostStream, name, SubType, Time, TimeStep); break ; case FORMAT_GNUPLOT : fprintf(PostStream, "# PostData '%s'\n", name); fprintf(PostStream, "# Type Num X Y Z N1 N2 N3 Values ...\n"); break ; case FORMAT_NODE_TABLE : NodeTable_StartNew = 1 ; break ; case FORMAT_ADAPT : fprintf(PostStream, "$Adapt /* %s */\n", name) ; break ; } } /* ------------------------------------------------------------------------ */ /* F o r m a t _ P o s t F o o t e r */ /* ------------------------------------------------------------------------ */ void Format_PostFooter(struct PostSubOperation *PSO_P, int Store) { List_T *Iso_L[NBR_MAX_ISO], *Solutions_L; double IsoMin = 1.e200, IsoMax = -1.e200, IsoVal = 0.0, freq, valr, vali ; int NbrIso = 0 ; int iPost, iNode, iIso, iTime, One=1, i, j, NbTimeStep ; char tmp[1024]; bool PostOpSolutionGenerated; struct PostElement *PE ; struct Solution *Solution_P=NULL, Solution_S; if( !(NbTimeStep = List_Nbr(PSO_P->TimeStep_L)) ) NbTimeStep = List_Nbr(Current.DofData->Solutions); if ( (PSO_P->Format == FORMAT_GMSH || PSO_P->Format == FORMAT_GMSH_PARSED) && Flag_GMSH_VERSION != 2 ){ switch(PSO_P->Legend){ case LEGEND_TIME: Gmsh_StringStart(PSO_P->Format, PSO_P->LegendPosition[0], PSO_P->LegendPosition[1], PSO_P->LegendPosition[2]); for (i = 0 ; i < NbTimeStep ; i++) { Pos_InitAllSolutions(PSO_P->TimeStep_L, i) ; valr = Current.DofData->CurrentSolution->Time ; for (j = 0 ; j < Current.NbrHar ; j++){ sprintf(tmp, "Step %d/%d: Time = %g", i+1, NbTimeStep, valr); Gmsh_StringAdd(PSO_P->Format, (!i && !j), tmp); } } Gmsh_StringEnd(PSO_P->Format); break; case LEGEND_FREQUENCY: if(Current.NbrHar > 1) { Gmsh_StringStart(PSO_P->Format, PSO_P->LegendPosition[0], PSO_P->LegendPosition[1], PSO_P->LegendPosition[2]); for (i = 0 ; i < NbTimeStep ; i++) { Pos_InitAllSolutions(PSO_P->TimeStep_L, i) ; for (j = 0 ; j < Current.NbrHar ; j+=2) { freq = 0.5*Current.DofData->Val_Pulsation[j/2]/M_PI ; sprintf(tmp, "%g Hz (Real Part: COSINUS)", freq); Gmsh_StringAdd(PSO_P->Format, (!i && !j), tmp); sprintf(tmp, "%g Hz (Imaginary Part: -SINUS)", freq); Gmsh_StringAdd(PSO_P->Format, 0, tmp); } } Gmsh_StringEnd(PSO_P->Format); } break; case LEGEND_EIGENVALUES: Gmsh_StringStart(PSO_P->Format, PSO_P->LegendPosition[0], PSO_P->LegendPosition[1], PSO_P->LegendPosition[2]); for (i = 0 ; i < NbTimeStep ; i++) { Pos_InitAllSolutions(PSO_P->TimeStep_L, i) ; valr = Current.DofData->CurrentSolution->Time ; vali = Current.DofData->CurrentSolution->TimeImag ; for (j = 0 ; j < Current.NbrHar ; j+=2) { sprintf(tmp, "Eigenvalue %d/%d: %g %s i * %g (Real Part)", i+1, NbTimeStep, valr, (vali > 0) ? "+" : "-", (vali > 0) ? vali : -vali); Gmsh_StringAdd(PSO_P->Format, (!i && !j), tmp); sprintf(tmp, "Eigenvalue %d/%d: %g %s i * %g (Imaginary Part)", i+1, NbTimeStep, valr, (vali > 0) ? "+" : "-", (vali > 0) ? vali : -vali); Gmsh_StringAdd(PSO_P->Format, 0, tmp); } } Gmsh_StringEnd(PSO_P->Format); break; } } if(PSO_P->Iso){ for(iPost = 0 ; iPost < List_Nbr(PostElement_L) ; iPost++){ PE = *(struct PostElement**)List_Pointer(PostElement_L, iPost); for (iNode = 0 ; iNode < PE->NbrNodes ; iNode++ ){ IsoMin = std::min(IsoMin, PE->Value[iNode].Val[0]) ; IsoMax = std::max(IsoMax, PE->Value[iNode].Val[0]) ; } } if((NbrIso = PSO_P->Iso) < 0) NbrIso = List_Nbr(PSO_P->Iso_L) ; if(NbrIso > NBR_MAX_ISO){ Message::Error("Too many Iso values"); NbrIso = NBR_MAX_ISO; } if(PSO_P->Format == FORMAT_GNUPLOT) fprintf(PostStream, "# NbIso = %d, Min = %g, Max = %g\n", NbrIso, IsoMin, IsoMax) ; for(iIso = 0 ; iIso < NbrIso ; iIso++) Iso_L[iIso] = List_Create(10, 10, sizeof(struct PostElement*)) ; for(iPost = 0 ; iPost < List_Nbr(PostElement_L) ; iPost++){ PE = *(struct PostElement**)List_Pointer(PostElement_L, iPost); for(iIso = 0 ; iIso < NbrIso ; iIso++){ if(PSO_P->Iso > 0){ Cal_Iso(PE, Iso_L[iIso], IsoMin+iIso*(IsoMax-IsoMin)/(double)(NbrIso-1), IsoMin, IsoMax, PSO_P->DecomposeInSimplex) ; } else{ List_Read(PSO_P->Iso_L, iIso, &IsoVal) ; Cal_Iso(PE, Iso_L[iIso], IsoVal, IsoMin, IsoMax, PSO_P->DecomposeInSimplex) ; } } if(!Store) Destroy_PostElement(PE); } for(iIso = 0 ; iIso < NbrIso ; iIso++){ for(iPost = 0 ; iPost < List_Nbr(Iso_L[iIso]) ; iPost++){ PE = *(struct PostElement**)List_Pointer(Iso_L[iIso], iPost) ; Format_PostElement(PSO_P, 0, 0, Current.Time, 0, 1, Current.NbrHar, PSO_P->HarmonicToTime, NULL, PE); Destroy_PostElement(PE) ; } List_Delete(Iso_L[iIso]) ; if(PSO_P->Format == FORMAT_GNUPLOT) fprintf(PostStream, "\n") ; } } switch(PSO_P->Format){ case FORMAT_GMSH_PARSED : if(List_Nbr(TimeValue_L) > 1){ fprintf(PostStream, "TIME{"); for(iTime = 0; iTime < List_Nbr(TimeValue_L); iTime++){ if(iTime) fprintf(PostStream, ","); fprintf(PostStream, "%.16g", *(double*)List_Pointer(TimeValue_L, iTime)); } fprintf(PostStream, "};\n"); } fprintf(PostStream, "};\n") ; break ; case FORMAT_GMSH : if(Gmsh_StartNewView) Gmsh_ResetStaticLists(); // nothing to print! if(PSO_P->StoreInField >= 0){ #if defined(HAVE_GMSH) Message::Info("Storing data in field %d", PSO_P->StoreInField); int NS[24] = {NbSP, NbVP, NbTP, NbSL, NbVL, NbTL, NbST, NbVT, NbTT, NbSQ, NbVQ, NbTQ, NbSS, NbVS, NbTS, NbSH, NbVH, NbTH, NbSI, NbVI, NbTI, NbSY, NbVY, NbTY}; std::vector *LS[24] = {&SP, &VP, &TP, &SL, &VL, &TL, &ST, &VT, &TT, &SQ, &VQ, &TQ, &SS, &VS, &TS1, &SH, &VH, &TH, &SI, &VI, &TI, &SY, &VY, &TY}; PView *v = new PView(PSO_P->StoreInField); v->getData()->importLists(NS, LS); #else Message::Error("GetDP must be compiled with Gmsh support to store data as field"); #endif if(!PSO_P->FileOut) break; } if(Flag_GMSH_VERSION == 2){ int NS[8] = {NbSP, NbSL, NbST, NbSQ, NbSS, NbSH, NbSI, NbSY}; std::vector *LS[8] = {&SP, &SL, &ST, &SQ, &SS, &SH, &SI, &SY}; Gmsh_PrintElementNodeData(PSO_P, NbTimeStep, 1, NS, LS); int NV[8] = {NbVP, NbVL, NbVT, NbVQ, NbVS, NbVH, NbVI, NbVY}; std::vector *LV[8] = {&VP, &VL, &VT, &VQ, &VS, &VH, &VI, &VY}; Gmsh_PrintElementNodeData(PSO_P, NbTimeStep, 3, NV, LV); int NT[8] = {NbTP, NbTL, NbTT, NbTQ, NbTS, NbTH, NbTI, NbTY}; std::vector *LT[8] = {&TP, &TL, &TT, &TQ, &TS1, &TH, &TI, &TY}; Gmsh_PrintElementNodeData(PSO_P, NbTimeStep, 9, NT, LT); } else if(Flag_BIN){ /* bricolage */ fprintf(PostStream, "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d " "%d %d %d %d %d %d %d %d %d %d %d 0 0\n", List_Nbr(TimeValue_L), NbSP, NbVP, NbTP, NbSL, NbVL, NbTL, NbST, NbVT, NbTT, NbSQ, NbVQ, NbTQ, NbSS, NbVS, NbTS, NbSH, NbVH, NbTH, NbSI, NbVI, NbTI, NbSY, NbVY, NbTY, NbT2, (int)T2C.size()); fwrite(&One, sizeof(int), 1, PostStream); List_WriteToFile(TimeValue_L, PostStream, LIST_FORMAT_BINARY); bool f = true; dVecWrite(SP, PostStream, f); dVecWrite(VP, PostStream, f); dVecWrite(TP, PostStream, f); dVecWrite(SL, PostStream, f); dVecWrite(VL, PostStream, f); dVecWrite(TL, PostStream, f); dVecWrite(ST, PostStream, f); dVecWrite(VT, PostStream, f); dVecWrite(TT, PostStream, f); dVecWrite(SQ, PostStream, f); dVecWrite(VQ, PostStream, f); dVecWrite(TQ, PostStream, f); dVecWrite(SS, PostStream, f); dVecWrite(VS, PostStream, f); dVecWrite(TS1, PostStream, f); dVecWrite(SH, PostStream, f); dVecWrite(VH, PostStream, f); dVecWrite(TH, PostStream, f); dVecWrite(SI, PostStream, f); dVecWrite(VI, PostStream, f); dVecWrite(TI, PostStream, f); dVecWrite(SY, PostStream, f); dVecWrite(VY, PostStream, f); dVecWrite(TY, PostStream, f); dVecWrite(T2D, PostStream, f); cVecWrite(T2C, PostStream, f); fprintf(PostStream, "\n"); fprintf(PostStream, "$EndView\n"); } else{ if(List_Nbr(TimeValue_L) > 1){ fprintf(PostStream, "TIME{"); for(iTime = 0; iTime < List_Nbr(TimeValue_L); iTime++){ if(iTime) fprintf(PostStream, ","); fprintf(PostStream, "%.16g", *(double*)List_Pointer(TimeValue_L, iTime)); } fprintf(PostStream, "};\n"); } fprintf(PostStream, "};\n") ; } break ; case FORMAT_ADAPT : fprintf(PostStream, "$EndAdapt\n"); break ; case FORMAT_UNV : Unv_PrintFooter(PostStream); break ; case FORMAT_NODE_TABLE : fprintf(PostStream, "%d\n", (int)NodeTable.size()); for(std::map >::iterator it = NodeTable.begin(); it != NodeTable.end(); it++){ fprintf(PostStream, "%d", it->first); for(unsigned int i = 0; i < it->second.size(); i++) fprintf(PostStream, " %.16g", it->second[i]); fprintf(PostStream, "\n"); } break; case FORMAT_LOOP_ERROR : Solutions_L = ((struct PostOpSolutions*) List_Pointer(Current.PostOpData_L, Current.PostOpDataIndex))->Solutions_L; PostOpSolutionGenerated = false; if(List_Nbr(Solutions_L)>0) { Solution_P = (struct Solution*)List_Pointer(Solutions_L, List_Nbr(Solutions_L)-1); PostOpSolutionGenerated = (Solution_P->TimeStep == (int)Current.TimeStep); } if (!PostOpSolutionGenerated) { Solution_S.Time = Current.Time; Solution_S.TimeImag = Current.TimeImag; Solution_S.TimeStep = Current.TimeStep; Solution_S.SolutionExist = 1; Solution_S.TimeFunctionValues = NULL; LinAlg_CreateVector(&Solution_S.x, &Current.DofData->Solver, List_Nbr(PostOpResults_L)); for(int i=0; ix, i); } List_Delete(PostOpResults_L); PostOpResults_L = NULL; break; } } /* ------------------------------------------------------------------------ */ /* F o r m a t _ P o s t E l e m e n t */ /* ------------------------------------------------------------------------ */ void Format_PostElement(struct PostSubOperation *PSO_P, int Contour, int Store, double Time, int TimeStep, int NbTimeStep, int NbrHarmonics, int HarmonicToTime, double *Dummy, struct PostElement * PE) { int i, j, k, l, Num_Element ; struct PostElement * PE2 ; struct Value Value ; static int Warning_FirstHarmonic = 0 ; if(PE->Index != NO_ELEMENT) Num_Element = Geo_GetGeoElement(PE->Index)->Num ; else Num_Element = 0 ; if(Contour){ if(PE->Value[0].Type != SCALAR){ Message::Error("Non scalar Element %d in contour creation", Num_Element); return; } if(NbTimeStep != 1){ Message::Error("Contour creation not allowed for multiple time steps"); return; } if(Current.NbrHar != 1 && !Warning_FirstHarmonic){ Message::Warning("Contour creation done only for first harmonic (use Re[] or Im[])"); Warning_FirstHarmonic = 1 ; } if(Store) List_Add(PostElement_L, &PE) ; else{ PE2 = PartialCopy_PostElement(PE) ; List_Add(PostElement_L, &PE2) ; } return ; } if(PSO_P->ChangeOfCoordinates && PSO_P->ChangeOfCoordinates[0] >= 0){ for(i=0 ; iNbrNodes ; i++){ Current.x = PE->x[i]; Current.y = PE->y[i]; Current.z = PE->z[i]; for(j = 0; j<9 ; j++) Current.Val[j] = PE->Value[i].Val[j]; Get_ValueOfExpressionByIndex(PSO_P->ChangeOfCoordinates[0], NULL, 0., 0., 0., &Value) ; PE->x[i] = Value.Val[0]; Get_ValueOfExpressionByIndex(PSO_P->ChangeOfCoordinates[1], NULL, 0., 0., 0., &Value) ; PE->y[i] = Value.Val[0]; Get_ValueOfExpressionByIndex(PSO_P->ChangeOfCoordinates[2], NULL, 0., 0., 0., &Value) ; PE->z[i] = Value.Val[0]; } } if(PSO_P->ChangeOfValues && List_Nbr(PSO_P->ChangeOfValues) > 0){ for(i=0 ; iNbrNodes ; i++){ Current.x = PE->x[i]; Current.y = PE->y[i]; Current.z = PE->z[i]; for(k=0 ; kValue[i].Val[MAX_DIM*k+j]; for(l=0 ; lChangeOfValues) ; l++){ Get_ValueOfExpressionByIndex(*(int*)List_Pointer(PSO_P->ChangeOfValues, l), NULL, 0., 0., 0., &Value) ; PE->Value[i].Val[MAX_DIM*k+l] = Value.Val[0]; } } } } switch(PSO_P->Format){ case FORMAT_GMSH_PARSED : GmshParsed_PrintElement(Time, TimeStep, NbTimeStep, NbrHarmonics, HarmonicToTime, PE->Type, PE->NbrNodes, PE->x, PE->y, PE->z, PE->Value) ; break ; case FORMAT_UNV : Unv_PrintElement(PostStream, Num_Element, PE->NbrNodes, PE->Value) ; break ; case FORMAT_GMSH : if(PSO_P->StoreInField >= 0){ Gmsh_PrintElement(Time, TimeStep, NbTimeStep, NbrHarmonics, HarmonicToTime, PE->Type, Num_Element, PE->NbrNodes, PE->x, PE->y, PE->z, PE->Value, PSO_P, Store) ; if(!PSO_P->FileOut || Flag_GMSH_VERSION == 2 || Flag_BIN) break; } if(Flag_GMSH_VERSION == 2 || Flag_BIN){ /* bricolage */ Gmsh_PrintElement(Time, TimeStep, NbTimeStep, NbrHarmonics, HarmonicToTime, PE->Type, Num_Element, PE->NbrNodes, PE->x, PE->y, PE->z, PE->Value, PSO_P, Store) ; } else{ GmshParsed_PrintElement(Time, TimeStep, NbTimeStep, NbrHarmonics, HarmonicToTime, PE->Type, PE->NbrNodes, PE->x, PE->y, PE->z, PE->Value) ; } break ; case FORMAT_GNUPLOT : Gnuplot_PrintElement(PSO_P->Format, Time, TimeStep, NbTimeStep, NbrHarmonics, HarmonicToTime, PE->Type, Num_Element, PE->NbrNodes, PE->x, PE->y, PE->z, Dummy, PE->Value) ; break ; case FORMAT_SPACE_TABLE : case FORMAT_TIME_TABLE : case FORMAT_SIMPLE_SPACE_TABLE : case FORMAT_VALUE_ONLY : Tabular_PrintElement(PSO_P, PSO_P->Format, Time, TimeStep, NbTimeStep, NbrHarmonics, HarmonicToTime, PE->Type, Num_Element, PE->NbrNodes, PE->x, PE->y, PE->z, Dummy, PE->Value) ; break ; case FORMAT_NODE_TABLE : NodeTable_PrintElement(TimeStep, NbTimeStep, NbrHarmonics, PE); break; case FORMAT_LOOP_ERROR : StorePostOpResult(NbrHarmonics, PE); break; case FORMAT_ADAPT: { if(Dummy[4]) fprintf(PostStream, "%d\n", (int)Dummy[4]) ; fprintf(PostStream, "%d %g %g %g\n", (int)Dummy[0], Dummy[1], Dummy[2], Dummy[3]); } break ; default : Message::Error("Unknown format in Format_PostElement"); } } /* ------------------------------------------------------------------------ */ /* F o r m a t _ P o s t V a l u e */ /* ------------------------------------------------------------------------ */ void Format_PostValue(int Format, int Flag_Comma, int Group_FunctionType, double Time, int iRegion, int numRegion, int NbrRegion, int NbrHarmonics, int HarmonicToTime, int Flag_NoNewLine, struct Value * Value) { static int Size ; int j, k ; double TimeMH, Freq ; double x, y, z ; static struct Value TmpValue, *TmpValues ; if(iRegion == 0){ switch(Value->Type){ case SCALAR : Size = 1 ; break ; case VECTOR : Size = 3 ; break ; case TENSOR_DIAG : Size = 3 ; break ; case TENSOR_SYM : Size = 6 ; break ; case TENSOR : Size = 9 ; break ; } } if (Format == FORMAT_REGION_TABLE) { if(iRegion == 0){ if(PostStream == stdout || PostStream == stderr) Message::Direct("%d", NbrRegion); else fprintf(PostStream, "%d\n", NbrRegion) ; } std::ostringstream sstream; sstream.precision(16); sstream << numRegion; for (k = 0 ; k < NbrHarmonics ; k++) { for(j = 0 ; j < Size ; j++) { if (Flag_Comma) sstream << ","; sstream << " " << Value->Val[MAX_DIM*k+j] ; } } if(PostStream == stdout || PostStream == stderr) Message::Direct(sstream.str().c_str()); else fprintf(PostStream, "%s\n", sstream.str().c_str()) ; } else if (Format == FORMAT_GMSH && Flag_GMSH_VERSION != 2) { if (Group_FunctionType == NODESOF) Geo_GetNodesCoordinates(1, &numRegion, &x, &y, &z) ; else { x = y = z = 0.; Message::Warning("Post Format \'Gmsh\' not adapted for global quantities supported" " by Regions. Zero coordinates are considered.") ; } GmshParsed_PrintElement(Time, 0, 1, NbrHarmonics, HarmonicToTime, POINT, 1, &x, &y, &z, Value) ; } else if (Format == FORMAT_UNV) { Unv_PrintRegion(PostStream, Flag_Comma, numRegion, NbrHarmonics, Size, Value); } else if (Format == FORMAT_LOOP_ERROR) { StorePostOpResult(NbrHarmonics, Value); } else { if(iRegion == 0){ TmpValues = (struct Value*) Malloc(NbrRegion*sizeof(struct Value)) ; } Cal_CopyValue(Value, &TmpValues[iRegion]) ; if (iRegion == NbrRegion-1) { if (HarmonicToTime == 1) { switch (Format) { case FORMAT_FREQUENCY_TABLE : if (NbrHarmonics == 1){ Message::Error("FrequencyTable format not allowed (only one harmonic)") ; return; } break ; case FORMAT_VALUE_ONLY : break; default : fprintf(PostStream, "%.16g ", Time) ; break ; } for (iRegion = 0 ; iRegion < NbrRegion ; iRegion++) for (k = 0 ; k < NbrHarmonics ; k++) { if (Format == FORMAT_FREQUENCY_TABLE && !(k%2) && iRegion==0) { Freq = Current.DofData->Val_Pulsation[0] / TWO_PI ; fprintf(PostStream, "%.16g ", Freq) ; } for(j = 0 ; j < Size ; j++) if (Format != FORMAT_REGION_VALUE) fprintf(PostStream, " %.16g", TmpValues[iRegion].Val[MAX_DIM*k+j]) ; } if (Flag_NoNewLine || Format == FORMAT_REGION_VALUE) fprintf(PostStream, " ") ; else fprintf(PostStream, "\n") ; } else { for(k = 0 ; k < HarmonicToTime ; k++) { for (iRegion = 0 ; iRegion < NbrRegion ; iRegion++) { F_MHToTime0(k+iRegion, &TmpValues[iRegion], &TmpValue, k, HarmonicToTime, &TimeMH) ; if (iRegion == 0) fprintf(PostStream, "%.16g ", TimeMH) ; for(j = 0 ; j < Size ; j++) fprintf(PostStream, " %.16g", TmpValue.Val[j]) ; } fprintf(PostStream, "\n") ; } } Free(TmpValues) ; } } } getdp-2.4.2-source/Legacy/BF_Edge_4.cpp000644 001750 001750 00000013133 12116424202 021141 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "ProData.h" #include "Message.h" /* ------------------------------------------------------------------------ */ /* B F _ E d g e _ 4 */ /* ------------------------------------------------------------------------ */ /* ------- */ /* Edges */ /* ------- */ #define WrongNumEntity Message::Error("Wrong Edge number in 'BF_Edge_4E'") void BF_Edge_4E(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { switch (Element->Type) { case LINE : switch(NumEntity) { case 1 : s[0] = u*u ; s[1] = 0. ; s[2] = 0. ; break ; default : WrongNumEntity ; } break ; case TRIANGLE : switch(NumEntity) { case 1 : s[0] = -6.0*u+1.0-2.0*v+6.0*u*u+6.0*u*v+v*v ; s[1] = -2.0*u+3.0*u*u+2.0*u*v ; s[2] = 0. ; break ; case 2 : s[0] = -2.0*v+3.0*v*v+2.0*u*v ; s[1] = -6.0*v+1.0-2.0*u+6.0*u*v+u*u+6.0*v*v ; s[2] = 0. ; break ; case 3 : s[0] = 2.0*u*v-v*v ; s[1] = u*u-2.0*u*v ; s[2] = 0. ; break ; default : WrongNumEntity ; } break ; case QUADRANGLE : switch(NumEntity) { default : Message::Error("BF_Edge_4E not ready for QUADRANGLE"); } break ; case TETRAHEDRON : switch(NumEntity) { case 1 : s[0] = -6.0*u+1.0-2.0*v-2.0*w+6.0*u*u+6.0*u*v+6.0*u*w+v*v+2.0*v*w+w*w; s[1] = -2.0*u+3.0*u*u+2.0*u*v+2.0*u*w; s[2] = -2.0*u+3.0*u*u+2.0*u*v+2.0*u*w; break ; case 2 : s[0] = -2.0*v+3.0*v*v+2.0*u*v+2.0*v*w; s[1] = -6.0*v+1.0-2.0*u-2.0*w+6.0*u*v+u*u+2.0*u*w+6.0*v*v+6.0*v*w+w*w; s[2] = -2.0*v+3.0*v*v+2.0*u*v+2.0*v*w; break ; case 3 : s[0] = -2.0*w+3.0*w*w+2.0*u*w+2.0*v*w; s[1] = -2.0*w+3.0*w*w+2.0*u*w+2.0*v*w; s[2] = -6.0*w+1.0-2.0*u-2.0*v+6.0*u*w+u*u+2.0*u*v+6.0*v*w+v*v+6.0*w*w; break ; case 4 : s[0] = 2.0*u*v-v*v; s[1] = u*u-2.0*u*v; s[2] = 0.0; break ; case 5 : s[0] = 2.0*u*w-w*w; s[1] = 0.0; s[2] = u*u-2.0*u*w; break ; case 6 : s[0] = 0.0; s[1] = 2.0*v*w-w*w; s[2] = v*v-2.0*v*w; break ; default : WrongNumEntity ; } break ; case HEXAHEDRON : switch(NumEntity) { default : Message::Error("BF_Edge_4E not ready for HEXAHEDRON"); } break ; case PRISM : switch(NumEntity) { default : Message::Error("BF_Edge_4E not ready for PRISM"); } break ; case PYRAMID : switch(NumEntity) { default : Message::Error("BF_Edge_4E not ready for PYRAMID"); } break ; default : Message::Error("Unkown type of Element in BF_Edge_4E"); break ; } if (Element->GeoElement->NumEdges[NumEntity-1] < 0) { s[0] = - s[0] ; s[1] = - s[1] ; s[2] = - s[2] ; } } #undef WrongNumEntity /* -------- */ /* Facets */ /* -------- */ #define WrongNumEntity Message::Error("Wrong Face number in 'BF_Edge_4F'") void BF_Edge_4F(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { switch (Element->Type) { case LINE : Message::Error("You should never end up here!") ; break; case TRIANGLE : switch(NumEntity) { case 1 : s[0] = v-2.0*u*v-v*v ; s[1] = u-u*u-2.0*u*v ; s[2] = 0. ; break ; default : WrongNumEntity ; } break ; case QUADRANGLE : switch(NumEntity) { default : Message::Error("BF_Edge_4F not ready for QUADRANGLE"); } break ; case TETRAHEDRON : switch(NumEntity) { case 1 : s[0] = w-2.0*u*w-v*w-w*w ; s[1] = -u*w ; s[2] = u-u*u-u*v-2.0*u*w ; break ; case 2 : s[0] = v-2.0*u*v-v*v-v*w ; s[1] = u-u*u-2.0*u*v-u*w ; s[2] = -u*v ; break ; case 3 : s[0] = -v*w ; s[1] = w-u*w-2.0*v*w-w*w ; s[2] = v-u*v-v*v-2.0*v*w ; break ; case 4 : s[0] = v*w ; s[1] = u*w ; s[2] = u*v ; break ; default : WrongNumEntity ; } break ; case HEXAHEDRON : switch(NumEntity) { default : Message::Error("BF_Edge_4F not ready for QUADRANGLE"); } break ; case PRISM : switch(NumEntity) { default : Message::Error("BF_Edge_4F not ready for PRISM"); } break ; default : Message::Error("Unkown type of Element in BF_Edge_4F"); break ; } } #undef WrongNumEntity /* -------- */ /* Volume */ /* -------- */ void BF_Edge_4V(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { Message::Error("You should never end up here!") ; } /* ------------------------------------------------------------------------ */ /* B F _ C u r l E d g e _ 4 */ /* ------------------------------------------------------------------------ */ /* ------- */ /* Edges */ /* ------- */ void BF_CurlEdge_4E(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { s[0] = 0. ; s[1] = 0. ; s[2] = 0. ; } /* -------- */ /* Facets */ /* -------- */ void BF_CurlEdge_4F(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { s[0] = 0. ; s[1] = 0. ; s[2] = 0. ; } /* -------- */ /* Volume */ /* -------- */ void BF_CurlEdge_4V(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { s[0] = 0. ; s[1] = 0. ; s[2] = 0. ; } getdp-2.4.2-source/Legacy/Get_DofOfElement.cpp000644 001750 001750 00000052103 12166744450 022630 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "ProData.h" #include "GeoData.h" #include "DofData.h" #include "Get_DofOfElement.h" #include "Get_ConstraintOfElement.h" #include "ExtendedGroup.h" #include "Cal_Quantity.h" #include "Message.h" extern struct Problem Problem_S ; extern struct CurrentData Current ; extern int TreatmentStatus ; extern double Flag_ORDER ; extern List_T *PreResolutionIndex_L ; struct BasisFunction * BasisFunction_P ; int Nbr_ElementaryBF, Flag_SubSpace ; struct Group * GroupSupport_P, * GroupEntity_P ; /* ------------------------------------------------------------------------ */ /* G e t _ I n i t D o f O f E l e m e n t */ /* ------------------------------------------------------------------------ */ void Get_InitDofOfElement(struct Element * Element) { Element->ElementTrace = NULL ; Element->NumLastElementForNodesCoordinates = -1 ; Element->NumLastElementForGroupsOfEntities = -1 ; Element->NumLastElementForSolidAngle = -1 ; Element->NumLastElementForSortedNodesByFacet = -1 ; } /* ------------------------------------------------------------------------ */ /* G e t _ D o f O f E l e m e n t */ /* ------------------------------------------------------------------------ */ void Get_DofOfElement(struct Element * Element, struct FunctionSpace * FunctionSpace_P, struct QuantityStorage * QuantityStorage_P, List_T * BasisFunctionIndex_L) { struct BasisFunction * BasisFunction_P0 ; int Nbr_BasisFunction, Nbr_BasisFunctionAll, i_BFunction, StartingIndex, i ; int * BasisFunctionIndex_P0 = NULL ; Current.Element = Element ; Nbr_ElementaryBF = 0 ; /* Get the SubSpace */ Nbr_BasisFunctionAll = List_Nbr(FunctionSpace_P->BasisFunction) ; BasisFunction_P0 = (Nbr_BasisFunctionAll) ? (struct BasisFunction*)List_Pointer(FunctionSpace_P->BasisFunction, 0) : NULL ; if (!BasisFunctionIndex_L) { Flag_SubSpace = 0 ; Nbr_BasisFunction = Nbr_BasisFunctionAll ; } else { Flag_SubSpace = 1 ; Nbr_BasisFunction = List_Nbr(BasisFunctionIndex_L) ; BasisFunctionIndex_P0 = (Nbr_BasisFunction) ? (int*)List_Pointer(BasisFunctionIndex_L, 0) : NULL ; } /* Set the DofData if explicitely specified */ switch (TreatmentStatus) { case _CAL : case _POS : if(QuantityStorage_P->DefineQuantity->DofData) FunctionSpace_P->DofData = QuantityStorage_P->DefineQuantity->DofData ; else FunctionSpace_P->DofData = FunctionSpace_P->MainDofData ; break; } /* For each subset of Basis Functions */ for (i = 0 ; i < Nbr_BasisFunction ; i++) { i_BFunction = (!Flag_SubSpace)? i : BasisFunctionIndex_P0[i] ; BasisFunction_P = BasisFunction_P0 + i_BFunction ; GroupSupport_P = (struct Group*) List_Pointer(Problem_S.Group, BasisFunction_P->SupportIndex) ; /* If the BasisFunction exists for this kind of element the interpolation order is lower or equal to the maximum order allowed the element is in the support of the BasisFunction */ if ( ( BasisFunction_P->ElementType & Current.Element->Type ) && ( Flag_ORDER < 0. || BasisFunction_P->Order <= Flag_ORDER ) && ( (GroupSupport_P->Type == REGIONLIST && List_Search(GroupSupport_P->InitialList, &Element->Region, fcmp_int)) || (GroupSupport_P->Type == ELEMENTLIST && Check_IsEntityInExtendedGroup(GroupSupport_P, Element->Num, 0)) ) ) { GroupEntity_P = (struct Group*) List_Pointer(Problem_S.Group, BasisFunction_P->EntityIndex) ; switch (GroupEntity_P->FunctionType) { case NODESOF : Get_CodesOfElement (FunctionSpace_P, QuantityStorage_P, Element->GeoElement->NbrNodes, Element->GeoElement->NumNodes, 0, i_BFunction, NODESOF, NULL) ; break ; case EDGESOF : case EDGESOFTREEIN : if (Element->GeoElement->NbrEdges == 0) Geo_CreateEdgesOfElement(Element->GeoElement) ; Get_CodesOfElement (FunctionSpace_P, QuantityStorage_P, Element->GeoElement->NbrEdges, Element->GeoElement->NumEdges, 0, i_BFunction, EDGESOF, NULL) ; break ; case FACETSOF : case FACETSOFTREEIN : if (Element->GeoElement->NbrEdges == 0) Geo_CreateEdgesOfElement(Element->GeoElement) ; if (Element->GeoElement->NbrFacets == 0) Geo_CreateFacetsOfElement(Element->GeoElement) ; Get_CodesOfElement (FunctionSpace_P, QuantityStorage_P, Element->GeoElement->NbrFacets, Element->GeoElement->NumFacets, 0, i_BFunction, FACETSOF, NULL) ; break ; case VOLUMESOF : Get_CodesOfElement(FunctionSpace_P, QuantityStorage_P, 1, &Element->GeoElement->Num, 0, i_BFunction, VOLUMESOF, NULL) ; break ; case GROUPSOFNODESOF : Get_GroupsOfElementaryEntitiesOfElement (Element, &StartingIndex, Element->GeoElement->NbrNodes, Element->GeoElement->NumNodes, BasisFunction_P) ; Get_CodesOfElement (FunctionSpace_P, QuantityStorage_P, Element->NbrGroupsOfEntities, Element->NumGroupsOfEntities, StartingIndex, i_BFunction, GROUPSOFNODESOF, Element->NumSubFunction[1]) ; break ; case GROUPSOFEDGESONNODESOF : if (Element->GeoElement->NbrEdges == 0) Geo_CreateEdgesOfElement(Element->GeoElement) ; Get_GroupsOfEdgesOnNodesOfElement(Element, &StartingIndex) ; Get_CodesOfElement (FunctionSpace_P, QuantityStorage_P, Element->NbrGroupsOfEntities, Element->NumGroupsOfEntities, StartingIndex, i_BFunction, GROUPSOFEDGESONNODESOF, NULL) ; break ; case GROUPSOFEDGESOF : if (Element->GeoElement->NbrEdges == 0) Geo_CreateEdgesOfElement(Element->GeoElement) ; Get_GroupsOfElementaryEntitiesOfElement (Element, &StartingIndex, Element->GeoElement->NbrEdges, Element->GeoElement->NumEdges, BasisFunction_P) ; Get_CodesOfElement (FunctionSpace_P, QuantityStorage_P, Element->NbrGroupsOfEntities, Element->NumGroupsOfEntities, StartingIndex, i_BFunction, GROUPSOFEDGESOF, NULL) ; break ; case GROUPSOFFACETSOF : if (Element->GeoElement->NbrFacets == 0) Geo_CreateFacetsOfElement(Element->GeoElement) ; Get_GroupsOfElementaryEntitiesOfElement (Element, &StartingIndex, Element->GeoElement->NbrFacets, Element->GeoElement->NumFacets, BasisFunction_P) ; Get_CodesOfElement (FunctionSpace_P, QuantityStorage_P, Element->NbrGroupsOfEntities, Element->NumGroupsOfEntities, StartingIndex, i_BFunction, GROUPSOFFACETSOF, NULL) ; break ; case REGION : Get_RegionForElement(Element, &StartingIndex, BasisFunction_P) ; Get_CodesOfElement (FunctionSpace_P, QuantityStorage_P, Element->NbrGroupsOfEntities, Element->NumGroupsOfEntities, StartingIndex, i_BFunction, REGION, Element->NumSubFunction[1]) ; break ; case GLOBAL : Get_GlobalForElement(Element, &StartingIndex, BasisFunction_P) ; Get_CodesOfElement (FunctionSpace_P, QuantityStorage_P, Element->NbrGroupsOfEntities, Element->NumGroupsOfEntities, StartingIndex, i_BFunction, GLOBAL, NULL) ; break ; } } /* if Region ... */ } /* for i ... */ QuantityStorage_P->NbrElementaryBasisFunction = Nbr_ElementaryBF ; if (TreatmentStatus == _PRE) Treatment_ConstraintByLocalProjection(Element, FunctionSpace_P, QuantityStorage_P); } /* ------------------------------------------------------------------------ */ /* G e t _ G r o u p s O f E l e m e n t a r y E n t i t i e s */ /* O f E l e m e n t */ /* ------------------------------------------------------------------------ */ void Get_GroupsOfElementaryEntitiesOfElement (struct Element * Element, int * StartingIndex, int Nbr_ElementaryEntities, int Num_ElementaryEntities[], struct BasisFunction * BasisFunction_P) { /* external input/output : GroupEntity_P : In */ int i, j, Num_Entity, Nbr_SubFunction, i_SF ; struct TwoInt * Key_P ; if (Element->NumLastElementForGroupsOfEntities != Element->Num) { Element->NumLastElementForGroupsOfEntities = Element->Num ; Element->NbrGroupsOfEntities = 0 ; } *StartingIndex = Element->NbrGroupsOfEntities ; if (GroupEntity_P->ExtendedList == NULL) Generate_ExtendedGroup(GroupEntity_P) ; for (i = 0 ; i < Nbr_ElementaryEntities ; i++) { Num_Entity = abs(Num_ElementaryEntities[i]) ; for (std::multimap::iterator it = GroupEntity_P->ExtendedListForSearch.lower_bound(Num_Entity); it != GroupEntity_P->ExtendedListForSearch.upper_bound(Num_Entity); ++it) { Key_P = &it->second; j = *StartingIndex ; while ((j < Element->NbrGroupsOfEntities) && (Element->NumGroupsOfEntities[j] != Key_P->Int2)) j++ ; if (!BasisFunction_P->SubFunction) { if (j == Element->NbrGroupsOfEntities) { Element->NumSubFunction[1][j] = 0 ; Element->NumSubFunction[0][j] = -1 ; Element->NumGroupsOfEntities[j] = Key_P->Int2 ; Element->NbrEntitiesInGroups[Element->NbrGroupsOfEntities++] = 0 ; } Element->NumEntitiesInGroups[j][Element->NbrEntitiesInGroups[j]++] = (Key_P->Int1 > 0)? (i+1) : -(i+1) ; } else { /* For SubFunctions (basis functions for a global function) */ Nbr_SubFunction = List_Nbr(BasisFunction_P->SubFunction) ; if (j == Element->NbrGroupsOfEntities) { for (i_SF = 0 ; i_SF < Nbr_SubFunction ; i_SF++) { Element->NumSubFunction[1][j+i_SF] = i_SF ; Element->NumSubFunction[0][j+i_SF] = *((int *)List_Pointer(BasisFunction_P->SubFunction, i_SF)) ; if (BasisFunction_P->SubdFunction) Element->NumSubFunction[2][j+i_SF] = *((int *)List_Pointer(BasisFunction_P->SubdFunction, i_SF)) ; Element->NumGroupsOfEntities[j+i_SF] = Key_P->Int2 ; Element->NbrEntitiesInGroups[Element->NbrGroupsOfEntities++] = 0 ; } } for (i_SF = 0 ; i_SF < Nbr_SubFunction ; i_SF++) Element->NumEntitiesInGroups[j+i_SF][Element->NbrEntitiesInGroups[j+i_SF]++] = (Key_P->Int1 > 0)? (i+1) : -(i+1) ; } } } } /* ------------------------------------------------------------------------ */ /* G e t _ G r o u p s O f E d g e s O n N o d e s O f E l e m e n t */ /* ------------------------------------------------------------------------ */ void Get_GroupsOfEdgesOnNodesOfElement(struct Element * Element, int * StartingIndex) { /* external input/output : GroupEntity_P : In */ int i, j, Num_Edge, * Num_Nodes, Num_Node ; if (Element->NumLastElementForGroupsOfEntities != Element->Num) { Element->NumLastElementForGroupsOfEntities = Element->Num ; Element->NbrGroupsOfEntities = 0 ; } *StartingIndex = Element->NbrGroupsOfEntities ; if (GroupEntity_P->ExtendedList == NULL) Generate_ExtendedGroup(GroupEntity_P) ; for (i = 0 ; i < Element->GeoElement->NbrEdges ; i++) { Num_Edge = abs(Element->GeoElement->NumEdges[i]) ; if (List_Search(GroupEntity_P->ExtendedList, &Num_Edge, fcmp_int )) { Num_Nodes = Geo_GetNodesOfEdgeInElement(Element->GeoElement, i) ; Num_Node = Element->GeoElement->NumNodes[abs(Num_Nodes[0])-1] ; j = *StartingIndex ; while ((j < Element->NbrGroupsOfEntities) && (Element->NumGroupsOfEntities[j] != Num_Node)) j++ ; if (j == Element->NbrGroupsOfEntities) { Element->NumGroupsOfEntities[Element->NbrGroupsOfEntities++] = Num_Node ; Element->NbrEntitiesInGroups[j] = 0 ; } Element->NumEntitiesInGroups[j] [Element->NbrEntitiesInGroups[j]++] = (Element->GeoElement->NumEdges[i] > 0)? -(i+1) : (i+1) ; /*- edge node 1 o--->---o node 2 => (Phi2 - Phi1) s12 ... -> minus sign associated with node 1 for positive edge from node 1 to node 2 */ Num_Node = Element->GeoElement->NumNodes[abs(Num_Nodes[1])-1] ; j = *StartingIndex ; while ((j < Element->NbrGroupsOfEntities) && (Element->NumGroupsOfEntities[j] != Num_Node)) j++ ; if (j == Element->NbrGroupsOfEntities) { Element->NumGroupsOfEntities[Element->NbrGroupsOfEntities++] = Num_Node ; Element->NbrEntitiesInGroups[j] = 0 ; } Element->NumEntitiesInGroups[j] [Element->NbrEntitiesInGroups[j]++] = (Element->GeoElement->NumEdges[i] > 0)? (i+1) : -(i+1) ; } } } /* ------------------------------------------------------------------------ */ /* G e t _ R e g i o n F o r E l e m e n t */ /* ------------------------------------------------------------------------ */ void Get_RegionForElement(struct Element * Element, int * StartingIndex, struct BasisFunction * BasisFunction_P) { int Nbr_SubFunction, i_SF ; if (Element->NumLastElementForGroupsOfEntities != Element->Num) { Element->NumLastElementForGroupsOfEntities = Element->Num ; Element->NbrGroupsOfEntities = 0 ; } *StartingIndex = Element->NbrGroupsOfEntities ; if (!BasisFunction_P->SubFunction) { Element->NumSubFunction[1][Element->NbrGroupsOfEntities] = 0 ; Element->NumSubFunction[0][Element->NbrGroupsOfEntities] = -1 ; Element->NumGroupsOfEntities[Element->NbrGroupsOfEntities++] = Element->Region ; } else { /* For SubFunctions (basis functions for a global function) */ Nbr_SubFunction = List_Nbr(BasisFunction_P->SubFunction) ; for (i_SF = 0 ; i_SF < Nbr_SubFunction ; i_SF++) { Element->NumSubFunction[1][Element->NbrGroupsOfEntities] = i_SF ; /* Index SF */ Element->NumSubFunction[0][Element->NbrGroupsOfEntities] = *((int *)List_Pointer(BasisFunction_P->SubFunction, i_SF)) ; /* Index Expression */ if (BasisFunction_P->SubdFunction) Element->NumSubFunction[2][Element->NbrGroupsOfEntities] = *((int *)List_Pointer(BasisFunction_P->SubdFunction, i_SF)) ; /* Index Expression */ Element->NumGroupsOfEntities[Element->NbrGroupsOfEntities++] = Element->Region ; } } } /* ------------------------------------------------------------------------ */ /* G e t _ G l o b a l F o r E l e m e n t */ /* ------------------------------------------------------------------------ */ void Get_GlobalForElement(struct Element * Element, int * StartingIndex, struct BasisFunction * BasisFunction_P) { int Nbr_Global, i, * Num_Global ; if (Element->NumLastElementForGroupsOfEntities != Element->Num) { Element->NumLastElementForGroupsOfEntities = Element->Num ; Element->NbrGroupsOfEntities = 0 ; } *StartingIndex = Element->NbrGroupsOfEntities ; Nbr_Global = List_Nbr(GroupEntity_P->InitialList) ; Num_Global = (Nbr_Global)? (int*)List_Pointer(GroupEntity_P->InitialList, 0) : NULL ; for (i = 0 ; i < Nbr_Global ; i++) { Element->GlobalBasisFunction[Element->NbrGroupsOfEntities ] = (struct GlobalBasisFunction *) List_Pointer(BasisFunction_P->GlobalBasisFunction, i) ; /* Attention: correspondance i-i si liste triee ! fait dans yacc */ Element->NumGroupsOfEntities[Element->NbrGroupsOfEntities++] = Num_Global[i] ; } if (TreatmentStatus == _PRE) Get_PreResolutionForGlobalBasisFunction(Nbr_Global, *StartingIndex, Element) ; } /* ------------------------------------------------------------------------ */ /* G e t _ C o d e s O f E l e m e n t */ /* ------------------------------------------------------------------------ */ void Get_CodesOfElement(struct FunctionSpace * FunctionSpace_P, struct QuantityStorage * QuantityStorage_P, int Nbr_Entity, int Num_Entity[], int StartingIndex, int i_BFunction, int TypeConstraint, int * Num_SubFunction) { /* external input/output : GroupSupport_P : In GroupEntity_P : In */ int i_Entity, CodeExist = 0, Code_BasisFunction ; struct Dof * Dof_P = NULL; /* 1. F o r e a c h e n t i t y t o w h i c h a b a s i s f u n c t i o n c o u l d b e a s s o c i a t e d : (Node, Edge, Facet, Volume, GroupOfNodes, Region, ...) */ for (i_Entity = StartingIndex ; i_Entity < Nbr_Entity ; i_Entity++) { Code_BasisFunction = BasisFunction_P->Num + (Num_SubFunction? Num_SubFunction[i_Entity] : 0) ; switch (TreatmentStatus) { case _CAL : case _POS : case _CST : if(!FunctionSpace_P->DofData){ Message::Error("Empty DofData in FunctionSpace '%s' (no unknowns?)", FunctionSpace_P->Name); return; } CodeExist = ((Dof_P = Dof_GetDofStruct(FunctionSpace_P->DofData, Code_BasisFunction, abs(Num_Entity[i_Entity]), 0)) != NULL) ; if (Flag_SubSpace && CodeExist && TreatmentStatus != _POS) CodeExist = Check_IsEntityInExtendedGroup(GroupEntity_P, abs(Num_Entity[i_Entity]), 0) ; /* ... parce que le code peut ne pas exister quand sous-espace ! */ break ; case _PRE : CodeExist = Check_IsEntityInExtendedGroup(GroupEntity_P, abs(Num_Entity[i_Entity]), 0) ; break ; default : Message::Error("Unknown TreatmentStatus (%d)", TreatmentStatus); return; } /* 2. O n e a s s o c i a t e s a b a s i s f u n c t i o n : */ if (CodeExist) { QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].Dof = Dof_P ; QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].NumEntityInElement = i_Entity ; QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].CodeBasisFunction = Code_BasisFunction ; QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].CodeEntity = abs(Num_Entity[i_Entity]) ; QuantityStorage_P->BasisFunction[Nbr_ElementaryBF].BasisFunction = BasisFunction_P ; if (TreatmentStatus == _PRE || TreatmentStatus == _CST) /* Associated Contraints? */ Treatment_ConstraintForElement(FunctionSpace_P, QuantityStorage_P, Num_Entity, i_Entity, i_BFunction, TypeConstraint) ; Nbr_ElementaryBF++ ; } /* if CodeExist ... */ } /* for i_Entity ... */ } /* ------------------------------------------------------------------------ */ /* G e t _ D o f O f R e g i o n */ /* ------------------------------------------------------------------------ */ void Get_DofOfRegion(int Num_Region, struct GlobalQuantity * GlobalQuantity_P, struct FunctionSpace * FunctionSpace_P, struct QuantityStorage * QuantityStorage_P) { int CodeExist = 0, Num_BasisFunction, Num_AssociateBasisFunction ; struct Dof * Dof_P = NULL; Nbr_ElementaryBF = 0 ; BasisFunction_P = (struct BasisFunction*) List_Pointer(FunctionSpace_P->BasisFunction, GlobalQuantity_P->ReferenceIndex) ; GroupEntity_P = (struct Group*) List_Pointer(Problem_S.Group, BasisFunction_P->EntityIndex) ; if (GroupEntity_P->Type == REGIONLIST && List_Search(GroupEntity_P->InitialList, &Num_Region, fcmp_int)) { if (GlobalQuantity_P->Type == ALIASOF) { Num_BasisFunction = BasisFunction_P->Num ; Num_AssociateBasisFunction = 0 ; } else { Num_BasisFunction = GlobalQuantity_P->Num ; Num_AssociateBasisFunction = BasisFunction_P->Num ; } switch (TreatmentStatus) { case _CAL : case _POS : case _CST : if(!FunctionSpace_P->DofData){ Message::Error("Empty DofData in FunctionSpace '%s' (no unknowns?)", FunctionSpace_P->Name); return; } CodeExist = ((Dof_P = Dof_GetDofStruct(FunctionSpace_P->DofData, Num_BasisFunction, Num_Region, 0)) != NULL) ; break ; case _PRE : CodeExist = 1 ; break ; default : break ; } if (CodeExist) { QuantityStorage_P->BasisFunction[0].Dof = Dof_P ; QuantityStorage_P->BasisFunction[0].CodeBasisFunction = Num_BasisFunction ; QuantityStorage_P->BasisFunction[0].CodeEntity = Num_Region ; QuantityStorage_P->BasisFunction[0].CodeAssociateBasisFunction = Num_AssociateBasisFunction ; if (TreatmentStatus == _PRE || TreatmentStatus == _CST) /* Contrainte associee ? */ Treatment_ConstraintForRegion(GlobalQuantity_P, FunctionSpace_P, QuantityStorage_P) ; Nbr_ElementaryBF = 1 ; } /* if CodeExist ... */ } /* if REGIONLIST ... */ QuantityStorage_P->NbrElementaryBasisFunction = Nbr_ElementaryBF ; } /* ------------------------------------------------------------------------ */ /* G e t _ P r e R e s o l u t i o n F o r GlobalBasisFunction */ /* ------------------------------------------------------------------------ */ void Get_PreResolutionForGlobalBasisFunction(int Nbr_Global, int StartingIndex, struct Element * Element) { int i ; struct PreResolutionInfo PreResolutionInfo_S ; for (i = 0 ; i < Nbr_Global ; i++) if(List_ISearchSeq(PreResolutionIndex_L, &(Element->GlobalBasisFunction[StartingIndex + i]-> ResolutionIndex), fcmp_int) < 0) { PreResolutionInfo_S.Index = Element->GlobalBasisFunction[StartingIndex + i]->ResolutionIndex ; PreResolutionInfo_S.Type = PR_GLOBALBASISFUNCTION ; List_Add(PreResolutionIndex_L, &PreResolutionInfo_S) ; Message::Info(" Adding Resolution '%s' for Pre-Resolution (Global BF)", ((struct Resolution*)List_Pointer(Problem_S.Resolution, PreResolutionInfo_S.Index))->Name) ; } } getdp-2.4.2-source/Legacy/Cal_GlobalTermOfFemEquation.cpp000644 001750 001750 00000024672 12116424202 024747 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "ProData.h" #include "GeoData.h" #include "DofData.h" #include "Cal_Quantity.h" #include "Cal_Value.h" #include "Cal_AssembleTerm.h" #include "Get_DofOfElement.h" #include "Get_Geometry.h" #include "Message.h" extern struct Problem Problem_S ; extern struct CurrentData Current ; /* ------------------------------------------------------------------------ */ /* C a l _ G l o b a l T e r m O f F e m F o r m u l a t i o n */ /* ------------------------------------------------------------------------ */ #define OFFSET (iHar < NbrHar-OffSet)? 0 : iHar-NbrHar+OffSet+2-iHar%2 void MH_Get_InitData(int Case, int NbrPoints, int *NbrPointsX_P, double ***H_P, double ****HH_P, double **t_P, double **w_P); void Cal_GlobalTermOfFemEquation(int Num_Region, struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0, struct QuantityStorage * QuantityStorageNoDof, struct Dof * DofForNoDof_P) { struct QuantityStorage * QuantityStorageEqu_P, * QuantityStorageDof_P ; struct Value vBFxDof [1] ; struct Element Element ; int k ; double Coefficient [NBR_MAX_HARMONIC] ; void (*Function_AssembleTerm)(struct Dof * Equ, struct Dof * Dof, double Val[])=0 ; List_T * WholeQuantity_L; struct WholeQuantity *WholeQuantity_P0 ; int i_WQ ; struct Expression * Expression_P; int NbrPointsX ; double **H, ***HH, *time, *weight, Factor=1., plus, plus0; double one=1.0 ; int j=0,iPul, ZeroHarmonic, DcHarmonic; int NbrHar, iTime, iHar, jHar, OffSet=0 ; double Val_Dof [NBR_MAX_HARMONIC] ; double E_D [NBR_MAX_HARMONIC][NBR_MAX_HARMONIC] ; struct Dof * Dof; struct Value t_Value; gMatrix * Jac; struct QuantityStorage * QuantityStorage_P; Element.Num = NO_ELEMENT ; switch (EquationTerm_P->Case.GlobalTerm.Term.TypeTimeDerivative) { case NODT_ : Function_AssembleTerm = Cal_AssembleTerm_NoDt ; break ; case DTDOF_ : Function_AssembleTerm = Cal_AssembleTerm_DtDof ; break ; case DT_ : Function_AssembleTerm = Cal_AssembleTerm_Dt ; break ; case DTDTDOF_ : Function_AssembleTerm = Cal_AssembleTerm_DtDtDof ; break ; case DTDT_ : Function_AssembleTerm = Cal_AssembleTerm_DtDt ; break ; case NEVERDT_ : Function_AssembleTerm = Cal_AssembleTerm_NeverDt ; break ; case JACNL_ : Function_AssembleTerm = Cal_AssembleTerm_JacNL ; break ; case DTDOFJACNL_ : Function_AssembleTerm = Cal_AssembleTerm_DtDofJacNL; break ; default : Message::Error("Unknown type of operator for Global term") ; return; } QuantityStorageEqu_P = QuantityStorage_P0 + EquationTerm_P->Case.GlobalTerm.Term.DefineQuantityIndexEqu ; if (EquationTerm_P->Case.GlobalTerm.Term.DefineQuantityIndexDof >= 0) { QuantityStorageDof_P = QuantityStorage_P0 + EquationTerm_P->Case.GlobalTerm.Term.DefineQuantityIndexDof ; } else { QuantityStorageDof_P = QuantityStorageNoDof ; Dof_InitDofForNoDof(DofForNoDof_P, Current.NbrHar) ; QuantityStorageDof_P->BasisFunction[0].Dof = DofForNoDof_P ; } /* search for MHJacNL-term(s) */ WholeQuantity_L = EquationTerm_P->Case.GlobalTerm.Term.WholeQuantity ; WholeQuantity_P0 = (struct WholeQuantity*)List_Pointer(WholeQuantity_L, 0) ; i_WQ = 0 ; while ( i_WQ < List_Nbr(WholeQuantity_L) && (WholeQuantity_P0 + i_WQ)->Type != WQ_MHJACNL) i_WQ++ ; if (i_WQ < List_Nbr(WholeQuantity_L) ) { Message::Info("MHJacNL term"); if (QuantityStorageEqu_P != QuantityStorageDof_P){ Message::Error("Global term with MHJacNL is not symmtric ?!"); return; } QuantityStorage_P = QuantityStorageEqu_P ; if (List_Nbr(WholeQuantity_L) == 3){ if (i_WQ != 0 || EquationTerm_P->Case.GlobalTerm.Term.DofIndexInWholeQuantity != 1 || (WholeQuantity_P0 + 2)->Type != WQ_BINARYOPERATOR || (WholeQuantity_P0 + 2)->Case.Operator.TypeOperator != OP_TIME){ Message::Error("Not allowed expression in Global term with MHJacNL (case 1)"); return; } Factor = 1.; } else if (List_Nbr(WholeQuantity_L) == 5){ if ((WholeQuantity_P0 + 0)->Type != WQ_CONSTANT || i_WQ != 1 || (WholeQuantity_P0 + 2)->Type != WQ_BINARYOPERATOR || (WholeQuantity_P0 + 2)->Case.Operator.TypeOperator != OP_TIME || EquationTerm_P->Case.GlobalTerm.Term.DofIndexInWholeQuantity != 3 || (WholeQuantity_P0 + 4)->Type != WQ_BINARYOPERATOR || (WholeQuantity_P0 + 4)->Case.Operator.TypeOperator != OP_TIME){ Message::Error("Not allowed expression in Global term with MHJacNL (case 2)"); return; } Factor = WholeQuantity_P0->Case.Constant ; /* printf(" Factor = %e \n" , FI->MHJacNL_Factor); */ } else { Message::Error("Not allowed expression in Global term with MHJacNL (%d terms) ", List_Nbr(WholeQuantity_L)); return; } if (EquationTerm_P->Case.GlobalTerm.Term.TypeTimeDerivative != JACNL_){ Message::Error("MHJacNL can only be used with JACNL") ; return; } Expression_P = (struct Expression *)List_Pointer (Problem_S.Expression, (WholeQuantity_P0 + i_WQ)->Case.MHJacNL.Index) ; MH_Get_InitData(2, (WholeQuantity_P0 + i_WQ)->Case.MHJacNL.NbrPoints, &NbrPointsX, &H, &HH, &time, &weight) ; NbrHar = Current.NbrHar ; /* special treatment of DC-term and associated dummy sinus-term */ DcHarmonic = NbrHar; ZeroHarmonic = 0; for (iPul = 0 ; iPul < NbrHar/2 ; iPul++) if (!Current.DofData->Val_Pulsation[iPul]){ DcHarmonic = 2*iPul ; ZeroHarmonic = 2*iPul+1 ; break; } for (k = 0 ; k < Current.NbrHar ; k+=2) Dof_GetComplexDofValue (QuantityStorage_P->FunctionSpace->DofData, QuantityStorage_P->BasisFunction[j].Dof + k/2*gCOMPLEX_INCREMENT, &Val_Dof[k], &Val_Dof[k+1]) ; /* time integration over fundamental period */ for (iHar = 0 ; iHar < NbrHar ; iHar++) for (jHar = OFFSET ; jHar <= iHar ; jHar++) E_D[iHar][jHar] = 0. ; Current.NbrHar = 1; /* evaluation in time domain */ for (iTime = 0 ; iTime < NbrPointsX ; iTime++) { t_Value.Type = SCALAR; t_Value.Val[0] = 0; for (iHar = 0 ; iHar < NbrHar ; iHar++) t_Value.Val[0] += H[iTime][iHar] * Val_Dof[iHar] ; Get_ValueOfExpression(Expression_P, QuantityStorage_P0, Current.u, Current.v, Current.w, &t_Value); for (iHar = 0 ; iHar < NbrHar ; iHar++) for (jHar = OFFSET ; jHar <= iHar ; jHar++) E_D[iHar][jHar] += HH[iTime][iHar][jHar] * t_Value.Val[0] ; } /* for i_IntPoint ... */ Current.NbrHar = NbrHar ; Jac = &Current.DofData->Jac; Dof = QuantityStorage_P->BasisFunction[0].Dof ; for (iHar = 0 ; iHar < NbrHar ; iHar++) for (jHar = OFFSET ; jHar <= iHar ; jHar++){ plus = plus0 = Factor * E_D[iHar][jHar] ; if(jHar==DcHarmonic && iHar!=DcHarmonic) { plus0 *= 1. ; plus *= 2. ;} Dof_AssembleInMat(Dof+iHar, Dof+jHar, 1, &plus, Jac, NULL) ; if(iHar != jHar) Dof_AssembleInMat(Dof+jHar, Dof+iHar, 1, &plus0, Jac, NULL) ; } /* dummy 1's on the diagonal for sinus-term of dc-component */ if (ZeroHarmonic) { Dof = QuantityStorage_P->BasisFunction[0].Dof + ZeroHarmonic ; Dof_AssembleInMat(Dof, Dof, 1, &one, Jac, NULL) ; } } else { vBFxDof[0].Type = SCALAR ; vBFxDof[0].Val[0] = 1. ; if(Current.NbrHar > 1) Cal_SetHarmonicValue(&vBFxDof[0]) ; Cal_WholeQuantity (Current.Element = &Element, QuantityStorage_P0, EquationTerm_P->Case.GlobalTerm.Term.WholeQuantity, Current.u = 0., Current.v = 0., Current.w = 0., EquationTerm_P->Case.GlobalTerm.Term.DofIndexInWholeQuantity, 1, vBFxDof) ; for (k = 0 ; k < Current.NbrHar ; k++) Coefficient[k] = vBFxDof[0].Val[MAX_DIM*k] ; Function_AssembleTerm (QuantityStorageEqu_P->BasisFunction[0].Dof, QuantityStorageDof_P->BasisFunction[0].Dof, Coefficient) ; } } #undef OFFSET void Cal_GlobalTermOfFemEquation_old(int Num_Region, struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0, struct QuantityStorage * QuantityStorageNoDof, struct Dof * DofForNoDof_P) { struct QuantityStorage * QuantityStorageEqu_P, * QuantityStorageDof_P ; struct Value vBFxDof [1] ; struct Element Element ; int k ; double Coefficient [NBR_MAX_HARMONIC] ; void (*Function_AssembleTerm)(struct Dof * Equ, struct Dof * Dof, double Val[]) = 0; Element.Num = NO_ELEMENT ; switch (EquationTerm_P->Case.GlobalTerm.Term.TypeTimeDerivative) { case NODT_ : Function_AssembleTerm = Cal_AssembleTerm_NoDt ; break ; case DTDOF_ : Function_AssembleTerm = Cal_AssembleTerm_DtDof ; break ; case DT_ : Function_AssembleTerm = Cal_AssembleTerm_Dt ; break ; case DTDTDOF_: Function_AssembleTerm = Cal_AssembleTerm_DtDtDof ; break ; case DTDT_ : Function_AssembleTerm = Cal_AssembleTerm_DtDt ; break ; case NEVERDT_: Function_AssembleTerm = Cal_AssembleTerm_NeverDt ; break ; case JACNL_ : Function_AssembleTerm = Cal_AssembleTerm_JacNL ; break ; case DTDOFJACNL_ : Function_AssembleTerm = Cal_AssembleTerm_DtDofJacNL; break ; default : Message::Error("Unknown type of operator for Global term") ; return ; } QuantityStorageEqu_P = QuantityStorage_P0 + EquationTerm_P->Case.GlobalTerm.Term.DefineQuantityIndexEqu ; if (EquationTerm_P->Case.GlobalTerm.Term.DefineQuantityIndexDof >= 0) { QuantityStorageDof_P = QuantityStorage_P0 + EquationTerm_P->Case.GlobalTerm.Term.DefineQuantityIndexDof ; } else { QuantityStorageDof_P = QuantityStorageNoDof ; Dof_InitDofForNoDof(DofForNoDof_P, Current.NbrHar) ; QuantityStorageDof_P->BasisFunction[0].Dof = DofForNoDof_P ; } vBFxDof[0].Type = SCALAR ; vBFxDof[0].Val[0] = 1. ; if(Current.NbrHar > 1) Cal_SetHarmonicValue(&vBFxDof[0]) ; Cal_WholeQuantity (Current.Element = &Element, QuantityStorage_P0, EquationTerm_P->Case.GlobalTerm.Term.WholeQuantity, Current.u = 0., Current.v = 0., Current.w = 0., EquationTerm_P->Case.GlobalTerm.Term.DofIndexInWholeQuantity, 1, vBFxDof) ; for (k = 0 ; k < Current.NbrHar ; k++) Coefficient[k] = vBFxDof[0].Val[MAX_DIM*k] ; Function_AssembleTerm (QuantityStorageEqu_P->BasisFunction[0].Dof, QuantityStorageDof_P->BasisFunction[0].Dof, Coefficient) ; } getdp-2.4.2-source/Legacy/Get_ElementSource.cpp000644 001750 001750 00000006754 12116424202 023067 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "ProData.h" #include "GeoData.h" #include "ExtendedGroup.h" #include "Get_Geometry.h" #include "Message.h" extern struct Problem Problem_S ; extern struct CurrentData Current ; static int Nbr_ElementSource, i_ElementSource ; static List_T *RegionSource_L ; static struct Element ElementSource , ElementTrace; /* ------------------------------------------------------------------------ */ /* G e t _ I n i t E l e m e n t S o u r c e */ /* ------------------------------------------------------------------------ */ void Get_InitElementSource(struct Element *Element, int InIndex) { Element->ElementSource = &ElementSource ; Nbr_ElementSource = Geo_GetNbrGeoElements() ; i_ElementSource = -1 ; if(InIndex<0){ Message::Error("Missing support (Region Group) in Integral Quantity"); } else{ RegionSource_L = ((struct Group*) List_Pointer(Problem_S.Group, InIndex))->InitialList ; Current.SourceIntegrationSupportIndex = InIndex ; } } /* ------------------------------------------------------------------------ */ /* G e t _ N e x t E l e m e n t S o u r c e */ /* ------------------------------------------------------------------------ */ int Get_NextElementSource(struct Element *ElementSource) { while (++i_ElementSource < Nbr_ElementSource) { ElementSource->GeoElement = Geo_GetGeoElement(i_ElementSource) ; ElementSource->Region = ElementSource->GeoElement->Region ; if (List_Search(RegionSource_L, &ElementSource->Region, fcmp_int)) { ElementSource->Num = ElementSource->GeoElement->Num ; ElementSource->Type = ElementSource->GeoElement->Type ; return(1) ; } } return(0) ; } /* ------------------------------------------------------------------------ */ /* G e t _ E l e m e n t S o u r c e I n t e r p o l a t i o n */ /* ------------------------------------------------------------------------ */ int Get_ElementSourceInterpolation(struct Element *ElementSource, struct PostSubOperation *PostSubOperation) { return(0) ; } /* ------------------------------------------------------------------------ */ /* G e t _ E l e m e n t T r a c e */ /* ------------------------------------------------------------------------ */ void Get_ElementTrace(struct Element *Element, int InIndex) { struct Group * Group_P ; struct TwoInt * Pair_P ; Element->ElementTrace = &ElementTrace ; Group_P = (struct Group*)List_Pointer(Problem_S.Group, InIndex) ; if (!Group_P->ExtendedList) Generate_ExtendedGroup(Group_P) ; if(!(Pair_P = (struct TwoInt*)List_PQuery(Group_P->ExtendedList, &Element->Num, fcmp_int))) Message::Error("No Element connected to Element %d: check Group for Trace", Element->Num) ; Element->ElementTrace = &ElementTrace ; Element->ElementTrace->GeoElement = Geo_GetGeoElement(Pair_P->Int2) ; Element->ElementTrace->Region = Element->ElementTrace->GeoElement->Region ; Element->ElementTrace->Num = Element->ElementTrace->GeoElement->Num ; Element->ElementTrace->Type = Element->ElementTrace->GeoElement->Type ; Get_NodesCoordinatesOfElement(Element->ElementTrace) ; Message::Debug("Element %d -> Trace %d", Element->Num, Element->ElementTrace->Num); } getdp-2.4.2-source/Legacy/GF_Laplace.cpp000644 001750 001750 00000016033 12116424202 021422 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "ProData.h" #include "GF.h" #include "Message.h" #define SQU(a) ((a)*(a)) #define CUB(a) ((a)*(a)*(a)) #define ONE_OVER_TWO_PI 1.5915494309189534E-01 #define ONE_OVER_FOUR_PI 7.9577471545947668E-02 extern struct CurrentData Current ; /* ------------------------------------------------------------------------ */ /* G F _ L a p l a c e */ /* ------------------------------------------------------------------------ */ void GF_Laplace(GF_ARG) { double d; switch((int)Fct->Para[0]){ case _1D : /* r/2 */ V->Val[0] = 0.5 * sqrt(SQU(Current.x - Current.xs)) ; break; case _2D : /* 1/(2*Pi) * ln(1/r) = -1/(4*Pi)*ln(r^2) */ d = SQU(Current.x - Current.xs) + SQU(Current.y - Current.ys) ; if(!d) Message::Error("Log(0) in 'GF_Laplace'") ; V->Val[0] = - ONE_OVER_FOUR_PI * log(d) ; V->Val[MAX_DIM] = 0. ; break; case _3D : /* 1/(4*Pi*r) */ d = SQU(Current.x - Current.xs) + SQU(Current.y - Current.ys) + SQU(Current.z - Current.zs) ; if(!d) Message::Error("1/0 in 'GF_Laplace'") ; V->Val[0] = ONE_OVER_FOUR_PI / sqrt(d) ; V->Val[MAX_DIM] = 0. ; break; default : Message::Error("Bad Parameter for 'GF_Laplace' (%d)", (int)Fct->Para[0]); break; } V->Type = SCALAR ; V->Val[MAX_DIM] = 0. ; } /* ------------------------------------------------------------------------ */ /* G F _ G r a d L a p l a c e */ /* ------------------------------------------------------------------------ */ /* the gradient is taken relative to the destination point (x,y,z) */ void GF_GradLaplace(GF_ARG) { double xxs, yys, zzs, r; V->Type = VECTOR ; switch((int)Fct->Para[0]){ case _2D : xxs = Current.x-Current.xs ; yys = Current.y-Current.ys ; r = SQU(xxs) + SQU(yys) ; if(!r) Message::Error("1/0 in 'GF_GradLaplace'") ; V->Val[0] = - ONE_OVER_TWO_PI * xxs / r ; V->Val[1] = - ONE_OVER_TWO_PI * yys / r ; V->Val[2] = 0.0 ; V->Val[MAX_DIM ] = V->Val[MAX_DIM + 1] = V->Val[MAX_DIM + 2] = 0. ; break ; case _3D : xxs = Current.x-Current.xs ; yys = Current.y-Current.ys ; zzs = Current.z-Current.zs ; r = CUB(sqrt(SQU(xxs) + SQU(yys) + SQU(zzs))) ; if(!r) Message::Error("1/0 in 'GF_GradLaplace'") ; V->Val[0] = - ONE_OVER_FOUR_PI * xxs / r ; V->Val[1] = - ONE_OVER_FOUR_PI * yys / r ; V->Val[2] = - ONE_OVER_FOUR_PI * zzs / r ; V->Val[MAX_DIM ] = V->Val[MAX_DIM + 1] = V->Val[MAX_DIM + 2] = 0. ; break ; default : Message::Error("Bad Parameter for 'GF_GradLaplace' (%d)", (int)Fct->Para[0]); break; } V->Type = VECTOR ; V->Val[MAX_DIM+0] = 0. ; V->Val[MAX_DIM+1] = 0. ; V->Val[MAX_DIM+2] = 0. ; } /* ------------------------------------------------------------------------ */ /* G F _ N P x G r a d L a p l a c e */ /* ------------------------------------------------------------------------ */ void GF_NPxGradLaplace(GF_ARG) { double x1x0, x2x0, y1y0, y2y0, z1z0, z2z0, xxs, yys, zzs, a, b, c, r ; V->Type = SCALAR ; V->Val[MAX_DIM] = 0. ; if (Current.Element->Num == Current.ElementSource->Num) { V->Val[0 ] = 0. ; V->Val[MAX_DIM] = 0. ; return ; } switch((int)Fct->Para[0]){ case _2D : x1x0 = Current.Element->x[1] - Current.Element->x[0] ; y1y0 = Current.Element->y[1] - Current.Element->y[0] ; xxs = Current.x-Current.xs ; yys = Current.y-Current.ys ; r = SQU(xxs)+SQU(yys) ; if(!r) V->Val[0] = 0 ; else V->Val[0] = - ONE_OVER_TWO_PI * (y1y0 * xxs - x1x0 * yys) / (sqrt(SQU(x1x0)+SQU(y1y0)) * r) ; V->Val[MAX_DIM] = 0. ; break; case _3D : x1x0 = Current.Element->x[1] - Current.Element->x[0] ; y1y0 = Current.Element->y[1] - Current.Element->y[0] ; z1z0 = Current.Element->z[1] - Current.Element->z[0] ; x2x0 = Current.Element->x[2] - Current.Element->x[0] ; y2y0 = Current.Element->y[2] - Current.Element->y[0] ; z2z0 = Current.Element->z[2] - Current.Element->z[0] ; a = y1y0 * z2z0 - z1z0 * y2y0 ; b = z1z0 * x2x0 - x1x0 * z2z0 ; c = x1x0 * y2y0 - y1y0 * x2x0 ; xxs = Current.x-Current.xs ; yys = Current.y-Current.ys ; zzs = Current.z-Current.zs ; V->Val[0] = - ONE_OVER_FOUR_PI * (a * xxs + b * yys + c * zzs) / ( (sqrt(SQU(a) + SQU(b) + SQU(c)) * CUB(sqrt(SQU(xxs) + SQU(yys) + SQU(zzs)))) ) ; V->Val[MAX_DIM] = 0. ; break ; default : Message::Error("Bad Parameter for 'GF_NPxGradLaplace' (%d)", (int)Fct->Para[0]); break; } } /* ------------------------------------------------------------------------ */ /* G F _ N S x G r a d L a p l a c e */ /* ------------------------------------------------------------------------ */ void GF_NSxGradLaplace(GF_ARG) { double x1x0, x2x0, y1y0, y2y0, z1z0, z2z0, xxs, yys, zzs, a, b, c; V->Type = SCALAR ; V->Val[MAX_DIM] = 0. ; if (Current.Element->Num == Current.ElementSource->Num) { V->Val[0] = 0. ; V->Val[MAX_DIM] = 0. ; return ; } switch((int)Fct->Para[0]){ case _2D : x1x0 = Current.ElementSource->x[1] - Current.ElementSource->x[0] ; y1y0 = Current.ElementSource->y[1] - Current.ElementSource->y[0] ; xxs = Current.x-Current.xs ; yys = Current.y-Current.ys ; V->Val[0] = ONE_OVER_TWO_PI * (y1y0 * xxs - x1x0 * yys) / (sqrt(SQU(x1x0)+SQU(y1y0)) * (SQU(xxs)+SQU(yys)) ) ; V->Val[MAX_DIM] = 0. ; break ; case _3D : x1x0 = Current.ElementSource->x[1] - Current.ElementSource->x[0] ; y1y0 = Current.ElementSource->y[1] - Current.ElementSource->y[0] ; z1z0 = Current.ElementSource->z[1] - Current.ElementSource->z[0] ; x2x0 = Current.ElementSource->x[2] - Current.ElementSource->x[0] ; y2y0 = Current.ElementSource->y[2] - Current.ElementSource->y[0] ; z2z0 = Current.ElementSource->z[2] - Current.ElementSource->z[0] ; a = y1y0 * z2z0 - z1z0 * y2y0 ; b = z1z0 * x2x0 - x1x0 * z2z0 ; c = x1x0 * y2y0 - y1y0 * x2x0 ; xxs = Current.x-Current.xs ; yys = Current.y-Current.ys ; zzs = Current.z-Current.zs ; V->Val[0] = ONE_OVER_FOUR_PI * (a * xxs + b * yys + c * zzs) / ( (sqrt(SQU(a)+SQU(b)+SQU(c)) * CUB(sqrt(SQU(xxs)+SQU(yys)+SQU(zzs)))) ) ; V->Val[MAX_DIM] = 0. ; break ; default : Message::Error("Bad Parameter for 'GF_NSxGradLaplace' (%d)", (int)Fct->Para[0]); break; } } /* ------------------------------------------------------------------------ */ /* G F _ A p p r o x i m a t e L a p l a c e */ /* ------------------------------------------------------------------------ */ void GF_ApproximateLaplace(GF_ARG) { Message::Error("The Approximate Integral Kernels can only be Integrated Analytically"); } getdp-2.4.2-source/Legacy/Treatment_Formulation.h000644 001750 001750 00000000553 12116424202 023474 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _TREATMENT_FORMULATION_H_ #define _TREATMENT_FORMULATION_H_ #include "ProData.h" void Treatment_Formulation(struct Formulation * Formulation_P) ; #endif getdp-2.4.2-source/Legacy/SolvingOperations.h000644 001750 001750 00000010135 12205340470 022637 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _SOLVING_OPERATIONS_H_ #define _SOLVING_OPERATIONS_H_ #include "ProData.h" #include "LinAlg.h" void ReGenerate_System(struct DefineSystem *DefineSystem_P, struct DofData *DofData_P, struct DofData *DofData_P0, int Flag_Jac); void Treatment_Operation(struct Resolution * Resolution_P, List_T * Operation_L, struct DofData * DofData_P0, struct GeoData * GeoData_P0, struct Resolution * Resolution2_P, struct DofData * DofData2_P0); int Operation_IterativeLinearSolver(struct Resolution *Resolution_P, struct Operation *Operation_P, struct DofData *DofData_P0, struct GeoData *GeoData_P0) ; void Operation_TimeLoopAdaptive(struct Resolution *Resolution_P, struct Operation *Operation_P, struct DofData *DofData_P0, struct GeoData *GeoData_P0, int *Flag_Break) ; void Operation_IterativeLoopN(struct Resolution *Resolution_P, struct Operation *Operation_P, struct DofData *DofData_P0, struct GeoData *GeoData_P0, struct Resolution *Resolution2_P, struct DofData *DofData2_P0, int *Flag_Break) ; void Operation_IterativeTimeReduction(struct Resolution * Resolution_P, struct Operation * Operation_P, struct DofData * DofData_P0, struct GeoData * GeoData_P0); void Operation_Update(struct DefineSystem * DefineSystem_P, struct DofData * DofData_P, struct DofData * DofData_P0, int TimeFunctionIndex); void Operation_ChangeOfCoordinates(struct Resolution * Resolution_P, struct Operation * Operation_P, struct DofData * DofData_P0, struct GeoData * GeoData_P0); void Operation_DeformeMesh(struct Resolution * Resolution_P, struct Operation * Operation_P, struct DofData * DofData_P0, struct GeoData * GeoData_P0); void Operation_PostOperation(Resolution *Resolution_P, DofData *DofData_P0, GeoData *GeoData_P0, List_T *PostOperations); void InitLEPostOperation(Resolution *Resolution_P, DofData *DofData_P0, GeoData *GeoData_P0, List_T *PostOp_L, List_T *LEPostOpNames_L, List_T *PostOpSolPredicted_L); void ClearLEPostOperation(Resolution *Resolution_P, DofData *DofData_P0, GeoData *GeoData_P0, List_T *LEPostOp_L, List_T *LEPostOpNames_L, List_T *PostOpSolPredicted_L, bool Delete_LEPostOp_L); void Cal_SolutionErrorRatio(gVector *dx, gVector *x, double reltol, double abstol, int NormType, double *ErrorRatio) ; void Cal_SolutionError(gVector *dx, gVector *x, int diff, double *MeanError); void Free_UnusedSolutions(struct DofData * DofData_P); void Free_UnusedPOresults(); void Free_AllPOresults(); #endif getdp-2.4.2-source/Legacy/ExtendedGroup.cpp000644 001750 001750 00000050000 12140252171 022253 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include "ProData.h" #include "ProDefine.h" #include "ExtendedGroup.h" #include "GeoData.h" #include "Message.h" extern struct Problem Problem_S ; int fcmp_int2(const void * a, const void * b) { static int result ; if ( ( result = ((struct TwoInt *)a)->Int1 - ((struct TwoInt *)b)->Int1 ) != 0 ) return result ; return ((struct TwoInt *)a)->Int2 - ((struct TwoInt *)b)->Int2 ; } int fcmp_absint2(const void * a, const void * b) { static int result ; if ( ( result = abs(((struct TwoInt *)a)->Int1) - abs(((struct TwoInt *)b)->Int1) ) != 0 ) return result ; return abs(((struct TwoInt *)a)->Int2) - abs(((struct TwoInt *)b)->Int2) ; } /* ------------------------------------------------------------------------ */ /* C h e c k _ I s E n t i t y I n E x t e n d e d G r o u p */ /* ------------------------------------------------------------------------ */ int Check_IsEntityInExtendedGroup(struct Group * Group_P, int Entity, int Flag) { switch (Group_P->FunctionType) { case NODESOF : case EDGESOF : case FACETSOF : case VOLUMESOF : if ((Group_P->InitialList && !Group_P->ExtendedList) || (Group_P->InitialSuppList && !Group_P->ExtendedSuppList)) Generate_ExtendedGroup(Group_P) ; return((!Group_P->InitialList || (List_Search(Group_P->ExtendedList, &Entity, fcmp_int))) && (!Group_P->InitialSuppList || (! List_Search(Group_P->ExtendedSuppList, &Entity, fcmp_int)))) ; case ELEMENTSOF : case EDGESOFTREEIN : case FACETSOFTREEIN : if (!Group_P->ExtendedList) Generate_ExtendedGroup(Group_P) ; return( List_Search(Group_P->ExtendedList, &Entity, fcmp_int) ) ; case GROUPSOFNODESOF : case GROUPSOFEDGESOF : case GROUPSOFFACETSOF : case REGION : case GLOBAL : return( (Flag)? List_Search(Group_P->InitialList, &Entity, fcmp_int) : 1 ) ; case GROUPSOFEDGESONNODESOF : if (!Group_P->InitialSuppList){ return(1) ; } return(! List_Search(Group_P->ExtendedSuppList, &Entity, fcmp_int)) ; default : Message::Error("Unknown function type for Group '%s'", Group_P->Name); return(-1) ; } } /* ------------------------------------------------------------------------ */ /* G e n e r a t e _ E x t e n d e d G r o u p */ /* ------------------------------------------------------------------------ */ void Generate_ExtendedGroup(struct Group * Group_P) { Message::Info(" Generate ExtendedGroup '%s' (%s)", Group_P->Name, Get_StringForDefine(FunctionForGroup_Type, Group_P->FunctionType)) ; switch (Group_P->FunctionType) { case NODESOF : case EDGESOF : case FACETSOF : case VOLUMESOF : Generate_ElementaryEntities(Group_P->InitialList, &Group_P->ExtendedList, Group_P->FunctionType) ; Generate_ElementaryEntities(Group_P->InitialSuppList, &Group_P->ExtendedSuppList, Group_P->FunctionType) ; break ; case GROUPSOFEDGESONNODESOF : Generate_ElementaryEntities(Group_P->InitialList, &Group_P->ExtendedList, EDGESOF) ; Generate_ElementaryEntities(Group_P->InitialSuppList, &Group_P->ExtendedSuppList, NODESOF) ; break ; case GROUPSOFNODESOF : Generate_GroupsOfNodes(Group_P->InitialList, &Group_P->ExtendedList) ; break ; case ELEMENTSOF : Generate_Elements(Group_P->InitialList, Group_P->SuppListType, Group_P->InitialSuppList, &Group_P->ExtendedList) ; break ; case GROUPSOFEDGESOF : Generate_GroupsOfEdges(Group_P->InitialList, Group_P->SuppListType, Group_P->InitialSuppList, &Group_P->ExtendedList) ; break ; case GROUPSOFFACETSOF : Generate_GroupsOfFacets(Group_P->InitialList, &Group_P->ExtendedList) ; break ; case EDGESOFTREEIN : Geo_GenerateEdgesOfTree(Group_P->InitialList, Group_P->InitialSuppList, &Group_P->ExtendedList) ; Geo_AddGroupForPRE(Group_P->Num) ; break ; case FACETSOFTREEIN : Geo_GenerateFacetsOfTree(Group_P->InitialList, Group_P->InitialSuppList, &Group_P->ExtendedList) ; Geo_AddGroupForPRE(Group_P->Num) ; break ; default : Message::Error("Unknown function type for Group '%s'", Group_P->Name) ; break; } // create multimap for fast searches in the extended group, even when // multi-valued for(int i = 0; i < List_Nbr(Group_P->ExtendedList); i++){ TwoInt k; List_Read(Group_P->ExtendedList, i, &k); Group_P->ExtendedListForSearch.insert(std::make_pair(abs(k.Int1), k)); } } /* ------------------------------------------------------------------------ */ /* G e n e r a t e _ E l e m e n t a r y E n t i t i e s */ /* ------------------------------------------------------------------------ */ void Generate_ElementaryEntities(List_T * InitialList, List_T ** ExtendedList, int Type_Entity) { Tree_T * Entity_Tr ; struct Geo_Element * GeoElement ; int Nbr_Element, i_Element, Num_Entity ; int Nbr_Entity = 0, i_Entity, * Num_Entities = NULL; if (InitialList != NULL) { Entity_Tr = Tree_Create(sizeof (int), fcmp_int) ; Nbr_Element = Geo_GetNbrGeoElements() ; for (i_Element = 0 ; i_Element < Nbr_Element ; i_Element++) { GeoElement = Geo_GetGeoElement(i_Element) ; if (List_Search(InitialList, &GeoElement->Region, fcmp_int) ) { switch (Type_Entity) { case NODESOF : Nbr_Entity = GeoElement->NbrNodes ; Num_Entities = GeoElement->NumNodes ; break ; case EDGESOF : if (GeoElement->NbrEdges == 0) Geo_CreateEdgesOfElement(GeoElement) ; Nbr_Entity = GeoElement->NbrEdges ; Num_Entities = GeoElement->NumEdges ; break ; case FACETSOF : if (GeoElement->NbrEdges == 0) Geo_CreateEdgesOfElement(GeoElement) ; if (GeoElement->NbrFacets == 0) Geo_CreateFacetsOfElement(GeoElement) ; Nbr_Entity = GeoElement->NbrFacets ; Num_Entities = GeoElement->NumFacets ; break ; case VOLUMESOF : Nbr_Entity = 1 ; Num_Entities = &GeoElement->Num ; break ; } for (i_Entity = 0; i_Entity < Nbr_Entity ; i_Entity++) { Num_Entity = abs(Num_Entities[i_Entity]) ; if ( ! Tree_Search(Entity_Tr, &Num_Entity) ) Tree_Add(Entity_Tr, &Num_Entity) ; } } } *ExtendedList = Tree2List(Entity_Tr) ; Tree_Delete(Entity_Tr) ; } } /* ------------------------------------------------------------------------ */ /* G e n e r a t e _ G r o u p s O f N o d e s */ /* ------------------------------------------------------------------------ */ void Generate_GroupsOfNodes(List_T * InitialList, List_T ** ExtendedList) { Tree_T * Entity_Tr ; struct Geo_Element * GeoElement ; int Nbr_Element, i_Element, i_Entity ; struct TwoInt Num_GroupOfNodes ; Entity_Tr = Tree_Create(sizeof (struct TwoInt), fcmp_int2) ; Nbr_Element = Geo_GetNbrGeoElements() ; // Message::Info(" Add Node :"); for (i_Element = 0 ; i_Element < Nbr_Element ; i_Element++) { GeoElement = Geo_GetGeoElement(i_Element) ; if (List_Search(InitialList, &GeoElement->Region, fcmp_int) ) { Num_GroupOfNodes.Int2 = GeoElement->Region ; for (i_Entity = 0 ; i_Entity < GeoElement->NbrNodes ; i_Entity++) { Num_GroupOfNodes.Int1 = GeoElement->NumNodes[i_Entity] ; if ( ! Tree_Search(Entity_Tr, &Num_GroupOfNodes) ) { Tree_Add(Entity_Tr, &Num_GroupOfNodes) ; // Message::Info(" (%d, %d)", Num_GroupOfNodes.Int1, Num_GroupOfNodes.Int2); } } } } *ExtendedList = Tree2List(Entity_Tr) ; Tree_Delete(Entity_Tr) ; } /* ------------------------------------------------------------------------ */ /* G e n e r a t e _ G r o u p s O f E d g e s */ /* ------------------------------------------------------------------------ */ void Generate_GroupsOfEdges(List_T * InitialList, int Type_SuppList, List_T * InitialSuppList, List_T ** ExtendedList) { Tree_T * Entity_Tr ; struct Geo_Element * GeoElement ; int Nbr_Element, i_Element, i_Entity, Num_Element ; int * Num_Nodes, Num_Node ; struct TwoInt Num_GroupOfEdges, * Key1_P, * Key2_P ; List_T * ExtendedAuxList ; struct Group * GroupForSupport_P ; int MultiValuedGroup = 0; switch (Type_SuppList) { case SUPPLIST_INSUPPORT : Entity_Tr = Tree_Create(sizeof (struct TwoInt), fcmp_absint2) ; if (List_Nbr(InitialList)) { Generate_GroupsOfNodes(InitialList, &ExtendedAuxList) ; /* Attention : ici, le Support est une liste d'elements ! */ GroupForSupport_P = (struct Group*) List_Pointer(Problem_S.Group, *((int *)List_Pointer(InitialSuppList, 0))) ; if (!GroupForSupport_P->ExtendedList) Generate_ExtendedGroup(GroupForSupport_P) ; Nbr_Element = List_Nbr(GroupForSupport_P->ExtendedList) ; for (i_Element = 0 ; i_Element < Nbr_Element ; i_Element++) { List_Read(GroupForSupport_P->ExtendedList, i_Element, &Num_Element) ; GeoElement = Geo_GetGeoElementOfNum(Num_Element) ; if (GeoElement->NbrEdges == 0) Geo_CreateEdgesOfElement(GeoElement) ; for (i_Entity = 0 ; i_Entity < GeoElement->NbrEdges ; i_Entity++) { Num_Nodes = Geo_GetNodesOfEdgeInElement(GeoElement, i_Entity) ; Num_Node = GeoElement->NumNodes[abs(Num_Nodes[0])-1] ; Key1_P = (struct TwoInt*)List_PQuery(ExtendedAuxList, &Num_Node, fcmp_int) ; Num_Node = GeoElement->NumNodes[abs(Num_Nodes[1])-1] ; Key2_P = (struct TwoInt*)List_PQuery(ExtendedAuxList, &Num_Node, fcmp_int) ; if (Key1_P && (!Key2_P || (Key2_P->Int2 != Key1_P->Int2))) { Num_GroupOfEdges.Int1 = - GeoElement->NumEdges[i_Entity] ; Num_GroupOfEdges.Int2 = Key1_P->Int2 ; if ( ! Tree_Search(Entity_Tr, &Num_GroupOfEdges) ) Tree_Add(Entity_Tr, &Num_GroupOfEdges) ; } if (Key2_P && (!Key1_P || (Key1_P->Int2 != Key2_P->Int2))) { Num_GroupOfEdges.Int1 = GeoElement->NumEdges[i_Entity] ; Num_GroupOfEdges.Int2 = Key2_P->Int2 ; if ( ! Tree_Search(Entity_Tr, &Num_GroupOfEdges) ) Tree_Add(Entity_Tr, &Num_GroupOfEdges) ; } /* if (Key1_P && !Key2_P) { Num_GroupOfEdges.Int1 = - GeoElement->NumEdges[i_Entity] ; Num_GroupOfEdges.Int2 = Key1_P->Int2 ; if ( ! Tree_Search(Entity_Tr, &Num_GroupOfEdges) ) Tree_Add(Entity_Tr, &Num_GroupOfEdges) ; } else if (Key2_P && !Key1_P) { Num_GroupOfEdges.Int1 = GeoElement->NumEdges[i_Entity] ; Num_GroupOfEdges.Int2 = Key2_P->Int2 ; if ( ! Tree_Search(Entity_Tr, &Num_GroupOfEdges) ) Tree_Add(Entity_Tr, &Num_GroupOfEdges) ; } else { if (Key1_P && Key2_P && Key1_P->Int2 != Key2_P->Int2) { Num_GroupOfEdges.Int1 = - GeoElement->NumEdges[i_Entity] ; Num_GroupOfEdges.Int2 = Key1_P->Int2 ; if ( ! Tree_Search(Entity_Tr, &Num_GroupOfEdges) ){ Tree_Add(Entity_Tr, &Num_GroupOfEdges) ; fprintf(stderr, "ADD 1 <========= %d %d %d\n", GeoElement->NumNodes[abs(Num_Nodes[0])-1], Num_GroupOfEdges.Int1, Num_GroupOfEdges.Int2); } Num_GroupOfEdges.Int1 = GeoElement->NumEdges[i_Entity] ; Num_GroupOfEdges.Int2 = Key2_P->Int2 ; if ( ! Tree_Search(Entity_Tr, &Num_GroupOfEdges) ){ Tree_Add(Entity_Tr, &Num_GroupOfEdges) ; fprintf(stderr, "ADD 2 <========= %d %d %d \n", GeoElement->NumNodes[abs(Num_Nodes[1])-1], Num_GroupOfEdges.Int1, Num_GroupOfEdges.Int2); } } } */ } } List_Delete(ExtendedAuxList) ; } *ExtendedList = Tree2List(Entity_Tr) ; Tree_Delete(Entity_Tr) ; break ; case SUPPLIST_NONE : default : MultiValuedGroup = 1; *ExtendedList = List_Create(10,10,sizeof (struct TwoInt)) ; if (List_Nbr(InitialList)) { Generate_GroupsOfNodes(InitialList, &ExtendedAuxList) ; Nbr_Element = Geo_GetNbrGeoElements() ; for (i_Element = 0 ; i_Element < Nbr_Element ; i_Element++) { GeoElement = Geo_GetGeoElement(i_Element) ; if (List_Search(InitialList, &GeoElement->Region, fcmp_int) ) { // when generating edges of line elements, we assume that we want to // keep any multiple copy that might arise, with its sign; this is // required by the cohomology solver if(GeoElement->Type != LINE && GeoElement->Type != LINE_2) MultiValuedGroup = 0; if (GeoElement->NbrEdges == 0) Geo_CreateEdgesOfElement(GeoElement) ; for (i_Entity = 0 ; i_Entity < GeoElement->NbrEdges ; i_Entity++) { Num_Nodes = Geo_GetNodesOfEdgeInElement(GeoElement, i_Entity) ; Num_Node = GeoElement->NumNodes[abs(Num_Nodes[0])-1] ; Key1_P = (struct TwoInt*)List_PQuery(ExtendedAuxList, &Num_Node, fcmp_int) ; Num_Node = GeoElement->NumNodes[abs(Num_Nodes[1])-1] ; Key2_P = (struct TwoInt*)List_PQuery(ExtendedAuxList, &Num_Node, fcmp_int) ; if (Key1_P && Key2_P) { Num_GroupOfEdges.Int1 = GeoElement->NumEdges[i_Entity] ; Num_GroupOfEdges.Int2 = GeoElement->Region ; List_Add(*ExtendedList, &Num_GroupOfEdges); } } } } List_Delete(ExtendedAuxList) ; } // prune list if we are not in the "forced" multivalued case if(!MultiValuedGroup) { Entity_Tr = Tree_Create(sizeof (struct TwoInt), fcmp_absint2) ; for (i_Entity = 0; i_Entity < List_Nbr(*ExtendedList); i_Entity++) { List_Read(*ExtendedList, i_Entity, &Num_GroupOfEdges) ; if (!Tree_Search(Entity_Tr, &Num_GroupOfEdges)) Tree_Add(Entity_Tr, &Num_GroupOfEdges) ; } List_Delete(*ExtendedList) ; *ExtendedList = Tree2List(Entity_Tr); Tree_Delete(Entity_Tr) ; } break; } /* for (i_Entity = 0 ; i_Entity < List_Nbr(*ExtendedList) ; i_Entity++) { List_Read(*ExtendedList, i_Entity, &Num_GroupOfEdges) ; Message::Info(" (%d, %d)", Num_GroupOfEdges.Int1, Num_GroupOfEdges.Int2) ; } */ } /* ------------------------------------------------------------------------ */ /* G e n e r a t e _ G r o u p s O f F a c e s */ /* ------------------------------------------------------------------------ */ void Generate_GroupsOfFacets(List_T * InitialList, List_T ** ExtendedList) { Tree_T * Entity_Tr ; struct Geo_Element * GeoElement ; int Nbr_Element, i_Element, i_Entity ; int * Num_Nodes, Num_Node ; struct TwoInt Num_GroupOfFacets ; List_T * ExtendedAuxList ; int MultiValuedGroup = 1; *ExtendedList = List_Create(10,10,sizeof (struct TwoInt)) ; if (List_Nbr(InitialList)) { Generate_GroupsOfNodes(InitialList, &ExtendedAuxList) ; Nbr_Element = Geo_GetNbrGeoElements() ; for (i_Element = 0 ; i_Element < Nbr_Element ; i_Element++) { GeoElement = Geo_GetGeoElement(i_Element) ; if (List_Search(InitialList, &GeoElement->Region, fcmp_int) ) { // when generating facets of surface elements, we assume that we want to // keep any multiple copy that might arise, with its sign; this is // required by the cohomology solver if(GeoElement->Type != TRIANGLE && GeoElement->Type != TRIANGLE_2 && GeoElement->Type != QUADRANGLE && GeoElement->Type != QUADRANGLE_2 && GeoElement->Type != QUADRANGLE_2_8N) MultiValuedGroup = 0; if (GeoElement->NbrEdges == 0) Geo_CreateEdgesOfElement(GeoElement) ; if (GeoElement->NbrFacets == 0) Geo_CreateFacetsOfElement(GeoElement) ; for (i_Entity = 0 ; i_Entity < GeoElement->NbrFacets ; i_Entity++) { Num_Nodes = Geo_GetNodesOfFacetInElement(GeoElement, i_Entity) ; bool found = true; int i = 0; while(Num_Nodes[i]){ Num_Node = GeoElement->NumNodes[abs(Num_Nodes[i])-1] ; if(!List_PQuery(ExtendedAuxList, &Num_Node, fcmp_int)){ found = false; break; } i++; } if(found){ Num_GroupOfFacets.Int1 = GeoElement->NumFacets[i_Entity] ; Num_GroupOfFacets.Int2 = GeoElement->Region ; List_Add(*ExtendedList, &Num_GroupOfFacets); } } } } List_Delete(ExtendedAuxList) ; } // prune list if we are not in the "forced" multivalued case if(!MultiValuedGroup) { Entity_Tr = Tree_Create(sizeof (struct TwoInt), fcmp_absint2) ; for(i_Entity = 0; i_Entity < List_Nbr(*ExtendedList); i_Entity++) { List_Read(*ExtendedList, i_Entity, &Num_GroupOfFacets) ; if(!Tree_Search(Entity_Tr, &Num_GroupOfFacets)) Tree_Add(Entity_Tr, &Num_GroupOfFacets) ; } List_Delete(*ExtendedList) ; *ExtendedList = Tree2List(Entity_Tr) ; Tree_Delete(Entity_Tr) ; } /* for (i_Entity = 0 ; i_Entity < List_Nbr(*ExtendedList) ; i_Entity++) { List_Read(*ExtendedList, i_Entity, &Num_GroupOfFacets) ; Message::Info(" (%d, %d)", Num_GroupOfFacets.Int1, Num_GroupOfFacets.Int2) ; } */ } /* ------------------------------------------------------------------------ */ /* G e n e r a t e _ E l e m e n t s */ /* ------------------------------------------------------------------------ */ void Generate_Elements(List_T * InitialList, int Type_SuppList, List_T * InitialSuppList, List_T ** ExtendedList) { Tree_T * Entity_Tr ; struct Geo_Element * GeoElement, * GeoElement2 ; struct TwoInt Pair ; int k ; int Nbr_Element, i_Element, i_Element2, Nbr_Node, i_Node, i_Node2 ; List_T * ExtendedSuppList ; Nbr_Element = Geo_GetNbrGeoElements() ; switch (Type_SuppList) { case SUPPLIST_ONONESIDEOF : Entity_Tr = Tree_Create(sizeof(int), fcmp_int) ; if (List_Nbr(InitialSuppList)) { Generate_GroupsOfNodes(InitialSuppList, &ExtendedSuppList) ; for (i_Element = 0 ; i_Element < Nbr_Element ; i_Element++) { GeoElement = Geo_GetGeoElement(i_Element) ; if (List_Search(InitialList, &GeoElement->Region, fcmp_int)) { Nbr_Node = GeoElement->NbrNodes ; for (i_Node = 0 ; i_Node < Nbr_Node ; i_Node++) if (List_Search(ExtendedSuppList, &(GeoElement->NumNodes[i_Node]), fcmp_int)) { Tree_Add(Entity_Tr, &GeoElement->Num) ; break ; /* at least one node of element is on surface Supp */ } } } /* + ne conserver que certains des elements qui viennent d'etre groupes ... ! */ List_Delete(ExtendedSuppList) ; } break ; case SUPPLIST_CONNECTEDTO : Entity_Tr = Tree_Create(sizeof(struct TwoInt), fcmp_int2) ; ExtendedSuppList = List_Create(100,100,sizeof(int)); for (i_Element = 0 ; i_Element < Nbr_Element ; i_Element++) { GeoElement = Geo_GetGeoElement(i_Element) ; if (List_Search(InitialSuppList, &GeoElement->Region, fcmp_int)) List_Add(ExtendedSuppList, &i_Element); } for (i_Element = 0 ; i_Element < Nbr_Element ; i_Element++) { GeoElement = Geo_GetGeoElement(i_Element) ; if (List_Search(InitialList, &GeoElement->Region, fcmp_int)){ for(i_Element2 = 0 ; i_Element2 < List_Nbr(ExtendedSuppList) ; i_Element2++){ GeoElement2 = Geo_GetGeoElement(*(int*)List_Pointer(ExtendedSuppList, i_Element2)) ; k = 0 ; for(i_Node2 = 0 ; i_Node2 < GeoElement2->NbrNodes ; i_Node2++){ for(i_Node = 0 ; i_Node < GeoElement->NbrNodes ; i_Node++){ if(GeoElement2->NumNodes[i_Node2] == GeoElement->NumNodes[i_Node]) k++; } } if(k == GeoElement2->NbrNodes){ Pair.Int1 = GeoElement2->Num ; /* Number of the the element on the boundary */ Pair.Int2 = i_Element ; /* Index of the element connected to all the nodes of the element on the boundary */ Tree_Add(Entity_Tr, &Pair); } } } } List_Delete(ExtendedSuppList) ; break ; case SUPPLIST_NONE : default : Entity_Tr = Tree_Create(sizeof(int), fcmp_int) ; for (i_Element = 0 ; i_Element < Nbr_Element ; i_Element++) { GeoElement = Geo_GetGeoElement(i_Element) ; if (List_Search(InitialList, &GeoElement->Region, fcmp_int)) Tree_Add(Entity_Tr, &GeoElement->Num) ; } break ; } *ExtendedList = Tree2List(Entity_Tr) ; Tree_Delete(Entity_Tr) ; } getdp-2.4.2-source/Legacy/GeoTree.cpp000644 001750 001750 00000016062 12116424202 021041 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "ProData.h" #include "GeoData.h" #include "TreeUtils.h" static int Tree_IndexToChange, Tree_NewIndex ; /* ------------------------------------------------------------------------ */ /* G e o _ G e n e r a t e E d g e s O f T r e e */ /* ------------------------------------------------------------------------ */ void Geo_GenerateEdgesOfTree(List_T * InitialList, List_T * InitialSuppList, List_T ** ExtendedList) { Tree_T * EntitiesInTree_T ; *ExtendedList = List_Create( 2000, 2000, sizeof(int)) ; EntitiesInTree_T = Tree_Create(2*sizeof(int), fcmp_int) ; if (InitialSuppList != NULL) Geo_GenerateEdgesOfSubTree(InitialSuppList, *ExtendedList, EntitiesInTree_T) ; if (InitialList != NULL) Geo_GenerateEdgesOfSubTree(InitialList, *ExtendedList, EntitiesInTree_T) ; Tree_Delete(EntitiesInTree_T) ; List_Sort(*ExtendedList, fcmp_int) ; } /* ------------------------------------------------------------------------ */ /* G e o _ G e n e r a t e F a c e t s O f T r e e */ /* ------------------------------------------------------------------------ */ void Geo_GenerateFacetsOfTree(List_T * InitialList, List_T * InitialSuppList, List_T ** ExtendedList) { Tree_T * EntitiesInTree_T ; *ExtendedList = List_Create( 2000, 2000, sizeof(int)) ; EntitiesInTree_T = Tree_Create(2*sizeof(int), fcmp_int) ; if (InitialSuppList != NULL) Geo_GenerateFacetsOfSubTree(InitialSuppList, *ExtendedList, EntitiesInTree_T) ; if (InitialList != NULL) Geo_GenerateFacetsOfSubTree(InitialList, *ExtendedList, EntitiesInTree_T) ; Tree_Delete(EntitiesInTree_T) ; List_Sort(*ExtendedList, fcmp_int) ; } /* ------------------------------------------------------------------------ */ /* G e o _ G e n e r a t e E d g e s O f S u b T r e e */ /* ------------------------------------------------------------------------ */ void Geo_GenerateEdgesOfSubTree(List_T * InitialList, List_T * ExtendedList, Tree_T * EntitiesInTree_T) { int Nbr_Element, i_Element, Nbr_Entities2, i, Num_Entity1 ; struct Geo_Element * Geo_Element ; int i_Entity2, Num_Entity2, * D_Element, * Entity_P, Entity, Flag_Change ; struct EntityInTree * EntitiesInTree_P[NBR_MAX_ENTITIES_IN_ELEMENT] ; struct EntityInTree EntityInTree_S ; Nbr_Element = Geo_GetNbrGeoElements() ; for (i_Element = 0 ; i_Element < Nbr_Element ; i_Element++) { Geo_Element = Geo_GetGeoElement(i_Element) ; if (List_Search(InitialList, &Geo_Element->Region, fcmp_int) ) { if (Geo_Element->NbrEdges == 0) Geo_CreateEdgesOfElement(Geo_Element) ; D_Element = Geo_GetIM_Den(Geo_Element->Type, &Nbr_Entities2) ; for (i = 0 ; i < Geo_Element->NbrNodes ; i++) { Num_Entity1 = abs(Geo_Element->NumNodes[i]) ; EntitiesInTree_P[i] = (struct EntityInTree*) Tree_PQuery(EntitiesInTree_T, &Num_Entity1) ; } for (i_Entity2 = 0 ; i_Entity2 < Geo_Element->NbrEdges ; i_Entity2++) { Entity_P = D_Element + i_Entity2 * NBR_MAX_SUBENTITIES_IN_ELEMENT ; i = 0 ; EntityInTree_S.Index = -1 ; while ((Entity = abs(Entity_P[i++])) && (EntityInTree_S.Index < 0)) if (EntitiesInTree_P[Entity-1] != NULL) EntityInTree_S.Index = EntitiesInTree_P[Entity-1]->Index ; if (EntityInTree_S.Index < 0) EntityInTree_S.Index = Geo_Element->Num ; Flag_Change = 0 ; while ((Entity = abs(*(Entity_P++)))) { if (EntitiesInTree_P[--Entity] != NULL) { if (EntitiesInTree_P[Entity]->Index != EntityInTree_S.Index) { Tree_IndexToChange = EntitiesInTree_P[Entity]->Index ; Tree_NewIndex = EntityInTree_S.Index ; Tree_Action(EntitiesInTree_T, Geo_ChangeTreeIndex) ; Flag_Change = 1 ; } } else { EntityInTree_S.Num = abs(Geo_Element->NumNodes[Entity]) ; EntitiesInTree_P[Entity] = (struct EntityInTree*) Tree_Add(EntitiesInTree_T, &EntityInTree_S) ; Flag_Change = 1 ; } } if (Flag_Change) { Num_Entity2 = abs(Geo_Element->NumEdges[i_Entity2]) ; List_Add(ExtendedList, &Num_Entity2) ; } } /* for i_Entity2 ... */ } /* if Region ... */ } /* for i_Element ... */ } /* ------------------------------------------------------------------------ */ /* G e o _ G e n e r a t e F a c e t s O f S u b T r e e */ /* ------------------------------------------------------------------------ */ void Geo_GenerateFacetsOfSubTree(List_T * InitialList, List_T * ExtendedList, Tree_T * EntitiesInTree_T) { int Nbr_Element, i_Element, Nbr_Entities2, i, Num_Entity1 ; struct Geo_Element * Geo_Element ; int i_Entity2, Num_Entity2, * D_Element, * Entity_P, Entity, Flag_Change ; struct EntityInTree * EntitiesInTree_P[NBR_MAX_ENTITIES_IN_ELEMENT] ; struct EntityInTree EntityInTree_S ; Nbr_Element = Geo_GetNbrGeoElements() ; for (i_Element = 0 ; i_Element < Nbr_Element ; i_Element++) { Geo_Element = Geo_GetGeoElement(i_Element) ; if (List_Search(InitialList, &Geo_Element->Region, fcmp_int) ) { if (Geo_Element->NbrEdges == 0) Geo_CreateEdgesOfElement(Geo_Element) ; if (Geo_Element->NbrFacets == 0) Geo_CreateFacetsOfElement(Geo_Element) ; D_Element = Geo_GetIM_Dfe(Geo_Element->Type, &Nbr_Entities2) ; for (i = 0 ; i < Geo_Element->NbrEdges ; i++) { Num_Entity1 = abs(Geo_Element->NumEdges[i]) ; EntitiesInTree_P[i] = (struct EntityInTree*) Tree_PQuery(EntitiesInTree_T, &Num_Entity1) ; } for (i_Entity2 = 0 ; i_Entity2 < Geo_Element->NbrFacets ; i_Entity2++) { Entity_P = D_Element + i_Entity2 * NBR_MAX_SUBENTITIES_IN_ELEMENT ; i = 0 ; EntityInTree_S.Index = -1 ; while ((Entity = abs(Entity_P[i++])) && (EntityInTree_S.Index < 0)) if (EntitiesInTree_P[Entity-1] != NULL) EntityInTree_S.Index = EntitiesInTree_P[Entity-1]->Index ; if (EntityInTree_S.Index < 0) EntityInTree_S.Index = Geo_Element->Num ; Flag_Change = 0 ; while ((Entity = abs(*(Entity_P++)))) { if (EntitiesInTree_P[--Entity] != NULL) { if (EntitiesInTree_P[Entity]->Index != EntityInTree_S.Index) { Tree_IndexToChange = EntitiesInTree_P[Entity]->Index ; Tree_NewIndex = EntityInTree_S.Index ; Tree_Action(EntitiesInTree_T, Geo_ChangeTreeIndex) ; Flag_Change = 1 ; } else if (Geo_Element->NbrFacets == 1) Flag_Change = 1 ; } else { EntityInTree_S.Num = abs(Geo_Element->NumEdges[Entity]) ; EntitiesInTree_P[Entity] = (struct EntityInTree*) Tree_Add(EntitiesInTree_T, &EntityInTree_S) ; Flag_Change = 1 ; } } if (Flag_Change) { Num_Entity2 = abs(Geo_Element->NumFacets[i_Entity2]) ; List_Add(ExtendedList, &Num_Entity2) ; } } /* for i_Entity2 ... */ } /* if Region ... */ } /* for i_Element ... */ } void Geo_ChangeTreeIndex(void * a, void * b) { if (((struct EntityInTree *)a)->Index == Tree_IndexToChange) ((struct EntityInTree *)a)->Index = Tree_NewIndex ; } getdp-2.4.2-source/Legacy/Pos_Iso.cpp000644 001750 001750 00000014035 12116424202 021060 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "ProData.h" #include "Pos_Element.h" #include "Message.h" #define PSCA3(a,b) ((a)[0]*(b)[0] + (a)[1]*(b)[1] + (a)[2]*(b)[2]) extern struct CurrentData Current ; /* ------------------------------------------------------------------------ */ /* C a l _ I s o */ /* ------------------------------------------------------------------------ */ void Interpolate(double *X, double *Y, double *Z, struct Value *Val, double V, int I1, int I2, double *XI, double *YI ,double *ZI) { if(Val[I1].Val[0] == Val[I2].Val[0]){ *XI = X[I1]; *YI = Y[I1]; *ZI = Z[I1]; } else{ *XI= (V - Val[I1].Val[0])*(X[I2]-X[I1])/(Val[I2].Val[0]-Val[I1].Val[0]) + X[I1]; *YI= (V - Val[I1].Val[0])*(Y[I2]-Y[I1])/(Val[I2].Val[0]-Val[I1].Val[0]) + Y[I1]; *ZI= (V - Val[I1].Val[0])*(Z[I2]-Z[I1])/(Val[I2].Val[0]-Val[I1].Val[0]) + Z[I1]; } } void Cal_IsoTetrahedron(double *X, double *Y, double *Z, struct Value *Val, double V, double Vmin, double Vmax, double *Xp, double *Yp, double *Zp, int *nb) { *nb = 0; if((Val[0].Val[0] >= V && Val[1].Val[0] <= V) || (Val[1].Val[0] >= V && Val[0].Val[0] <= V)){ Interpolate(X,Y,Z,Val,V,0,1,&Xp[*nb],&Yp[*nb],&Zp[*nb]); (*nb)++; } if((Val[0].Val[0] >= V && Val[2].Val[0] <= V) || (Val[2].Val[0] >= V && Val[0].Val[0] <= V)){ Interpolate(X,Y,Z,Val,V,0,2,&Xp[*nb],&Yp[*nb],&Zp[*nb]); (*nb)++; } if((Val[0].Val[0] >= V && Val[3].Val[0] <= V) || (Val[3].Val[0] >= V && Val[0].Val[0] <= V)){ Interpolate(X,Y,Z,Val,V,0,3,&Xp[*nb],&Yp[*nb],&Zp[*nb]); (*nb)++; } if((Val[1].Val[0] >= V && Val[2].Val[0] <= V) || (Val[2].Val[0] >= V && Val[1].Val[0] <= V)){ Interpolate(X,Y,Z,Val,V,1,2,&Xp[*nb],&Yp[*nb],&Zp[*nb]); (*nb)++; } if((Val[1].Val[0] >= V && Val[3].Val[0] <= V) || (Val[3].Val[0] >= V && Val[1].Val[0] <= V)){ Interpolate(X,Y,Z,Val,V,1,3,&Xp[*nb],&Yp[*nb],&Zp[*nb]); (*nb)++; } if((Val[2].Val[0] >= V && Val[3].Val[0] <= V) || (Val[3].Val[0] >= V && Val[2].Val[0] <= V)){ Interpolate(X,Y,Z,Val,V,2,3,&Xp[*nb],&Yp[*nb],&Zp[*nb]); (*nb)++; } } void Cal_IsoTriangle(double *X, double *Y, double *Z, struct Value *Val, double V, double Vmin, double Vmax, double *Xp, double *Yp, double *Zp, int *nb) { *nb = 0; if((Val[0].Val[0] >= V && Val[1].Val[0] <= V) || (Val[1].Val[0] >= V && Val[0].Val[0] <= V)){ Interpolate(X,Y,Z,Val,V,0,1,&Xp[*nb],&Yp[*nb],&Zp[*nb]); (*nb)++; } if((Val[0].Val[0] >= V && Val[2].Val[0] <= V) || (Val[2].Val[0] >= V && Val[0].Val[0] <= V)){ Interpolate(X,Y,Z,Val,V,0,2,&Xp[*nb],&Yp[*nb],&Zp[*nb]); (*nb)++; } if((Val[1].Val[0] >= V && Val[2].Val[0] <= V) || (Val[2].Val[0] >= V && Val[1].Val[0] <= V)){ Interpolate(X,Y,Z,Val,V,1,2,&Xp[*nb],&Yp[*nb],&Zp[*nb]); (*nb)++; } } void Fill_Iso(struct PostElement *PE, int nb, int *index, double *x, double *y, double *z, double val) { int i, k ; for (i = 0 ; i < nb ; i++){ PE->x[i] = x[index[i]] ; PE->y[i] = y[index[i]] ; PE->z[i] = z[index[i]] ; PE->Value[i].Type = SCALAR ; PE->Value[i].Val[0] = val ; for (k = 1 ; k < Current.NbrHar ; k++) PE->Value[i].Val[MAX_DIM*k] = 0. ; } } void normvec(double *a); void Cal_Iso(struct PostElement *PE, List_T *list, double val, double vmin, double vmax, int DecomposeInSimplex) { struct PostElement *PE2 ; double x[5], y[5], z[5] ; double d1[3], d2[3], d3[3], a1, a2, a3 ; int nb, index[5], index_default[] = {0,1,2,3} ; switch(PE->Type){ case TRIANGLE : case TRIANGLE_2 : Cal_IsoTriangle(PE->x, PE->y, PE->z, PE->Value, val, vmin, vmax, x, y, z, &nb) ; if(nb == 2){ PE2 = Create_PostElement(PE->Index, LINE, 2, 1) ; Fill_Iso(PE2, nb, index_default, x, y, z, val) ; List_Add(list, &PE2); } break ; case TETRAHEDRON : Cal_IsoTetrahedron(PE->x, PE->y, PE->z, PE->Value, val, vmin, vmax, x, y, z, &nb) ; if(nb == 3){ PE2 = Create_PostElement(PE->Index, TRIANGLE, 3, 1) ; Fill_Iso(PE2, nb, index_default, x, y, z, val) ; List_Add(list, &PE2); } else if(nb == 4){ if(DecomposeInSimplex){ d1[0] = x[0] - x[1] ; d1[1] = y[0] - y[1] ; d1[2] = z[0] - z[1] ; d2[0] = x[0] - x[2] ; d2[1] = y[0] - y[2] ; d2[2] = z[0] - z[2] ; d3[0] = x[0] - x[3] ; d3[1] = y[0] - y[3] ; d3[2] = z[0] - z[3] ; normvec(d1) ; normvec(d2) ; normvec(d3) ; a1 = acos(PSCA3(d1,d2)) ; a2 = acos(PSCA3(d1,d3)) ; a3 = acos(PSCA3(d2,d3)) ; if(a1 >= a2 && a1 >= a3){ PE2 = Create_PostElement(PE->Index, TRIANGLE, 3, 1) ; index[0] = 0 ; index[1] = 1 ; index[2] = 2 ; Fill_Iso(PE2, 3, index, x, y, z, val) ; List_Add(list, &PE2); PE2 = Create_PostElement(PE->Index, TRIANGLE, 3, 1) ; index[0] = 3 ; index[1] = 2 ; index[2] = 1 ; Fill_Iso(PE2, 3, index, x, y, z, val) ; List_Add(list, &PE2); } else if(a2 >= a1 && a2 >= a3){ PE2 = Create_PostElement(PE->Index, TRIANGLE, 3, 1) ; index[0] = 0 ; index[1] = 1 ; index[2] = 3 ; Fill_Iso(PE2, 3, index, x, y, z, val) ; List_Add(list, &PE2); PE2 = Create_PostElement(PE->Index, TRIANGLE, 3, 1) ; index[0] = 2 ; index[1] = 3 ; index[2] = 1 ; Fill_Iso(PE2, 3, index, x, y, z, val) ; List_Add(list, &PE2); } else{ PE2 = Create_PostElement(PE->Index, TRIANGLE, 3, 1) ; index[0] = 0 ; index[1] = 2 ; index[2] = 3 ; Fill_Iso(PE2, 3, index, x, y, z, val) ; List_Add(list, &PE2); PE2 = Create_PostElement(PE->Index, TRIANGLE, 3, 1) ; index[0] = 1 ; index[1] = 3 ; index[2] = 2 ; Fill_Iso(PE2, 3, index, x, y, z, val) ; List_Add(list, &PE2); } } else{ PE2 = Create_PostElement(PE->Index, QUADRANGLE, 4, 1) ; Fill_Iso(PE2, nb, index_default, x, y, z, val) ; List_Add(list, &PE2); } } break ; default : Message::Error("Iso computation not done for this type of element"); break ; } } getdp-2.4.2-source/Legacy/DofData.cpp000644 001750 001750 00000170634 12166744450 021036 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Johan Gyselinck // Ruth Sabariego // #include #include #include #include #include "GetDPVersion.h" #include "ProData.h" #include "DofData.h" #include "GeoData.h" #include "ExtendedGroup.h" #include "ListUtils.h" #include "TreeUtils.h" #include "MallocUtils.h" #include "Message.h" #include "OS.h" #define TWO_PI 6.2831853071795865 extern struct Problem Problem_S ; extern struct CurrentData Current ; FILE * File_PRE = 0, * File_RES = 0, * File_TMP = 0 ; struct DofData * CurrentDofData ; int fcmp_Dof(const void * a, const void * b) { int Result ; if ((Result = ((struct Dof *)a)->NumType - ((struct Dof *)b)->NumType) != 0) return Result ; if ((Result = ((struct Dof *)a)->Entity - ((struct Dof *)b)->Entity) != 0) return Result ; return ((struct Dof *)a)->Harmonic - ((struct Dof *)b)->Harmonic ; } /* ------------------------------------------------------------------------ */ /* D o f _ I n i t D o f D a t a */ /* ------------------------------------------------------------------------ */ void Dof_InitDofData(struct DofData * DofData_P, int Num, int ResolutionIndex, int SystemIndex, char * Name_SolverDataFile) { int Index ; DofData_P->Num = Num ; DofData_P->ResolutionIndex = ResolutionIndex ; DofData_P->SystemIndex = SystemIndex ; DofData_P->FunctionSpaceIndex = NULL ; DofData_P->TimeFunctionIndex = List_Create(10, 5, sizeof(int)) ; Index = 0 ; List_Add(DofData_P->TimeFunctionIndex, &Index) ; DofData_P->Pulsation = NULL ; DofData_P->Val_Pulsation = NULL ; DofData_P->NbrHar = 1 ; DofData_P->NbrAnyDof = 0 ; DofData_P->NbrDof = 0 ; DofData_P->DofTree = Tree_Create(sizeof(struct Dof), fcmp_Dof) ; DofData_P->DofList = NULL ; DofData_P->SolverDataFileName = Name_SolverDataFile ; DofData_P->Flag_RHS = 0 ; DofData_P->Flag_Init[0] = 0 ; DofData_P->Flag_Init[1] = 0 ; DofData_P->Flag_Init[2] = 0 ; DofData_P->Flag_Init[3] = 0 ; DofData_P->Flag_Only = 0 ; DofData_P->Flag_InitOnly[0] = 0 ; DofData_P->Flag_InitOnly[1] = 0 ; DofData_P->Flag_InitOnly[2] = 0 ; DofData_P->OnlyTheseMatrices = NULL; DofData_P->Solutions = NULL ; DofData_P->CurrentSolution = NULL ; DofData_P->CorrectionSolutions.Flag = 0; DofData_P->CorrectionSolutions.AllSolutions = NULL; DofData_P->DummyDof = NULL ; } /* ------------------------------------------------------------------------ */ /* D o f _ F r e e D o f D a t a */ /* ------------------------------------------------------------------------ */ void Dof_FreeDofData(struct DofData * DofData_P) { Message::Debug("Freeing DofData %d", DofData_P->Num); List_Delete(DofData_P->FunctionSpaceIndex); List_Delete(DofData_P->TimeFunctionIndex); List_Delete(DofData_P->Pulsation); Tree_Delete(DofData_P->DofTree); List_Delete(DofData_P->DofList); Free(DofData_P->DummyDof); if(DofData_P->Solutions){ for(int i = 0; i < List_Nbr(DofData_P->Solutions); i++){ Solution *Solution_P = (struct Solution*)List_Pointer(DofData_P->Solutions, i); if(Solution_P->SolutionExist){ LinAlg_DestroyVector(&Solution_P->x); Free(Solution_P->TimeFunctionValues) ; Solution_P->TimeFunctionValues = NULL; Solution_P->SolutionExist = 0; } } List_Delete(DofData_P->Solutions); } List_Delete(DofData_P->OnlyTheseMatrices); if(DofData_P->Flag_Init[0] == 1 || DofData_P->Flag_Init[0] == 2){ LinAlg_DestroyMatrix(&DofData_P->A); LinAlg_DestroyVector(&DofData_P->b); LinAlg_DestroySolver(&DofData_P->Solver); } if(DofData_P->Flag_Init[0] == 2){ LinAlg_DestroyMatrix(&DofData_P->Jac); LinAlg_DestroyVector(&DofData_P->res); LinAlg_DestroyVector(&DofData_P->dx); } if(DofData_P->Flag_Init[1] == 1){ LinAlg_DestroyMatrix(&DofData_P->M1); LinAlg_DestroyVector(&DofData_P->m1); for(int i = 0; i < List_Nbr(DofData_P->m1s); i++) LinAlg_DestroyVector((gVector*)List_Pointer(DofData_P->m1s, i)); List_Delete(DofData_P->m1s); } if(DofData_P->Flag_Init[2] == 1){ LinAlg_DestroyMatrix(&DofData_P->M2); LinAlg_DestroyVector(&DofData_P->m2); for(int i = 0; i < List_Nbr(DofData_P->m2s); i++) LinAlg_DestroyVector((gVector*)List_Pointer(DofData_P->m2s, i)); List_Delete(DofData_P->m2s); } if(DofData_P->Flag_Init[3] == 1){ LinAlg_DestroyMatrix(&DofData_P->M3); LinAlg_DestroyVector(&DofData_P->m3); for(int i = 0; i < List_Nbr(DofData_P->m3s); i++) LinAlg_DestroyVector((gVector*)List_Pointer(DofData_P->m3s, i)); List_Delete(DofData_P->m3s); } if(DofData_P->Flag_Only){ if(DofData_P->Flag_InitOnly[0] == 1){ LinAlg_DestroyMatrix(&DofData_P->A1); LinAlg_DestroyVector(&DofData_P->b1); } if(DofData_P->Flag_InitOnly[1] == 1){ LinAlg_DestroyMatrix(&DofData_P->A2); LinAlg_DestroyVector(&DofData_P->b2); } if(DofData_P->Flag_InitOnly[2] == 1){ LinAlg_DestroyMatrix(&DofData_P->A3); LinAlg_DestroyVector(&DofData_P->b3); } } // TODO: handle MH data and CorrectionSolutions } /* ------------------------------------------------------------------------ */ /* D o f _ S e t C u r r e n t D o f D a t a */ /* ------------------------------------------------------------------------ */ void Dof_SetCurrentDofData(struct DofData * DofData_P) { CurrentDofData = DofData_P ; } /* ------------------------------------------------------------------------ */ /* F i l e s . . . */ /* ------------------------------------------------------------------------ */ /* ------------------------------------------------------------------------ */ /* D o f _ O p e n F i l e */ /* ------------------------------------------------------------------------ */ void Dof_OpenFile(int Type, char * Name, const char * Mode) { if((Message::GetIsCommWorld() && Message::GetCommRank()) && (Mode[0] == 'w' || Mode[0] == 'a')){ switch (Type) { case DOF_PRE : File_PRE = 0 ; break ; case DOF_RES : File_RES = 0 ; break ; case DOF_TMP : File_RES = 0 ; break ; default : break ; } return; } const char * Extension; char FileName[256] ; FILE * File_X ; switch (Type) { case DOF_PRE : Extension = ".pre" ; break ; case DOF_RES : Extension = "" ; break ; case DOF_TMP : Extension = "" ; break ; default : Extension = ".pre" ; break ; } strcpy(FileName, Name) ; strcat(FileName, Extension) ; if (!(File_X = FOpen(FileName, Mode))) Message::Error("Unable to open file '%s'", FileName) ; switch (Type) { case DOF_PRE : File_PRE = File_X ; break ; case DOF_RES : File_RES = File_X ; break ; case DOF_TMP : File_TMP = File_RES ; File_RES = File_X ; break ; default : break ; } } /* ------------------------------------------------------------------------ */ /* D o f _ C l o s e F i l e */ /* ------------------------------------------------------------------------ */ void Dof_CloseFile(int Type) { switch (Type) { case DOF_PRE : if(File_PRE) fclose(File_PRE) ; break ; case DOF_RES : if(File_RES) fclose(File_RES) ; break ; case DOF_TMP : if(File_RES) fclose(File_RES) ; File_RES = File_TMP ; break ; } } /* ------------------------------------------------------------------------ */ /* D o f _ F l u s h F i l e */ /* ------------------------------------------------------------------------ */ void Dof_FlushFile(int Type) { switch (Type) { case DOF_PRE : fflush(File_PRE) ; break ; case DOF_RES : fflush(File_RES) ; break ; } } /* ------------------------------------------------------------------------ */ /* D o f _ W r i t e F i l e P R E 0 */ /* ------------------------------------------------------------------------ */ void Dof_WriteFilePRE0(int Num_Resolution, char * Name_Resolution, int Nbr_DofData) { if(Message::GetIsCommWorld() && Message::GetCommRank()) return; fprintf(File_PRE, "$Resolution /* '%s' */\n", Name_Resolution) ; fprintf(File_PRE, "%d %d\n", Num_Resolution, Nbr_DofData) ; fprintf(File_PRE, "$EndResolution\n") ; } /* ------------------------------------------------------------------------ */ /* D o f _ R e a d F i l e P R E 0 */ /* ------------------------------------------------------------------------ */ void Dof_ReadFilePRE0(int * Num_Resolution, int * Nbr_DofData) { Message::Barrier(); char String[256] ; do { fgets(String, sizeof(String), File_PRE) ; if (feof(File_PRE)) break ; } while (String[0] != '$') ; if (feof(File_PRE)){ Message::Error("$Resolution field not found in file"); return; } if (!strncmp(&String[1], "Resolution", 10)) { fscanf(File_PRE, "%d %d", Num_Resolution, Nbr_DofData) ; } do { fgets(String, sizeof(String), File_PRE) ; if (feof(File_PRE)){ Message::Error("Prematured end of file"); return; } } while (String[0] != '$') ; } /* ------------------------------------------------------------------------ */ /* D o f _ W r i t e F i l e P R E */ /* ------------------------------------------------------------------------ */ void Dof_WriteFilePRE(struct DofData * DofData_P) { if(Message::GetIsCommWorld() && Message::GetCommRank()) return; int i, Nbr_Index ; struct Dof * Dof_P0 ; fprintf(File_PRE, "$DofData /* #%d */\n", DofData_P->Num) ; fprintf(File_PRE, "%d %d\n", DofData_P->ResolutionIndex, DofData_P->SystemIndex) ; Nbr_Index = List_Nbr(DofData_P->FunctionSpaceIndex) ; fprintf(File_PRE, "%d", Nbr_Index) ; for (i = 0 ; i < Nbr_Index ; i++) fprintf(File_PRE, " %d", *((int *)List_Pointer(DofData_P->FunctionSpaceIndex, i))) ; fprintf(File_PRE, "\n") ; Nbr_Index = List_Nbr(DofData_P->TimeFunctionIndex) ; fprintf(File_PRE, "%d", Nbr_Index) ; for (i = 0 ; i < Nbr_Index ; i++) fprintf(File_PRE, " %d", *((int *)List_Pointer(DofData_P->TimeFunctionIndex, i))) ; fprintf(File_PRE, "\n") ; fprintf(File_PRE, "%d", 1) ; for(i = 0 ; i < 1 ; i++) fprintf(File_PRE, " %d", 0) ; fprintf(File_PRE, "\n") ; fprintf(File_PRE, "%d %d\n", (DofData_P->DofTree)? Tree_Nbr(DofData_P->DofTree) : DofData_P->NbrAnyDof, DofData_P->NbrDof) ; if (DofData_P->DofTree) Tree_Action(DofData_P->DofTree, Dof_WriteDofPRE) ; else { if (DofData_P->NbrAnyDof){ Dof_P0 = (struct Dof *)List_Pointer(DofData_P->DofList, 0) ; for (i = 0 ; i < DofData_P->NbrAnyDof ; i++) Dof_WriteDofPRE(Dof_P0 + i, NULL) ; } } fprintf(File_PRE, "$EndDofData\n") ; fflush(File_PRE) ; } /* ------------------------------- */ /* D o f _ W r i t e D o f P R E */ /* ------------------------------- */ void Dof_WriteDofPRE(void * a, void * b) { struct Dof * Dof_P ; Dof_P = (struct Dof *) a ; fprintf(File_PRE, "%d %d %d %d ", Dof_P->NumType, Dof_P->Entity, Dof_P->Harmonic, Dof_P->Type) ; switch (Dof_P->Type) { case DOF_UNKNOWN : fprintf(File_PRE, "%d %d\n", Dof_P->Case.Unknown.NumDof, Dof_P->Case.Unknown.NonLocal ? -1 : 1) ; break ; case DOF_FIXEDWITHASSOCIATE : fprintf(File_PRE, "%d ", Dof_P->Case.FixedAssociate.NumDof) ; LinAlg_PrintScalar(File_PRE, &Dof_P->Val); fprintf(File_PRE, " %d\n", Dof_P->Case.FixedAssociate.TimeFunctionIndex) ; break ; case DOF_FIXED : LinAlg_PrintScalar(File_PRE, &Dof_P->Val); fprintf(File_PRE, " %d\n", Dof_P->Case.FixedAssociate.TimeFunctionIndex) ; break ; case DOF_FIXED_SOLVE : fprintf(File_PRE, "%d\n", Dof_P->Case.FixedAssociate.TimeFunctionIndex) ; break ; case DOF_UNKNOWN_INIT : fprintf(File_PRE, "%d ", Dof_P->Case.Unknown.NumDof) ; LinAlg_PrintScalar(File_PRE, &Dof_P->Val); fprintf(File_PRE, " ") ; LinAlg_PrintScalar(File_PRE, &Dof_P->Val2); fprintf(File_PRE, " %d\n", Dof_P->Case.Unknown.NonLocal ? -1 : 1) ; break ; case DOF_LINK : fprintf(File_PRE, "%.16g %d\n", Dof_P->Case.Link.Coef, Dof_P->Case.Link.EntityRef) ; break ; case DOF_LINKCPLX : fprintf(File_PRE, "%.16g %.16g %d\n", Dof_P->Case.Link.Coef, Dof_P->Case.Link.Coef2, Dof_P->Case.Link.EntityRef) ; break ; } } /* ------------------------------------------------------------------------ */ /* D o f _ R e a d F i l e P R E */ /* ------------------------------------------------------------------------ */ void Dof_ReadFilePRE(struct DofData * DofData_P) { Message::Barrier(); int i, Nbr_Index, Int, Dummy ; struct Dof Dof ; char String[256] ; do { fgets(String, sizeof(String), File_PRE) ; if (feof(File_PRE)) break ; } while (String[0] != '$') ; if (feof(File_PRE)){ Message::Error("$DofData field not found in file"); return; } if (!strncmp(&String[1], "DofData", 7)) { fscanf(File_PRE, "%d %d", &DofData_P->ResolutionIndex, &DofData_P->SystemIndex) ; fscanf(File_PRE, "%d", &Nbr_Index) ; DofData_P->FunctionSpaceIndex = List_Create(Nbr_Index, 1, sizeof(int)) ; for (i = 0 ; i < Nbr_Index ; i++) { fscanf(File_PRE, "%d", &Int) ; List_Add(DofData_P->FunctionSpaceIndex, &Int) ; } fscanf(File_PRE, "%d", &Nbr_Index) ; DofData_P->TimeFunctionIndex = List_Create(Nbr_Index, 1, sizeof(int)) ; for (i = 0 ; i < Nbr_Index ; i++) { fscanf(File_PRE, "%d", &Int) ; List_Add(DofData_P->TimeFunctionIndex, &Int) ; } fscanf(File_PRE, "%d", &Dummy) ; for(i = 0 ; i < 1 ; i++) fscanf(File_PRE, "%d", &Dummy) ; fscanf(File_PRE, "%d %d", &DofData_P->NbrAnyDof, &DofData_P->NbrDof) ; DofData_P->DofList = List_Create(DofData_P->NbrAnyDof, 1, sizeof(struct Dof)) ; for (i = 0 ; i < DofData_P->NbrAnyDof ; i++) { fscanf(File_PRE, "%d %d %d %d", &Dof.NumType, &Dof.Entity, &Dof.Harmonic, &Dof.Type) ; switch (Dof.Type) { case DOF_UNKNOWN : fscanf(File_PRE, "%d", &Dof.Case.Unknown.NumDof) ; fscanf(File_PRE, "%d", &Dummy) ; Dof.Case.Unknown.NonLocal = (Dummy < 0) ? true : false; if(Dummy < 0) DofData_P->NonLocalEquations.push_back(Dof.Case.Unknown.NumDof); break ; case DOF_FIXEDWITHASSOCIATE : fscanf(File_PRE, "%d", &Dof.Case.FixedAssociate.NumDof) ; LinAlg_ScanScalar(File_PRE, &Dof.Val) ; fscanf(File_PRE, "%d", &Dof.Case.FixedAssociate.TimeFunctionIndex) ; break ; case DOF_FIXED : LinAlg_ScanScalar(File_PRE, &Dof.Val) ; fscanf(File_PRE, "%d", &Dof.Case.FixedAssociate.TimeFunctionIndex) ; break ; case DOF_FIXED_SOLVE : fscanf(File_PRE, "%d", &Dof.Case.FixedAssociate.TimeFunctionIndex) ; break ; case DOF_UNKNOWN_INIT : fscanf(File_PRE, "%d", &Dof.Case.Unknown.NumDof) ; LinAlg_ScanScalar(File_PRE, &Dof.Val) ; LinAlg_ScanScalar(File_PRE, &Dof.Val2) ; fscanf(File_PRE, "%d", &Dummy) ; Dof.Case.Unknown.NonLocal = (Dummy < 0) ? true : false; if(Dummy < 0) DofData_P->NonLocalEquations.push_back(Dof.Case.Unknown.NumDof); break ; case DOF_LINK : fscanf(File_PRE, "%lf %d", &Dof.Case.Link.Coef, &Dof.Case.Link.EntityRef) ; Dof.Case.Link.Dof = NULL ; break ; case DOF_LINKCPLX : fscanf(File_PRE, "%lf %lf %d", &Dof.Case.Link.Coef, &Dof.Case.Link.Coef2, &Dof.Case.Link.EntityRef) ; Dof.Case.Link.Dof = NULL ; break ; } List_Add(DofData_P->DofList, &Dof) ; } } do { fgets(String, sizeof(String), File_PRE) ; if (feof(File_PRE)){ Message::Error("Prematured end of file"); return; } } while (String[0] != '$') ; Dof_InitDofType(DofData_P) ; } /* ------------------------------------------------------------------------ */ /* D o f _ W r i t e F i l e R E S 0 */ /* ------------------------------------------------------------------------ */ void Dof_WriteFileRES0(char * Name_File, int Format) { if(Message::GetIsCommWorld() && Message::GetCommRank()) return; Dof_OpenFile(DOF_RES, Name_File, (char*)(Format ? "wb" : "w")) ; fprintf(File_RES, "$ResFormat /* GetDP %s, %s */\n", GETDP_VERSION, Format ? "binary" : "ascii") ; fprintf(File_RES, "1.1 %d\n", Format) ; fprintf(File_RES, "$EndResFormat\n") ; Dof_CloseFile(DOF_RES) ; } /* ------------------------------------------------------------------------ */ /* D o f _ W r i t e F i l e R E S _ E x t e n d M H */ /* ------------------------------------------------------------------------ */ void Dof_WriteFileRES_ExtendMH(char * Name_File, struct DofData * DofData_P, int Format, int NbrH) { if(Message::GetIsCommWorld() && Message::GetCommRank()) return; gVector x; double d; int i, inew; Dof_OpenFile(DOF_RES, Name_File, (char*)(Format ? "ab" : "a")) ; fprintf(File_RES, "$Solution /* DofData #%d */\n", DofData_P->Num) ; fprintf(File_RES, "%d 0 0 0 \n", DofData_P->Num) ; LinAlg_CreateVector(&x, &DofData_P->Solver, (DofData_P->NbrDof / Current.NbrHar) * NbrH) ; LinAlg_ZeroVector(&x) ; for (i=0 ; iNbrDof ; i++){ LinAlg_GetDoubleInVector(&d, &DofData_P->CurrentSolution->x, i); inew = (i / Current.NbrHar) * NbrH + i % Current.NbrHar; LinAlg_SetDoubleInVector(d, &x, inew); } Format ? LinAlg_WriteVector(File_RES,&x) : LinAlg_PrintVector(File_RES,&x) ; fprintf(File_RES, "$EndSolution\n") ; Dof_CloseFile(DOF_RES) ; LinAlg_DestroyVector(&x) ; } void Dof_WriteFileRES_MHtoTime(char * Name_File, struct DofData * DofData_P, int Format, List_T * Time_L) { if(Message::GetIsCommWorld() && Message::GetCommRank()) return; gVector x; double Time, d1, d2, d, *Pulsation; int iT, i, j, k; Dof_OpenFile(DOF_RES, Name_File, (char*)(Format ? "ab" : "a")) ; for(iT=0 ; iTNum) ; fprintf(File_RES, "%d %e 0 %d \n", DofData_P->Num,Time,iT) ; Pulsation = DofData_P->Val_Pulsation ; LinAlg_CreateVector(&x, &DofData_P->Solver, DofData_P->NbrDof/Current.NbrHar) ; LinAlg_ZeroVector(&x) ; for (i=0 ; iNbrDof/Current.NbrHar ; i++) { d = 0; for (k=0 ; kCurrentSolution->x, j) ; LinAlg_GetDoubleInVector(&d2, &DofData_P->CurrentSolution->x, j+1) ; d += d1 * cos(Pulsation[k]*Time) - d2 * sin(Pulsation[k]*Time) ; } LinAlg_SetDoubleInVector(d, &x, i) ; } Format ? LinAlg_WriteVector(File_RES,&x) : LinAlg_PrintVector(File_RES,&x) ; fprintf(File_RES, "$EndSolution\n") ; } Dof_CloseFile(DOF_RES) ; LinAlg_DestroyVector(&x) ; } /* ------------------------------------------------------------------------ */ /* D o f _ W r i t e F i l e R E S */ /* ------------------------------------------------------------------------ */ void Dof_WriteFileRES(char * Name_File, struct DofData * DofData_P, int Format, double Val_Time, double Val_TimeImag, int Val_TimeStep) { if(Message::GetIsCommWorld() && Message::GetCommRank()) return; Dof_OpenFile(DOF_RES, Name_File, (char*)(Format ? "ab" : "a")) ; fprintf(File_RES, "$Solution /* DofData #%d */\n", DofData_P->Num) ; fprintf(File_RES, "%d %.16g %.16g %d\n", DofData_P->Num, Val_Time, Val_TimeImag, Val_TimeStep) ; Format ? LinAlg_WriteVector(File_RES, &DofData_P->CurrentSolution->x) : LinAlg_PrintVector(File_RES, &DofData_P->CurrentSolution->x) ; fprintf(File_RES, "$EndSolution\n") ; Dof_CloseFile(DOF_RES) ; } /* ------------------------------------------------------------------------ */ /* D o f _ W r i t e F i l e R E S _ W i t h E n t i t y N u m */ /* ------------------------------------------------------------------------ */ void Dof_WriteFileRES_WithEntityNum(char * Name_File, struct DofData * DofData_P, struct GeoData * GeoData_P0, struct Group *Group_P, bool saveFixed) { if(Message::GetIsCommWorld() && Message::GetCommRank()) return; char FileCplx[256] ; char FileRe[256] ; char FileIm[256] ; strcpy(FileCplx, Name_File) ; strcat(FileCplx, ".txt") ; strcpy(FileRe, Name_File) ; strcat(FileRe, "_Re.txt") ; strcpy(FileIm, Name_File) ; strcat(FileIm, "_Im.txt") ; FILE *fp = FOpen(FileCplx, "w"); if(!fp){ Message::Error("Unable to open file '%s'", FileCplx) ; return; } FILE *fpRe = FOpen(FileRe, "w"); if(!fpRe){ Message::Error("Unable to open file '%s'", FileRe) ; return; } FILE *fpIm = FOpen(FileIm, "w"); if(!fpIm){ Message::Error("Unable to open file '%s'", FileIm) ; return; } std::map > unknowns; List_T *l = !DofData_P->DofList ? Tree2List(DofData_P->DofTree) : 0; int N = l ? List_Nbr(l) : List_Nbr(DofData_P->DofList); for(int i = 0; i < N; i++){ Dof *dof; if(l) List_Read(l, i, &dof); else dof = (Dof*)List_Pointer(DofData_P->DofList, i); if(dof->Type == DOF_UNKNOWN){ gScalar s; LinAlg_GetScalarInVector(&s, &DofData_P->CurrentSolution->x, dof->Case.Unknown.NumDof - 1); unknowns[dof->Entity] = s.s; } if(saveFixed && dof->Type == DOF_FIXED){ unknowns[dof->Entity] = dof->Val.s; } } if(!Group_P){ fprintf(fpRe, "%d\n", N);//Needed for ListFromFile fprintf(fpIm, "%d\n", N); for(std::map >::iterator it = unknowns.begin(); it != unknowns.end(); it++){ fprintf(fp , "%d %.16g %.16g\n", it->first, it->second.real(), it->second.imag()); fprintf(fpRe, "%d %.16g\n", it->first, it->second.real()); fprintf(fpIm, "%d %.16g\n", it->first, it->second.imag()); } } else{ Message::Info("Writing solution for all entities in group '%s'", Group_P->Name) ; // force generation of extended list (necessary when using // multiple meshes) List_Delete(Group_P->ExtendedList); Generate_ExtendedGroup(Group_P) ; fprintf(fpRe, "%d\n", List_Nbr(Group_P->ExtendedList));//Needed for ListFromFile fprintf(fpIm, "%d\n", List_Nbr(Group_P->ExtendedList)); for(int i = 0; i < List_Nbr(Group_P->ExtendedList); i++){ int num; List_Read(Group_P->ExtendedList, i, &num); if(!Group_P->InitialSuppList || (!List_Search(Group_P->ExtendedSuppList, &num, fcmp_int))){ // SuppList assumed to be "Not"! if(unknowns.count(num)){ std::complex s = unknowns[num]; fprintf(fp, "%d %.16g %.16g\n", num, s.real(), s.imag()); fprintf(fpRe, "%d %.16g\n", num, s.real()); fprintf(fpIm, "%d %.16g\n", num, s.imag()); } else{ // yes, write zero: that's on purpose for the iterative schemes fprintf(fp, "%d 0 0\n", num); fprintf(fpRe, "%d 0\n", num); fprintf(fpIm, "%d 0\n", num); } } } } List_Delete(l); fclose(fp); fclose(fpRe); fclose(fpIm); } /* ------------------------------------------------------------------------ */ /* D o f _ R e a d F i l e R E S */ /* ------------------------------------------------------------------------ */ void Dof_ReadFileRES(List_T * DofData_L, struct DofData * Read_DofData_P, int Read_DofData, double *Time, double *TimeImag, double *TimeStep) { Message::Barrier(); int Num_DofData, Val_TimeStep, Format = 0, Read ; double Val_Time, Val_TimeImag = 0., Version = 0.; struct DofData * DofData_P = NULL ; struct Solution Solution_S ; char String[256] ; while (1) { do { fgets(String, sizeof(String), File_RES) ; if (feof(File_RES)) break ; } while (String[0] != '$') ; if (feof(File_RES)) break ; /* F o r m a t */ if (!strncmp(&String[1], "ResFormat", 9)) { fscanf(File_RES, "%lf %d\n", &Version, &Format) ; } /* S o l u t i o n */ if (!strncmp(&String[1], "Solution", 8)) { /* don't use fscanf directly on the stream here: the data that follows can be binary, and the first character could be e.g. 0x0d, which would cause fscanf to eat-up one character too much, leading to an offset in fread */ fgets(String, sizeof(String), File_RES) ; if(Version <= 1.0) sscanf(String, "%d %lf %d", &Num_DofData, &Val_Time, &Val_TimeStep) ; else sscanf(String, "%d %lf %lf %d", &Num_DofData, &Val_Time, &Val_TimeImag, &Val_TimeStep) ; if (Read_DofData < 0){ Read = 1 ; DofData_P = (struct DofData*)List_Pointer(DofData_L, Num_DofData) ; } else if (Num_DofData == Read_DofData) { Read = 1 ; DofData_P = Read_DofData_P ; } else { Read = 0 ; } if(Read){ Solution_S.Time = Val_Time ; Solution_S.TimeImag = Val_TimeImag ; Solution_S.TimeStep = Val_TimeStep ; Solution_S.SolutionExist = 1 ; Solution_S.TimeFunctionValues = NULL ; LinAlg_CreateVector(&Solution_S.x, &DofData_P->Solver, DofData_P->NbrDof) ; Format ? LinAlg_ReadVector(File_RES, &Solution_S.x) : LinAlg_ScanVector(File_RES, &Solution_S.x) ; if (DofData_P->Solutions == NULL) DofData_P->Solutions = List_Create( 20, 20, sizeof(struct Solution)) ; List_Add(DofData_P->Solutions, &Solution_S) ; } } do { fgets(String, sizeof(String), File_RES) ; if (feof(File_RES)) Message::Warning("Prematured end of file (Time Step %d)", Val_TimeStep); } while (String[0] != '$') ; } /* while 1 ... */ *Time = Val_Time ; *TimeImag = Val_TimeImag ; *TimeStep = (double)Val_TimeStep ; } /* ------------------------------------------------------------------------ */ /* D o f _ T r a n s f e r D o f T r e e T o L i s t */ /* ------------------------------------------------------------------------ */ void Dof_TransferDofTreeToList(struct DofData * DofData_P) { if (DofData_P->DofTree) { DofData_P->DofList = Tree2List(DofData_P->DofTree) ; Tree_Delete(DofData_P->DofTree) ; DofData_P->DofTree = NULL ; DofData_P->NbrAnyDof = List_Nbr(DofData_P->DofList) ; } Dof_InitDofType(DofData_P) ; } /* ------------------------------------------------------------------------ */ /* D o f _ I n i t D o f T y p e */ /* ------------------------------------------------------------------------ */ void Dof_InitDofType(struct DofData * DofData_P) { struct Dof * Dof_P, * Dof_P0 ; int i ; if (!DofData_P->NbrAnyDof){ return; } Dof_P0 = (struct Dof *)List_Pointer(DofData_P->DofList, 0) ; for (i = 0 ; i < DofData_P->NbrAnyDof ; i++) { Dof_P = Dof_P0 + i ; switch (Dof_P->Type) { case DOF_LINK : case DOF_LINKCPLX : Dof_P->Case.Link.Dof = Dof_GetDofStruct(DofData_P, Dof_P->NumType, Dof_P->Case.Link.EntityRef, Dof_P->Harmonic) ; if (Dof_P->Case.Link.Dof == NULL || Dof_P->Case.Link.Dof == Dof_GetDofStruct(DofData_P, Dof_P->NumType, Dof_P->Entity, Dof_P->Harmonic) ) { Dof_P->Case.Link.Dof = /* Attention: bricolage ... */ Dof_GetDofStruct(DofData_P, Dof_P->NumType-1, Dof_P->Case.Link.EntityRef, Dof_P->Harmonic) ; if (Dof_P->Case.Link.Dof == NULL) Message::Error("Wrong Link Constraint: reference Dof (%d %d %d) does not exist", Dof_P->NumType, Dof_P->Case.Link.EntityRef, Dof_P->Harmonic); } /* if (Dof_P->Case.Link.Dof == NULL) Message::Error("Wrong Link Constraint: reference Dof (%d %d %d) does not exist", Dof_P->NumType, Dof_P->Case.Link.EntityRef, Dof_P->Harmonic); */ break ; default : break ; } } } /* ------------------------------------------------------------------------ */ /* P R E P R O C E S S I N G ( C o d e s i n T r e e ) */ /* ------------------------------------------------------------------------ */ /* ------------------------------------------------------------------------ */ /* D o f _ A d d F u n c t i o n S p a c e I n d e x */ /* ------------------------------------------------------------------------ */ void Dof_AddFunctionSpaceIndex(int Index_FunctionSpace) { if (CurrentDofData->FunctionSpaceIndex == NULL) CurrentDofData->FunctionSpaceIndex = List_Create(10, 5, sizeof(int)) ; if (List_PQuery (CurrentDofData->FunctionSpaceIndex, &Index_FunctionSpace, fcmp_int) == NULL) { List_Add(CurrentDofData->FunctionSpaceIndex, &Index_FunctionSpace) ; List_Sort(CurrentDofData->FunctionSpaceIndex, fcmp_int) ; } } /* ------------------------------------------------------------------------ */ /* D o f _ A d d T i m e F u n c t i o n I n d e x */ /* ------------------------------------------------------------------------ */ void Dof_AddTimeFunctionIndex(int Index_TimeFunction) { if (List_PQuery (CurrentDofData->TimeFunctionIndex, &Index_TimeFunction, fcmp_int) == NULL) { List_Add(CurrentDofData->TimeFunctionIndex, &Index_TimeFunction) ; List_Sort(CurrentDofData->TimeFunctionIndex, fcmp_int) ; } } /* ------------------------------------------------------------------------ */ /* D o f _ A d d P u l s a t i o n */ /* ------------------------------------------------------------------------ */ void Dof_AddPulsation(struct DofData * DofData_P, double Val_Pulsation) { if (DofData_P->Pulsation == NULL) DofData_P->Pulsation = List_Create(1, 2, sizeof(double)) ; if (List_PQuery (DofData_P->Pulsation, &Val_Pulsation, fcmp_double) == NULL) { List_Add(DofData_P->Pulsation, &Val_Pulsation) ; List_Sort(DofData_P->Pulsation, fcmp_double) ; } } /* ------------------------------------------------------------------------ */ /* D o f _ D e f i n e A s s i g n F i x e d D o f */ /* ------------------------------------------------------------------------ */ void Dof_DefineAssignFixedDof(int D1, int D2, int NbrHar, double *Val, int Index_TimeFunction) { struct Dof Dof, * Dof_P ; int k ; Dof.NumType = D1 ; Dof.Entity = D2 ; for(k=0 ; kDofTree, &Dof))) { Dof.Type = DOF_FIXED ; LinAlg_SetScalar(&Dof.Val, &Val[k]) ; Dof.Case.FixedAssociate.TimeFunctionIndex = Index_TimeFunction + 1 ; Dof_AddTimeFunctionIndex(Index_TimeFunction + 1) ; Tree_Add(CurrentDofData->DofTree, &Dof) ; } else if(Dof_P->Type == DOF_UNKNOWN) { if(Message::GetVerbosity() == 10) Message::Info("Overriding unknown Dof with fixed Dof"); Dof_P->Type = DOF_FIXED ; LinAlg_SetScalar(&Dof_P->Val, &Val[k]) ; Dof_P->Case.FixedAssociate.TimeFunctionIndex = Index_TimeFunction + 1 ; Dof_AddTimeFunctionIndex(Index_TimeFunction + 1) ; } } } /* ------------------------------------------------------------------------ */ /* D o f _ D e f i n e A s s i g n S o l v e D o f */ /* ------------------------------------------------------------------------ */ void Dof_DefineAssignSolveDof(int D1, int D2, int NbrHar, int Index_TimeFunction) { struct Dof Dof ; int k ; Dof.NumType = D1 ; Dof.Entity = D2 ; for(k=0 ; kDofTree, &Dof)) { Dof.Type = DOF_FIXED_SOLVE ; Dof.Case.FixedAssociate.TimeFunctionIndex = Index_TimeFunction + 1 ; Dof_AddTimeFunctionIndex(Index_TimeFunction + 1) ; Tree_Add(CurrentDofData->DofTree, &Dof) ; } } } /* ------------------------------------------------------------------------ */ /* D o f _ D e f i n e I n i t F i x e d D o f */ /* ------------------------------------------------------------------------ */ void Dof_DefineInitFixedDof(int D1, int D2, int NbrHar, double *Val, double *Val2, bool NonLocal) { struct Dof Dof ; int k ; Dof.NumType = D1 ; Dof.Entity = D2 ; for(k=0 ; kDofTree, &Dof)) { Dof.Type = DOF_UNKNOWN_INIT ; LinAlg_SetScalar(&Dof.Val, &Val[k]) ; LinAlg_SetScalar(&Dof.Val2, &Val2[k]) ; Dof.Case.Unknown.NumDof = ++(CurrentDofData->NbrDof) ; Dof.Case.Unknown.NonLocal = NonLocal; Tree_Add(CurrentDofData->DofTree, &Dof) ; } } } /* ------------------------------------------------------------------------ */ /* D o f _ D e f i n e I n i t S o l v e D o f */ /* ------------------------------------------------------------------------ */ void Dof_DefineInitSolveDof(int D1, int D2, int NbrHar) { struct Dof Dof ; int k ; Dof.NumType = D1 ; Dof.Entity = D2 ; for(k=0 ; kDofTree, &Dof)) { Dof.Type = DOF_UNKNOWN_INIT ; Dof.Case.Unknown.NumDof = ++(CurrentDofData->NbrDof) ; Dof.Case.Unknown.NonLocal = false ; Tree_Add(CurrentDofData->DofTree, &Dof) ; } } } /* ------------------------------------------------------------------------ */ /* D o f _ D e f i n e L i n k D o f */ /* ------------------------------------------------------------------------ */ void Dof_DefineLinkDof(int D1, int D2, int NbrHar, double Value[], int D2_Link) { struct Dof Dof ; int k ; Dof.NumType = D1 ; Dof.Entity = D2 ; for(k=0 ; kDofTree, &Dof)) { Dof.Type = DOF_LINK ; Dof.Case.Link.Coef = Value[0] ; Dof.Case.Link.EntityRef = D2_Link ; Dof.Case.Link.Dof = NULL ; Tree_Add(CurrentDofData->DofTree, &Dof) ; } } } void Dof_DefineLinkCplxDof(int D1, int D2, int NbrHar, double Value[], int D2_Link) { struct Dof Dof ; int k ; Dof.NumType = D1 ; Dof.Entity = D2 ; for(k=0 ; kDofTree, &Dof)) { Dof.Type = DOF_LINKCPLX ; Dof.Case.Link.Coef = Value[0] ; Dof.Case.Link.Coef2 = Value[1] ; Dof.Case.Link.EntityRef = D2_Link ; Dof.Case.Link.Dof = NULL ; Tree_Add(CurrentDofData->DofTree, &Dof) ; } } } /* ------------------------------------------------------------------------ */ /* D o f _ D e f i n e U n k n o w n D o f */ /* ------------------------------------------------------------------------ */ void Dof_DefineUnknownDof(int D1, int D2, int NbrHar, bool NonLocal) { struct Dof Dof ; int k ; Dof.NumType = D1 ; Dof.Entity = D2 ; for(k=0 ; kDofTree, &Dof)) { Dof.Type = DOF_UNKNOWN ; /* Dof.Case.Unknown.NumDof = ++(CurrentDofData->NbrDof) ; */ Dof.Case.Unknown.NumDof = -1 ; Dof.Case.Unknown.NonLocal = NonLocal ; Tree_Add(CurrentDofData->DofTree, &Dof) ; } } } void NumberUnknownDof (void *a, void *b) { struct Dof * Dof_P ; Dof_P = (struct Dof *)a ; if(Dof_P->Type == DOF_UNKNOWN){ if(Dof_P->Case.Unknown.NumDof == -1) Dof_P->Case.Unknown.NumDof = ++(CurrentDofData->NbrDof) ; if(Dof_P->Case.Unknown.NonLocal) CurrentDofData->NonLocalEquations.push_back(Dof_P->Case.Unknown.NumDof); } } void Dof_NumberUnknownDof(void) { if(CurrentDofData->DofTree) Tree_Action(CurrentDofData->DofTree, NumberUnknownDof) ; else List_Action(CurrentDofData->DofList, NumberUnknownDof) ; } /* ------------------------------------------------------------------------ */ /* D o f _ D e f i n e A s s o c i a t e D o f */ /* ------------------------------------------------------------------------ */ void Dof_DefineAssociateDof(int E1, int E2, int D1, int D2, int NbrHar, int init, double *Val) { struct Dof Dof, Equ, * Equ_P ; int k ; Equ.NumType = E1 ; Equ.Entity = E2 ; for(k=0 ; kDofTree, &Equ))) { switch (Equ_P->Type) { case DOF_FIXED : Equ_P->Type = DOF_FIXEDWITHASSOCIATE ; Equ_P->Case.FixedAssociate.NumDof = ++(CurrentDofData->NbrDof) ; /* To be modified (Patrick): strange to define a new NumDof for Equ if associate-Dof already exists */ Dof.NumType = D1 ; Dof.Entity = D2 ; Dof.Harmonic = k ; if (!Tree_PQuery(CurrentDofData->DofTree, &Dof)) { if (!init) { Dof.Type = DOF_UNKNOWN ; } else { Dof.Type = DOF_UNKNOWN_INIT ; LinAlg_SetScalar(&Dof.Val, &Val[k]) ; LinAlg_ZeroScalar(&Dof.Val2) ; } Dof.Case.Unknown.NumDof = CurrentDofData->NbrDof ; Dof.Case.Unknown.NonLocal = true ; Tree_Add(CurrentDofData->DofTree, &Dof) ; } break ; case DOF_FIXED_SOLVE : Equ_P->Type = DOF_FIXEDWITHASSOCIATE_SOLVE ; Equ_P->Case.FixedAssociate.NumDof = ++(CurrentDofData->NbrDof) ; Dof.NumType = D1 ; Dof.Entity = D2 ; Dof.Harmonic = k ; if (!Tree_PQuery(CurrentDofData->DofTree, &Dof)) { if (!init) { Dof.Type = DOF_UNKNOWN ; } else { Dof.Type = DOF_UNKNOWN_INIT ; LinAlg_SetScalar(&Dof.Val, &Val[k]) ; LinAlg_ZeroScalar(&Dof.Val2) ; } Dof.Case.Unknown.NumDof = CurrentDofData->NbrDof ; Dof.Case.Unknown.NonLocal = true ; Tree_Add(CurrentDofData->DofTree, &Dof) ; } break ; case DOF_UNKNOWN : case DOF_UNKNOWN_INIT : Dof_DefineUnknownDof(D1, D2, NbrHar) ; break ; } } } } void Dof_GetDof_Four(struct DofData * DofData_P, struct DofData * DofData2_P) { int NbrHar2, NbrDof2, i ; struct Dof * Dof_P ; NbrHar2 = DofData2_P->NbrHar ; NbrDof2 = List_Nbr(DofData2_P->DofList) ; for (i=0 ; iDofList, i) ; printf("i %d, dof %d \n", i/NbrHar2, List_ISearch(DofData_P->DofList, Dof_P, fcmp_Dof)) ; } } /* ------------------------------------------------------------------------ */ /* P R O C E S S I N G ( C o d e s i n L i s t ) */ /* ------------------------------------------------------------------------ */ /* ------------------------------------------------------------------------ */ /* D o f _ G e t D o f S t r u c t */ /* ------------------------------------------------------------------------ */ struct Dof *Dof_GetDofStruct(struct DofData * DofData_P, int D1, int D2, int D3) { struct Dof Dof ; Dof.NumType = D1 ; Dof.Entity = D2 ; Dof.Harmonic = D3 ; return (struct Dof *)List_PQuery(DofData_P->DofList, &Dof, fcmp_Dof); } /* ------------------------------------------------------------------------ */ /* D o f _ U p d a t e A s s i g n F i x e d D o f */ /* ------------------------------------------------------------------------ */ void Dof_UpdateAssignFixedDof(struct Dof *Dof_P, int NbrHar, double *Val) { int k ; for(k=0 ; kVal, &Val[k]) ; } } /* ------------------------------------------------------------------------ */ /* D o f _ U p d a t e L i n k D o f */ /* ------------------------------------------------------------------------ */ void Dof_UpdateLinkDof(struct Dof *Dof_P, int NbrHar, double Value[], int D2_Link) { int k ; if (Dof_P->Type == DOF_LINK || Dof_P->Type == DOF_LINKCPLX) { /* fprintf(stderr,"===> %d %d %.16g\n", Dof_P->NumType, Dof_P->Entity, Value[0]) ; */ for(k=0 ; kCase.Link.Coef = Value[0] ; if (Dof_P->Type == DOF_LINKCPLX) Dof_P->Case.Link.Coef2 = Value[1] ; Dof_P->Case.Link.EntityRef = D2_Link ; Dof_P->Case.Link.Dof = NULL ; } } } /* ------------------------------------------------------------------------ */ /* D o f _ A s s e m b l e I n M a t */ /* ------------------------------------------------------------------------ */ void Dof_AssembleInMat(struct Dof * Equ_P, struct Dof * Dof_P, int NbrHar, double * Val, gMatrix * Mat, gVector * Vec, List_T * Vecs) { gScalar tmp, tmp2 ; double valtmp[2], d1, d2 ; switch (Equ_P->Type) { case DOF_UNKNOWN : case DOF_FIXEDWITHASSOCIATE : switch (Dof_P->Type) { case DOF_UNKNOWN : if(Current.DofData->Flag_RHS) break; if(NbrHar==1){ LinAlg_AddDoubleInMatrix (Val[0], Mat, Equ_P->Case.Unknown.NumDof-1, Dof_P->Case.Unknown.NumDof-1) ; } else LinAlg_AddComplexInMatrix (Val[0], Val[1], Mat, Equ_P->Case.Unknown.NumDof-1, Dof_P->Case.Unknown.NumDof-1, (gSCALAR_SIZE==1)?((Equ_P+1)->Case.Unknown.NumDof-1):-1, (gSCALAR_SIZE==1)?((Dof_P+1)->Case.Unknown.NumDof-1):-1) ; break ; case DOF_FIXED : case DOF_FIXEDWITHASSOCIATE : if(Vec){ if(NbrHar==1){ if(Val[0]){ LinAlg_ProdScalarDouble (&Dof_P->Val, CurrentDofData->CurrentSolution-> TimeFunctionValues[Dof_P->Case.FixedAssociate.TimeFunctionIndex], &tmp); LinAlg_ProdScalarDouble(&tmp, -Val[0], &tmp) ; LinAlg_AddScalarInVector(&tmp, Vec, Equ_P->Case.Unknown.NumDof-1) ; if(Vecs){ // experimental int index = List_ISearchSeq(Current.DofData->TimeFunctionIndex, &Dof_P->Case.FixedAssociate.TimeFunctionIndex, fcmp_int); if(index >= 0 && index < List_Nbr(Vecs)){ gVector *v = (gVector*)List_Pointer(Vecs, index); LinAlg_AddScalarInVector(&tmp, v, Equ_P->Case.Unknown.NumDof-1) ; } else{ Message::Error("Something wrong in multi-vec assembly"); } } } } else{ LinAlg_ProdScalarDouble (&Dof_P->Val, CurrentDofData->CurrentSolution-> TimeFunctionValues[Dof_P->Case.FixedAssociate.TimeFunctionIndex], &tmp); if(gSCALAR_SIZE == 2){ LinAlg_ProdScalarComplex(&tmp, -Val[0], -Val[1], &valtmp[0], &valtmp[1]) ; } else{ LinAlg_GetDoubleInScalar(&d1, &tmp); LinAlg_ProdScalarDouble (&(Dof_P+1)->Val, CurrentDofData->CurrentSolution-> TimeFunctionValues[Dof_P->Case.FixedAssociate.TimeFunctionIndex], &tmp2); LinAlg_GetDoubleInScalar(&d2, &tmp2); valtmp[0] = -d1*Val[0] + d2*Val[1] ; valtmp[1] = -d1*Val[1] - d2*Val[0] ; } LinAlg_AddComplexInVector (valtmp[0], valtmp[1], Vec, Equ_P->Case.Unknown.NumDof-1, (gSCALAR_SIZE==1)?((Equ_P+1)->Case.Unknown.NumDof-1):-1) ; } } break ; case DOF_LINK : if(NbrHar==1) valtmp[0] = Val[0] * Dof_P->Case.Link.Coef ; else{ valtmp[0] = Val[0] * Dof_P->Case.Link.Coef ; valtmp[1] = Val[1] * Dof_P->Case.Link.Coef ; } Dof_AssembleInMat(Equ_P, Dof_P->Case.Link.Dof, NbrHar, valtmp, Mat, Vec, Vecs) ; break ; case DOF_LINKCPLX : if(NbrHar==1) Message::Error("LinkCplx only valid for Complex systems") ; else{ valtmp[0] = Val[0] * Dof_P->Case.Link.Coef - Val[1] * Dof_P->Case.Link.Coef2 ; valtmp[1] = Val[1] * Dof_P->Case.Link.Coef + Val[0] * Dof_P->Case.Link.Coef2 ; } Dof_AssembleInMat(Equ_P, Dof_P->Case.Link.Dof, NbrHar, valtmp, Mat, Vec, Vecs) ; break ; case DOF_FIXED_SOLVE : case DOF_FIXEDWITHASSOCIATE_SOLVE : Message::Error("Wrong Constraints: " "remaining Dof(s) waiting to be fixed by a Resolution"); break; case DOF_UNKNOWN_INIT : Message::Error("Wrong Initial Constraints: " "remaining Dof(s) with non-fixed initial conditions"); break; } break ; case DOF_LINK : if(NbrHar==1) valtmp[0] = Val[0] * Equ_P->Case.Link.Coef ; else{ valtmp[0] = Val[0] * Equ_P->Case.Link.Coef ; valtmp[1] = Val[1] * Equ_P->Case.Link.Coef ; } Dof_AssembleInMat(Equ_P->Case.Link.Dof, Dof_P, NbrHar, valtmp, Mat, Vec, Vecs) ; break ; case DOF_LINKCPLX : if(NbrHar==1) Message::Error("LinkCplx only valid for Complex systems") ; else{ /* Warning: conjugate! */ valtmp[0] = Val[0] * Equ_P->Case.Link.Coef + Val[1] * Equ_P->Case.Link.Coef2 ; valtmp[1] = Val[1] * Equ_P->Case.Link.Coef - Val[0] * Equ_P->Case.Link.Coef2 ; } Dof_AssembleInMat(Equ_P->Case.Link.Dof, Dof_P, NbrHar, valtmp, Mat, Vec, Vecs) ; break ; } } /* ------------------------------------------------------------------------ */ /* D o f _ A s s e m b l e I n V e c */ /* ------------------------------------------------------------------------ */ void Dof_AssembleInVec(struct Dof * Equ_P, struct Dof * Dof_P, int NbrHar, double * Val, struct Solution * OtherSolution, gVector * Vec0, gVector * Vec) { gScalar tmp ; double valtmp[2] ; double a, b, c, d ; switch (Equ_P->Type) { case DOF_UNKNOWN : case DOF_FIXEDWITHASSOCIATE : switch (Dof_P->Type) { case DOF_UNKNOWN : if(NbrHar==1){ if(Val[0]){ LinAlg_GetDoubleInVector(&a, Vec0, Dof_P->Case.Unknown.NumDof-1) ; a *= Val[0] ; LinAlg_AddDoubleInVector(a, Vec, Equ_P->Case.Unknown.NumDof-1) ; } } else{ LinAlg_GetComplexInVector(&a, &b, Vec0, Dof_P->Case.Unknown.NumDof-1, (gSCALAR_SIZE==1)?((Dof_P+1)->Case.Unknown.NumDof-1):-1) ; c = a * Val[0] - b * Val[1] ; d = a * Val[1] + b * Val[0] ; LinAlg_AddComplexInVector(c, d, Vec, Equ_P->Case.Unknown.NumDof-1, (gSCALAR_SIZE==1)?((Equ_P+1)->Case.Unknown.NumDof-1):-1) ; } break ; case DOF_FIXED : case DOF_FIXEDWITHASSOCIATE : if(NbrHar==1){ if(Val[0]){ LinAlg_ProdScalarDouble (&Dof_P->Val, Val[0] * OtherSolution-> TimeFunctionValues[Dof_P->Case.FixedAssociate.TimeFunctionIndex], &tmp) ; LinAlg_AddScalarInVector(&tmp, Vec, Equ_P->Case.Unknown.NumDof-1) ; } } else{ if(gSCALAR_SIZE == 2){ LinAlg_ProdScalarComplex (&Dof_P->Val, Val[0] * OtherSolution-> TimeFunctionValues[Dof_P->Case.FixedAssociate.TimeFunctionIndex], Val[1] * OtherSolution-> TimeFunctionValues[Dof_P->Case.FixedAssociate.TimeFunctionIndex], &a, &b) ; LinAlg_AddComplexInVector(a, b, Vec, Equ_P->Case.Unknown.NumDof-1, (gSCALAR_SIZE==1)?((Equ_P+1)->Case.Unknown.NumDof-1):-1) ; } else{ Message::Error("Assemby in vectors with more than one harmonic not yet implemented") ; } } break ; case DOF_LINK : if(NbrHar==1) valtmp[0] = Val[0] * Dof_P->Case.Link.Coef ; else{ valtmp[0] = Val[0] * Dof_P->Case.Link.Coef ; valtmp[1] = Val[1] * Dof_P->Case.Link.Coef ; } Dof_AssembleInVec(Equ_P, Dof_P->Case.Link.Dof, NbrHar, valtmp, OtherSolution, Vec0, Vec) ; break ; case DOF_LINKCPLX : if(NbrHar==1) Message::Error("LinkCplx only valid for Complex systems") ; else{ valtmp[0] = Val[0] * Dof_P->Case.Link.Coef - Val[1] * Dof_P->Case.Link.Coef2 ; valtmp[1] = Val[1] * Dof_P->Case.Link.Coef + Val[0] * Dof_P->Case.Link.Coef2 ; } Dof_AssembleInVec(Equ_P, Dof_P->Case.Link.Dof, NbrHar, valtmp, OtherSolution, Vec0, Vec) ; break ; case DOF_FIXED_SOLVE : case DOF_FIXEDWITHASSOCIATE_SOLVE : Message::Error("Wrong Constraints: " "remaining Dof(s) waiting to be fixed by a Resolution"); break; case DOF_UNKNOWN_INIT : Message::Error("Wrong Initial Constraints: " "remaining Dof(s) with non-fixed initial conditions"); break; } break ; case DOF_LINK : if(NbrHar==1) valtmp[0] = Val[0] * Equ_P->Case.Link.Coef ; else{ valtmp[0] = Val[0] * Equ_P->Case.Link.Coef ; valtmp[1] = Val[1] * Equ_P->Case.Link.Coef ; } Dof_AssembleInVec(Equ_P->Case.Link.Dof, Dof_P, NbrHar, valtmp, OtherSolution, Vec0, Vec) ; break ; case DOF_LINKCPLX : if(NbrHar==1) Message::Error("LinkCplx only valid for Complex systems") ; else{ /* Warning: conjugate! */ valtmp[0] = Val[0] * Equ_P->Case.Link.Coef + Val[1] * Equ_P->Case.Link.Coef2 ; valtmp[1] = Val[1] * Equ_P->Case.Link.Coef - Val[0] * Equ_P->Case.Link.Coef2 ; } Dof_AssembleInVec(Equ_P->Case.Link.Dof, Dof_P, NbrHar, valtmp, OtherSolution, Vec0, Vec) ; break ; } } /* ------------------------------------------------------------------------ */ /* D o f _ T r a n s f e r S o l u t i o n T o C o n s t r a i n t */ /* ------------------------------------------------------------------------ */ void Dof_TransferSolutionToConstraint(struct DofData * DofData_P) { struct Dof * Dof_P, * Dof_P0 ; int i ; if (!DofData_P->NbrAnyDof){ return; } Dof_P0 = (struct Dof *)List_Pointer(DofData_P->DofList, 0) ; for (i = 0 ; i < DofData_P->NbrAnyDof ; i++) { Dof_P = Dof_P0 + i ; switch (Dof_P->Type) { case DOF_UNKNOWN : Dof_P->Type = DOF_FIXED ; LinAlg_GetScalarInVector(&Dof_P->Val, &DofData_P->CurrentSolution->x, Dof_P->Case.Unknown.NumDof-1) ; Dof_P->Case.FixedAssociate.TimeFunctionIndex = 0 ; break ; case DOF_FIXED : case DOF_FIXEDWITHASSOCIATE : case DOF_LINK : case DOF_LINKCPLX : break ; default : break ; } } DofData_P->NbrDof = 0 ; } /* ------------------------------------------------------------------------ */ /* D o f _ G e t D o f V a l u e */ /* ------------------------------------------------------------------------ */ gScalar Dof_GetDofValue(struct DofData * DofData_P, struct Dof * Dof_P) { gScalar tmp ; switch (Dof_P->Type) { case DOF_UNKNOWN : if(!DofData_P->CurrentSolution->SolutionExist) Message::Error("Empty solution in DofData %d", DofData_P->Num); else LinAlg_GetScalarInVector(&tmp, &DofData_P->CurrentSolution->x, Dof_P->Case.Unknown.NumDof-1) ; break ; case DOF_FIXED : case DOF_FIXEDWITHASSOCIATE : LinAlg_ProdScalarDouble(&Dof_P->Val, ((Dof_P->Case.FixedAssociate.TimeFunctionIndex)? DofData_P->CurrentSolution->TimeFunctionValues [Dof_P->Case.FixedAssociate.TimeFunctionIndex] : 1.), &tmp); break ; case DOF_LINK : tmp = Dof_GetDofValue(DofData_P, Dof_P->Case.Link.Dof) ; LinAlg_ProdScalarDouble(&tmp, Dof_P->Case.Link.Coef, &tmp) ; break ; case DOF_LINKCPLX : /* Too soon to treat LinkCplx: we need the real and imaginary parts */ Message::Error("Cannot call Dof_GetDofValue for LinkCplx"); break ; default : LinAlg_ZeroScalar(&tmp) ; break ; } return tmp ; } void Dof_GetRealDofValue(struct DofData * DofData_P, struct Dof * Dof_P, double *d) { gScalar tmp ; if (Dof_P->Type == DOF_LINKCPLX) { Message::Error("Cannot call Dof_GetRealDofValue for LinkCplx"); return; } tmp = Dof_GetDofValue(DofData_P, Dof_P) ; LinAlg_GetDoubleInScalar(d, &tmp) ; } void Dof_GetComplexDofValue(struct DofData * DofData_P, struct Dof * Dof_P, double *d1, double *d2) { gScalar tmp1, tmp2 ; double valtmp[2] ; if(gSCALAR_SIZE == 1){ if(Dof_P->Type == DOF_LINKCPLX) { /* Can only be done here */ if (Dof_P->Case.Link.Dof->Type == DOF_LINKCPLX) { /* recurse */ Dof_GetComplexDofValue(DofData_P, Dof_P->Case.Link.Dof, d1, d2); } else{ tmp1 = Dof_GetDofValue(DofData_P, Dof_P->Case.Link.Dof) ; tmp2 = Dof_GetDofValue(DofData_P, (Dof_P+1)->Case.Link.Dof) ; LinAlg_GetDoubleInScalar(d1, &tmp1) ; LinAlg_GetDoubleInScalar(d2, &tmp2) ; } } else{ tmp1 = Dof_GetDofValue(DofData_P, Dof_P) ; tmp2 = Dof_GetDofValue(DofData_P, Dof_P+1) ; LinAlg_GetDoubleInScalar(d1, &tmp1) ; LinAlg_GetDoubleInScalar(d2, &tmp2) ; } } else{ if (Dof_P->Type == DOF_LINKCPLX) { /* Can only be done here */ if (Dof_P->Case.Link.Dof->Type == DOF_LINKCPLX) { /* recurse */ Dof_GetComplexDofValue(DofData_P, Dof_P->Case.Link.Dof, d1, d2); } else{ tmp1 = Dof_GetDofValue(DofData_P, Dof_P->Case.Link.Dof) ; LinAlg_GetComplexInScalar(d1, d2, &tmp1) ; } } else{ tmp1 = Dof_GetDofValue(DofData_P, Dof_P) ; LinAlg_GetComplexInScalar(d1, d2, &tmp1) ; } } if(Dof_P->Type == DOF_LINKCPLX){ valtmp[0] = Dof_P->Case.Link.Coef*(*d1) - Dof_P->Case.Link.Coef2*(*d2) ; valtmp[1] = Dof_P->Case.Link.Coef*(*d2) + Dof_P->Case.Link.Coef2*(*d1) ; *d1 = valtmp[0] ; *d2 = valtmp[1] ; } } /* ------------------------------------------------------------------------- */ /* D o f _ D e f i n e Unknown D o f F r o m Solve o r Init D o f */ /* ------------------------------------------------------------------------- */ void Dof_DefineUnknownDofFromSolveOrInitDof(struct DofData ** DofData_P) { int i, Nbr_AnyDof ; struct Dof * Dof_P ; Nbr_AnyDof = List_Nbr((*DofData_P)->DofList) ; for(i = 0 ; i < Nbr_AnyDof ; i++) { Dof_P = (struct Dof*)List_Pointer((*DofData_P)->DofList, i) ; switch (Dof_P->Type) { case DOF_FIXED_SOLVE : case DOF_FIXEDWITHASSOCIATE_SOLVE : Dof_P->Type = DOF_UNKNOWN ; Dof_P->Case.Unknown.NumDof = ++((*DofData_P)->NbrDof) ; break ; case DOF_UNKNOWN_INIT : Dof_P->Type = DOF_UNKNOWN ; break ; } } } /* ------------------------------------------------------------------------ */ /* D o f _ T r a n s f e r D o f */ /* ------------------------------------------------------------------------ */ void Dof_TransferDof(struct DofData * DofData_P1, struct DofData ** DofData_P2) { int i, Nbr_AnyDof ; struct Dof Dof, * Dof_P ; struct Solution * Solutions_P0 ; Nbr_AnyDof = List_Nbr(DofData_P1->DofList) ; Solutions_P0 = (struct Solution*)List_Pointer(DofData_P1->Solutions, 0) ; DofData_P1->CurrentSolution = Solutions_P0 ; for(i = 0; i < Nbr_AnyDof; i++) { Dof = *(struct Dof *)List_Pointer(DofData_P1->DofList, i) ; if((Dof_P = (struct Dof*)Tree_PQuery((*DofData_P2)->DofTree, &Dof))){ switch (Dof_P->Type) { case DOF_FIXED_SOLVE : Dof_P->Type = DOF_FIXED ; Dof_P->Val = Dof_GetDofValue(DofData_P1, &Dof) ; break ; case DOF_FIXEDWITHASSOCIATE_SOLVE : Dof_P->Type = DOF_FIXEDWITHASSOCIATE ; Dof_P->Val = Dof_GetDofValue(DofData_P1, &Dof) ; break ; case DOF_UNKNOWN_INIT : /* A DOF_UNKNOWN_INIT will always use the value obtained by pre-resolution even if a simple Init contraint is given; we should introduce DOF_UNKNOWN_INIT_SOLVE */ Dof_P->Val = Dof_GetDofValue(DofData_P1, &Dof) ; if((DofData_P1->CurrentSolution - Solutions_P0) > 0){ DofData_P1->CurrentSolution -= 1 ; Dof_P->Val2 = Dof_GetDofValue(DofData_P1, &Dof) ; DofData_P1->CurrentSolution += 1 ; } else{ LinAlg_ZeroScalar(&Dof_P->Val2); } break ; } } } } /* ------------------------------------------------------------------------ */ /* D o f _ I n i t D o f F o r N o D o f */ /* ------------------------------------------------------------------------ */ void Dof_InitDofForNoDof(struct Dof * DofForNoDof, int NbrHar) { int k ; double Val[2] = {1.,0.} ; for (k=0 ; kType){ case DOF_UNKNOWN : printf("%d(%d) ", Dof_P->Case.Unknown.NumDof, Dof_P->Entity) ; break ; case DOF_FIXED : printf("Fixed(%d) ", Dof_P->Entity) ; break ; case DOF_FIXEDWITHASSOCIATE : printf("Assoc-%d ", Dof_P->Case.FixedAssociate.NumDof) ; break ; case DOF_LINK : printf("Link-"); Print_DofNumber(Dof_P->Case.Link.Dof); break ; case DOF_LINKCPLX : printf("LinkCplx-"); Print_DofNumber(Dof_P->Case.Link.Dof); break ; default : printf(" ? ") ; break ; } } /* ------------------------------------------------------- */ /* D u m m y D o f s */ /* ------------------------------------------------------- */ void Dof_GetDummies(struct DefineSystem * DefineSystem_P, struct DofData * DofData_P) { struct Formulation * Formulation_P ; struct DefineQuantity * DefineQuantity_P ; struct FunctionSpace * FunctionSpace_P ; struct BasisFunction * BasisFunction_P ; struct GlobalQuantity * GlobalQuantity_P ; struct Dof * Dof_P ; int i, j, k, l, iDof, ii,iit, iNum, iHar; int Nbr_Formulation, Index_Formulation ; int * DummyDof; double DummyFrequency, * Val_Pulsation; if (!(Val_Pulsation = Current.DofData->Val_Pulsation)){ Message::Error("Dof_GetDummies can only be used for harmonic problems"); return; } DummyDof = DofData_P->DummyDof = (int *)Malloc(DofData_P->NbrDof*sizeof(int)); for (iDof = 0 ; iDof < DofData_P->NbrDof ; iDof++) DummyDof[iDof]=0; Nbr_Formulation = List_Nbr(DefineSystem_P->FormulationIndex) ; for (i = 0 ; i < Nbr_Formulation ; i++) { List_Read(DefineSystem_P->FormulationIndex, i, &Index_Formulation) ; Formulation_P = (struct Formulation*) List_Pointer(Problem_S.Formulation, Index_Formulation) ; for (j = 0 ; j < List_Nbr(Formulation_P->DefineQuantity) ; j++) { DefineQuantity_P = (struct DefineQuantity*) List_Pointer(Formulation_P->DefineQuantity, j) ; for (l = 0 ; l < List_Nbr(DefineQuantity_P->DummyFrequency) ; l++) { DummyFrequency = *(double *)List_Pointer(DefineQuantity_P->DummyFrequency, l) ; iHar=-1; for (k = 0 ; k < Current.NbrHar/2 ; k++) if (fabs (Val_Pulsation[k]-TWO_PI*DummyFrequency) <= 1e-10 * Val_Pulsation[k]) { iHar = 2*k; break; } if(iHar>=0) { FunctionSpace_P = (struct FunctionSpace*) List_Pointer(Problem_S.FunctionSpace, DefineQuantity_P->FunctionSpaceIndex) ; for (k = 0 ; k < List_Nbr(FunctionSpace_P->BasisFunction) ; k++) { BasisFunction_P = (struct BasisFunction *) List_Pointer(FunctionSpace_P->BasisFunction, k) ; iNum = ((struct BasisFunction *)BasisFunction_P)->Num; ii=iit=0; for (iDof = 0 ; iDof < List_Nbr(DofData_P->DofList) ; iDof++) { Dof_P = (struct Dof *)List_Pointer(DofData_P->DofList, iDof) ; if (Dof_P->Type == DOF_UNKNOWN && Dof_P->NumType == iNum) { iit++; if (Dof_P->Harmonic == iHar || Dof_P->Harmonic == iHar+1) { DummyDof[Dof_P->Case.Unknown.NumDof-1]=1; ii++; } } } Message::Info("Freq %e (%d/%d) Form %d Quant %d Basis %d #dummies %d/%d", Val_Pulsation[iHar/2]/TWO_PI, iHar/2, Current.NbrHar/2, i, j, ((struct BasisFunction *)BasisFunction_P)->Num, ii, iit) ; } for (k = 0 ; k < List_Nbr(FunctionSpace_P->GlobalQuantity) ; k++) { GlobalQuantity_P = (struct GlobalQuantity *) List_Pointer(FunctionSpace_P->GlobalQuantity, k) ; iNum = ((struct GlobalQuantity *)GlobalQuantity_P)->Num; ii=iit=0; for (iDof = 0 ; iDof < List_Nbr(DofData_P->DofList) ; iDof++) { Dof_P = (struct Dof *)List_Pointer(DofData_P->DofList, iDof) ; if (Dof_P->Type == DOF_UNKNOWN && Dof_P->NumType == iNum) { iit++; if (Dof_P->Harmonic == iHar || Dof_P->Harmonic == iHar+1) { DummyDof[Dof_P->Case.Unknown.NumDof-1]=1; ii++; } } } Message::Info("Freq %e (%d/%d) Form %d Quant %d Global %d #dummies %d/%d", Val_Pulsation[iHar/2]/TWO_PI, iHar/2, Current.NbrHar/2, i, j, ((struct GlobalQuantity *)GlobalQuantity_P)->Num, ii, iit) ; } } /* end DummyFrequency in DofData */ } /* end DummyFrequency in Quantity */ } /* end Quantity */ } /* end Formulation */ i=0; for (iDof = 0 ; iDof < DofData_P->NbrDof ; iDof++) { if(DummyDof[iDof]) i++; /* Dof_P = (struct Dof *)List_Pointer(DofData_P->DofList, iDof) ; Message::Info("Dof Num iHar, Entity %d %d %d", iDof, Dof_P->NumType, Dof_P->Harmonic, Dof_P->Entity); */ } Message::Info("Total %d Dummies %d", DofData_P->NbrDof,i) ; } getdp-2.4.2-source/Legacy/F_Geometry.cpp000644 001750 001750 00000027433 12221300353 021550 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "ProData.h" #include "ProDefine.h" #include "GeoData.h" #include "Get_Geometry.h" #include "F.h" #include "NumericUtils.h" #include "MallocUtils.h" #include "Message.h" #define SQU(a) ((a)*(a)) extern struct CurrentData Current ; void F_Normal(F_ARG) { int k ; if(!Current.Element || Current.Element->Num == NO_ELEMENT) Message::Error("No element on which to compute 'F_Normal'"); Geo_CreateNormal(Current.Element->Type, Current.Element->x, Current.Element->y, Current.Element->z, V->Val); if (Current.NbrHar != 1) { V->Val[MAX_DIM] = 0. ; V->Val[MAX_DIM+1] = 0. ; V->Val[MAX_DIM+2] = 0. ; for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) { V->Val[MAX_DIM* k ] = V->Val[0] ; V->Val[MAX_DIM* k +1] = V->Val[1] ; V->Val[MAX_DIM* k +2] = V->Val[2] ; V->Val[MAX_DIM*(k+1) ] = 0. ; V->Val[MAX_DIM*(k+1)+1] = 0. ; V->Val[MAX_DIM*(k+1)+2] = 0. ; } } V->Type = VECTOR ; } void F_NormalSource(F_ARG) { int k ; if(!Current.ElementSource || Current.ElementSource->Num == NO_ELEMENT) Message::Error("No element on which to compute 'F_NormalSource'"); Geo_CreateNormal(Current.ElementSource->Type, Current.ElementSource->x, Current.ElementSource->y, Current.ElementSource->z, V->Val); if (Current.NbrHar != 1) { V->Val[MAX_DIM] = 0. ; V->Val[MAX_DIM+1] = 0. ; V->Val[MAX_DIM+2] = 0. ; for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) { V->Val[MAX_DIM* k ] = V->Val[0] ; V->Val[MAX_DIM* k +1] = V->Val[1] ; V->Val[MAX_DIM* k +2] = V->Val[2] ; V->Val[MAX_DIM*(k+1) ] = 0. ; V->Val[MAX_DIM*(k+1)+1] = 0. ; V->Val[MAX_DIM*(k+1)+2] = 0. ; } } V->Type = VECTOR ; } void F_Tangent(F_ARG) { int k ; double tx, ty, tz, norm ; if(!Current.Element || Current.Element->Num == NO_ELEMENT) Message::Error("No element on which to compute 'F_Tangent'"); switch (Current.Element->Type) { case LINE : tx = Current.Element->x[1] - Current.Element->x[0] ; ty = Current.Element->y[1] - Current.Element->y[0] ; tz = Current.Element->z[1] - Current.Element->z[0] ; norm = sqrt(SQU(tx)+SQU(ty)+SQU(tz)) ; V->Val[0] = tx/norm ; V->Val[1] = ty/norm ; V->Val[2] = tz/norm ; break ; default : Message::Error("Function 'Tangent' only valid for Line Elements"); } if (Current.NbrHar != 1) { V->Val[MAX_DIM] = 0. ; V->Val[MAX_DIM+1] = 0. ; V->Val[MAX_DIM+2] = 0. ; for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) { V->Val[MAX_DIM* k ] = V->Val[0] ; V->Val[MAX_DIM* k +1] = V->Val[1] ; V->Val[MAX_DIM* k +2] = V->Val[2] ; V->Val[MAX_DIM*(k+1) ] = 0. ; V->Val[MAX_DIM*(k+1)+1] = 0. ; V->Val[MAX_DIM*(k+1)+2] = 0. ; } } V->Type = VECTOR ; } void F_TangentSource(F_ARG) { int k ; double tx, ty, tz, norm ; if(!Current.ElementSource || Current.ElementSource->Num == NO_ELEMENT) Message::Error("No element on which to compute 'F_TangentSource'"); switch (Current.ElementSource->Type) { case LINE : tx = Current.ElementSource->x[1] - Current.ElementSource->x[0] ; ty = Current.ElementSource->y[1] - Current.ElementSource->y[0] ; tz = Current.ElementSource->z[1] - Current.ElementSource->z[0] ; norm = sqrt(SQU(tx)+SQU(ty)+SQU(tz)) ; V->Val[0] = tx/norm ; V->Val[1] = ty/norm ; V->Val[2] = tz/norm ; break ; default : Message::Error("Function 'TangentSource' only valid for Line Elements"); } if (Current.NbrHar != 1) { V->Val[MAX_DIM] = 0. ; V->Val[MAX_DIM+1] = 0. ; V->Val[MAX_DIM+2] = 0. ; for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) { V->Val[MAX_DIM* k ] = V->Val[0] ; V->Val[MAX_DIM* k +1] = V->Val[1] ; V->Val[MAX_DIM* k +2] = V->Val[2] ; V->Val[MAX_DIM*(k+1) ] = 0. ; V->Val[MAX_DIM*(k+1)+1] = 0. ; V->Val[MAX_DIM*(k+1)+2] = 0. ; } } V->Type = VECTOR ; } void F_ElementVol(F_ARG) { int k; double Vol = 0.; MATRIX3x3 Jac; if(!Current.Element || Current.Element->Num == NO_ELEMENT) Message::Error("No element on which to compute 'F_ElementVol'"); /* It would be more efficient to compute the volumes directly from the node coordinates, but I'm lazy... */ Get_NodesCoordinatesOfElement(Current.Element) ; Get_BFGeoElement(Current.Element, Current.u, Current.v, Current.w) ; /* we use the most general case (3D embedding) */ switch(Current.Element->Type){ case LINE: Vol = 2. * JacobianLin3D(Current.Element,&Jac); break; case TRIANGLE: Vol = 0.5 * JacobianSur3D(Current.Element,&Jac) ; break; case QUADRANGLE: Vol = 4. * JacobianSur3D(Current.Element,&Jac) ; break; case TETRAHEDRON: Vol = 1./6. * JacobianVol3D(Current.Element,&Jac) ; break; case HEXAHEDRON: Vol = 8. * JacobianVol3D(Current.Element,&Jac) ; break; case PRISM: Vol = JacobianVol3D(Current.Element,&Jac) ; break; case PYRAMID: Vol = 4./3. * JacobianVol3D(Current.Element,&Jac) ; break; default : Message::Error("F_ElementVol not implemented for %s", Get_StringForDefine(Element_Type, Current.Element->Type)); } V->Type = SCALAR ; V->Val[0] = fabs(Vol); for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) V->Val[MAX_DIM* k] = V->Val[0] ; } void F_SurfaceArea(F_ARG) { struct Element Element ; List_T * InitialList_L; int Index_Region, Nbr_Element, i_Element ; double Val_Surface ; double c11, c21, c12, c22, DetJac ; int i, k ; if (!Fct->Active) { Fct->Active = (struct FunctionActive *)Malloc(sizeof(struct FunctionActive)) ; if (Fct->NbrParameters == 1) { Index_Region = (int)(Fct->Para[0]) ; InitialList_L = List_Create(1,1,sizeof(int)); List_Reset(InitialList_L); List_Add(InitialList_L,&Index_Region); /* InitialList_L = ((struct Group *) List_Pointer(Problem_S.Group, Index_Region))->InitialList ; */ } else { Index_Region = -1 ; InitialList_L = NULL ; } Val_Surface = 0. ; Nbr_Element = Geo_GetNbrGeoElements() ; for (i_Element = 0 ; i_Element < Nbr_Element; i_Element++) { Element.GeoElement = Geo_GetGeoElement(i_Element) ; if ((InitialList_L && List_Search(InitialList_L, &(Element.GeoElement->Region), fcmp_int)) || (!InitialList_L && Element.GeoElement->Region == Current.Region)) { Element.Num = Element.GeoElement->Num ; Element.Type = Element.GeoElement->Type ; if (Element.Type == TRIANGLE || Element.Type == QUADRANGLE) { Get_NodesCoordinatesOfElement(&Element) ; Get_BFGeoElement(&Element, 0., 0., 0.) ; c11 = c21 = c12 = c22 = 0. ; for ( i = 0 ; i < Element.GeoElement->NbrNodes ; i++ ) { c11 += Element.x[i] * Element.dndu[i][0] ; c21 += Element.x[i] * Element.dndu[i][1] ; c12 += Element.y[i] * Element.dndu[i][0] ; c22 += Element.y[i] * Element.dndu[i][1] ; } DetJac = c11 * c22 - c12 * c21 ; if (Element.Type == TRIANGLE) Val_Surface += fabs(DetJac) * 0.5 ; else if (Element.Type == QUADRANGLE) Val_Surface += fabs(DetJac) * 4. ; } else { Message::Error("Function 'SurfaceArea' only valid for Triangle or " "Quandrangle Elements"); } } } Fct->Active->Case.SurfaceArea.Value = Val_Surface ; } V->Type = SCALAR ; V->Val[0] = Fct->Active->Case.SurfaceArea.Value ; V->Val[MAX_DIM] = 0; for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) { V->Val[MAX_DIM* k] = V->Val[0] ; V->Val[MAX_DIM* (k+1)] = 0 ; } } void F_GetVolume(F_ARG) { struct Element Element ; List_T * InitialList_L; int Index_Region, Nbr_Element, i_Element ; double Val_Volume ; double c11, c21, c31, c12, c22, c32, c13, c23, c33 ; double DetJac ; int i, k ; if (!Fct->Active) { Fct->Active = (struct FunctionActive *)Malloc(sizeof(struct FunctionActive)) ; if (Fct->NbrParameters == 1) { Index_Region = (int)(Fct->Para[0]) ; InitialList_L = List_Create(1,1,sizeof(int)); List_Reset(InitialList_L); List_Add(InitialList_L,&Index_Region); /* InitialList_L = ((struct Group *) List_Pointer(Problem_S.Group, Index_Region))->InitialList ; */ } else { Index_Region = -1 ; InitialList_L = NULL ; } Val_Volume = 0. ; Nbr_Element = Geo_GetNbrGeoElements() ; for (i_Element = 0 ; i_Element < Nbr_Element; i_Element++) { Element.GeoElement = Geo_GetGeoElement(i_Element) ; if ((InitialList_L && List_Search(InitialList_L, &(Element.GeoElement->Region), fcmp_int)) || (!InitialList_L && Element.GeoElement->Region == Current.Region)) { Element.Num = Element.GeoElement->Num ; Element.Type = Element.GeoElement->Type ; if (Element.Type == TETRAHEDRON || Element.Type == HEXAHEDRON || Element.Type == PRISM) { Get_NodesCoordinatesOfElement(&Element) ; Get_BFGeoElement(&Element, 0., 0., 0.) ; c11 = c21 = c31 = c12 = c22 = c32 = c13 = c23 = c33 = 0; for ( i = 0 ; i < Element.GeoElement->NbrNodes ; i++ ) { c11 += Element.x[i] * Element.dndu[i][0] ; c21 += Element.x[i] * Element.dndu[i][1] ; c31 += Element.x[i] * Element.dndu[i][2] ; c12 += Element.y[i] * Element.dndu[i][0] ; c22 += Element.y[i] * Element.dndu[i][1] ; c32 += Element.y[i] * Element.dndu[i][2] ; c13 += Element.z[i] * Element.dndu[i][0] ; c23 += Element.z[i] * Element.dndu[i][1] ; c33 += Element.z[i] * Element.dndu[i][2] ; } DetJac = c11 * c22 * c33 + c13 * c21 * c32 + c12 * c23 * c31 - c13 * c22 * c31 - c11 * c23 * c32 - c12 * c21 * c33 ; switch(Element.Type){ case TETRAHEDRON: Val_Volume += 1./6. * fabs(DetJac); break; case HEXAHEDRON: Val_Volume += 8. * fabs(DetJac); break; case PRISM: Val_Volume += fabs(DetJac); break; } } else { Message::Error("Function 'GetVolume' only valid for %s", Get_StringForDefine(Element_Type, Element.Type)); } } } Fct->Active->Case.GetVolume.Value = Val_Volume ; } V->Type = SCALAR ; V->Val[0] = Fct->Active->Case.GetVolume.Value ; V->Val[MAX_DIM] = 0; for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) { V->Val[MAX_DIM* k] = V->Val[0] ; V->Val[MAX_DIM* (k+1)] = 0 ; } } static double POINT_TO_PROJECT[3], ELLIPSE_PARAMETERS[2]; static double dist_ellipse(double t) { double x, y; x = ELLIPSE_PARAMETERS[0] * cos(t); y = ELLIPSE_PARAMETERS[1] * sin(t); return sqrt(SQU(x - POINT_TO_PROJECT[0]) + SQU(y - POINT_TO_PROJECT[1])); } void F_ProjectPointOnEllipse(F_ARG) { int k; double t1 = 0., t2 = 1.e-6, t3, f1, f2, f3, tol = 1.e-4; double t, x, y; POINT_TO_PROJECT[0] = A->Val[0]; POINT_TO_PROJECT[1] = A->Val[1]; POINT_TO_PROJECT[2] = A->Val[2]; ELLIPSE_PARAMETERS[0] = Fct->Para[0] ; ELLIPSE_PARAMETERS[1] = Fct->Para[1] ; mnbrak(&t1, &t2, &t3, &f1, &f2, &f3, dist_ellipse); if(t1 > t2){ t = t1; t1 = t3; t3 = t; } brent(t1, t2, t3, dist_ellipse, tol, &t); x = ELLIPSE_PARAMETERS[0] * cos(t); y = ELLIPSE_PARAMETERS[1] * sin(t); /* printf("SL(%g,%g,0,%g,%g,0){1,1};\n", A->Val[0], A->Val[1], x, y); */ for (k = 0 ; k < Current.NbrHar ; k++) { V->Val[MAX_DIM*k ] = 0. ; V->Val[MAX_DIM*k+1] = 0. ; V->Val[MAX_DIM*k+2] = 0. ; } V->Val[0] = x; V->Val[1] = y; V->Type = VECTOR ; } getdp-2.4.2-source/Legacy/Pos_Print.cpp000644 001750 001750 00000153635 12116424202 021434 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include #include "ProData.h" #include "GeoData.h" #include "Cal_PostQuantity.h" #include "Get_Geometry.h" #include "Get_DofOfElement.h" #include "Get_FunctionValue.h" #include "ExtendedGroup.h" #include "Cal_Quantity.h" #include "Cal_Value.h" #include "Pos_Formulation.h" #include "Pos_Element.h" #include "Pos_Search.h" #include "Pos_Print.h" #include "Pos_Format.h" #include "Adapt.h" #include "MallocUtils.h" #include "Message.h" #define SQU(a) ((a)*(a)) extern struct Problem Problem_S ; extern struct CurrentData Current ; extern int Flag_BIN ; extern FILE *PostStream ; /* Print OnElementsOf ------------------ expl: plot on elements, belonging to the current mesh, where the solution was computed during the processing stage args: list of groups of region type Print OnSection --------------- expl: plot an a 'real' cut of the mesh, i.e. computation on the intersections of the mesh with a cutting entity (plane, line) args: 2 (not done) or 3 points, specifying the cutting line or the cutting plane Print OnGrid ------------ expl: reinterpolate the solution on a grid args: - a list of groups of region type (belonging to a mesh, where the solution will be reinterpolated) - 3 expressions (using $S and $T) and 2 intervals for the parametric grid definition Print OnPoint, OnLine, OnPlane, OnBox ------------------------------------- expl: reinterpolate the solution on a grid (particular cases) args: 1, 2, 3 or 4 points (0d, 1d, 2d or 3d grid) and the associated number of divisions Print OnRegion -------------- expl: print Global Quantities associated with Regions args: list of groups of region type */ /* ------------------------------------------------------------------------ */ /* P o s _ P r i n t O n E l e m e n t s O f */ /* ------------------------------------------------------------------------ */ struct CutEdge { int nbc ; double x[2],y[2],z[2] ; double xc,yc,zc ; double uc,vc,wc ; struct Value *Value ; } ; struct xyzv{ double x,y,z; struct Value v; /*int nbvals; for time domain -> malloc Value *v... */ int nboccurences; }; static int fcmp_xyzv(const void * a, const void * b) { struct xyzv *p1, *p2; double TOL = Current.GeoData->CharacteristicLength * 1.e-8; p1 = (struct xyzv*)a; p2 = (struct xyzv*)b; if(p1->x - p2->x > TOL) return 1; if(p1->x - p2->x <-TOL) return -1; if(p1->y - p2->y > TOL) return 1; if(p1->y - p2->y <-TOL) return -1; if(p1->z - p2->z > TOL) return 1; if(p1->z - p2->z <-TOL) return -1; return 0; } static List_T * SkinPostElement_L ; static int SkinDepth ; static void Cut_SkinPostElement(void *a, void *b) { struct PostElement * PE ; PE = *(struct PostElement**)a ; Cut_PostElement(PE, Geo_GetGeoElement(PE->Index), SkinPostElement_L, PE->Index, SkinDepth, 0, 1) ; } static void Decompose_SkinPostElement(void *a, void *b) { struct PostElement * PE, * PE2 ; PE = *(struct PostElement**)a ; if(PE->Type != QUADRANGLE) return; /* change the quad to a tri */ PE->Type = TRIANGLE; PE->NbrNodes = 3; /* create a second tri */ PE2 = NodeCopy_PostElement(PE) ; PE2->NumNodes[1] = PE->NumNodes[2]; PE2->u[1] = PE->u[2]; PE2->x[1] = PE->x[2]; PE2->v[1] = PE->v[2]; PE2->y[1] = PE->y[2]; PE2->w[1] = PE->w[2]; PE2->z[1] = PE->z[2]; PE2->NumNodes[2] = PE->NumNodes[3]; PE2->u[2] = PE->u[3]; PE2->x[2] = PE->x[3]; PE2->v[2] = PE->v[3]; PE2->y[2] = PE->y[3]; PE2->w[2] = PE->w[3]; PE2->z[2] = PE->z[3]; List_Add(SkinPostElement_L, &PE2); } void Pos_PrintOnElementsOf(struct PostQuantity *NCPQ_P, struct PostQuantity *CPQ_P, int Order, struct DefineQuantity *DefineQuantity_P0, struct QuantityStorage *QuantityStorage_P0, struct PostSubOperation *PSO_P) { Tree_T * PostElement_T ; List_T * PostElement_L, * Region_L ; struct Element Element ; struct PostElement * PE ; struct Value * CumulativeValues ; struct xyzv xyzv, *xyzv_P ; Tree_T * xyzv_T ; double * Error=NULL, Dummy[5], d, x1, x2 ; int jj, NbrGeo, iGeo, incGeo, NbrPost=0, iPost ; int NbrTimeStep, iTime, iNode ; int Store = 0, DecomposeInSimplex = 0, Depth ; /* Select the TimeSteps */ NbrTimeStep = Pos_InitTimeSteps(PSO_P); /* Print the header */ NbrGeo = Geo_GetNbrGeoElements() ; Format_PostHeader(PSO_P, NbrTimeStep, Order, PSO_P->Label ? PSO_P->Label : (NCPQ_P ? NCPQ_P->Name : NULL), PSO_P->Label ? NULL : (CPQ_P ? CPQ_P->Name : NULL)); /* Get the region */ Region_L = ((struct Group *) List_Pointer(Problem_S.Group, PSO_P->Case.OnRegion.RegionIndex))->InitialList ; Get_InitDofOfElement(&Element) ; /* Compute the Cumulative quantity, if any */ if(CPQ_P){ Cal_PostCumulativeQuantity(Region_L, PSO_P->PostQuantitySupport[Order], PSO_P->TimeStep_L, CPQ_P, DefineQuantity_P0, QuantityStorage_P0, &CumulativeValues); } /* Init a search grid if we plot a NonCumulative quantity with OnGrid */ if(NCPQ_P && PSO_P->SubType == PRINT_ONGRID) Init_SearchGrid(&Current.GeoData->Grid) ; /* If we compute a skin, apply smoothing, sort the results, or perform adaption, we'll need to store all the PostElements */ if(PSO_P->Smoothing || PSO_P->Skin || PSO_P->Adapt || PSO_P->Sort) Store = 1 ; /* Check if everything is OK for Adaption */ if(PSO_P->Adapt){ if(PSO_P->Dimension == _ALL){ Message::Error("You have to specify a Dimension for the adaptation (2 or 3)"); return; } if(PSO_P->Target < 0.){ Message::Error("You have to specify a Target for the adaptation (e.g. 0.01)"); return; } if(NbrTimeStep > 1){ Message::Error("Adaption not ready with more than one time step"); return; } } /* Check if we should decompose all PostElements to simplices */ if(!PSO_P->Skin && PSO_P->DecomposeInSimplex) DecomposeInSimplex = 1 ; /* Check for de-refinement */ if(PSO_P->Depth < 0) incGeo = - PSO_P->Depth ; else incGeo = 1 ; /* Create the list of PostElements */ PostElement_L = List_Create(Store ? NbrGeo/10 : 10, Store ? NbrGeo/10 : 10, sizeof(struct PostElement *)) ; if(Store){ /* If we have a Skin, we will divide after the skin extraction */ if(PSO_P->Skin && PSO_P->Depth > 1) Depth = 1; else Depth = PSO_P->Depth; /* Generate all PostElements */ Message::ResetProgressMeter(); for(iGeo = 0 ; iGeo < NbrGeo ; iGeo += incGeo) { Element.GeoElement = Geo_GetGeoElement(iGeo) ; if(List_Search(Region_L, &Element.GeoElement->Region, fcmp_int)){ Fill_PostElement(Element.GeoElement, PostElement_L, iGeo, Depth, PSO_P->Skin, PSO_P->EvaluationPoints, DecomposeInSimplex) ; } Message::ProgressMeter(iGeo + 1, NbrGeo, "Post-processing (Generate)"); if(Message::GetErrorCount()) break; } /* Compute the skin */ if(PSO_P->Skin){ PostElement_T = Tree_Create(sizeof(struct PostElement *), fcmp_PostElement); Message::ResetProgressMeter(); for(iPost = 0 ; iPost < List_Nbr(PostElement_L) ; iPost++){ PE = *(struct PostElement**)List_Pointer(PostElement_L, iPost) ; if(Tree_PQuery(PostElement_T, &PE)){ Tree_Suppress(PostElement_T, &PE); Destroy_PostElement(PE) ; } else Tree_Add(PostElement_T, &PE); Message::ProgressMeter(iPost + 1, List_Nbr(PostElement_L), "Post-processing (Skin)"); if(Message::GetErrorCount()) break; } /* only decompose in simplices (triangles!) now */ if(PSO_P->DecomposeInSimplex){ List_Reset(PostElement_L); SkinPostElement_L = PostElement_L ; Tree_Action(PostElement_T, Decompose_SkinPostElement); for(iPost = 0 ; iPost < List_Nbr(SkinPostElement_L) ; iPost++) Tree_Add(PostElement_T, (struct PostElement**)List_Pointer(SkinPostElement_L, iPost)) ; } if(PSO_P->Depth > 1){ List_Reset(PostElement_L); SkinPostElement_L = PostElement_L ; SkinDepth = PSO_P->Depth ; Tree_Action(PostElement_T, Cut_SkinPostElement) ; } else{ List_Delete(PostElement_L); PostElement_L = Tree2List(PostElement_T); } Tree_Delete(PostElement_T); } } /* if Store */ /* Loop on GeoElements */ Message::ResetProgressMeter(); for(iGeo = 0 ; iGeo < NbrGeo ; iGeo += incGeo) { if(Store){ if(iGeo) break ; } else{ List_Reset(PostElement_L) ; Element.GeoElement = Geo_GetGeoElement(iGeo) ; if(List_Search(Region_L, &Element.GeoElement->Region, fcmp_int)){ Fill_PostElement(Element.GeoElement, PostElement_L, iGeo, PSO_P->Depth, PSO_P->Skin, PSO_P->EvaluationPoints, DecomposeInSimplex) ; } } NbrPost = List_Nbr(PostElement_L) ; /* Loop on PostElements */ for(iPost = 0 ; iPost < NbrPost ; iPost++) { PE = *(struct PostElement **)List_Pointer(PostElement_L, iPost) ; if(!NCPQ_P){ /* Only one Cumulative */ for (iTime = 0 ; iTime < NbrTimeStep ; iTime++){ for(iNode = 0 ; iNode < PE->NbrNodes ; iNode++) Cal_CopyValue(&CumulativeValues[iTime], &PE->Value[iNode]); if(!Store) Format_PostElement(PSO_P, PSO_P->Iso, 0, Current.Time, iTime, NbrTimeStep, Current.NbrHar, PSO_P->HarmonicToTime, NULL, PE); } } else{ /* There is one non-cumulative */ if(PSO_P->SubType == PRINT_ONGRID){ /* We re-interpolate */ for (iTime = 0 ; iTime < NbrTimeStep ; iTime++) { Pos_InitAllSolutions(PSO_P->TimeStep_L, iTime) ; for(iNode = 0 ; iNode < PE->NbrNodes ; iNode++){ InWhichElement(Current.GeoData->Grid, Region_L, &Element, PSO_P->Dimension, PE->x[iNode], PE->y[iNode], PE->z[iNode], &PE->u[iNode], &PE->v[iNode], &PE->w[iNode]) ; Current.Region = Element.Region ; Current.x = PE->x[iNode] ; Current.y = PE->y[iNode] ; Current.z = PE->z[iNode] ; Cal_PostQuantity(NCPQ_P, DefineQuantity_P0, QuantityStorage_P0, NULL, &Element, PE->u[iNode], PE->v[iNode], PE->w[iNode], &PE->Value[iNode]); if(CPQ_P) Combine_PostQuantity(PSO_P->CombinationType, Order, &PE->Value[iNode], &CumulativeValues[iNode]) ; } if(!Store) Format_PostElement(PSO_P, PSO_P->Iso, 0, Current.Time, iTime, NbrTimeStep, Current.NbrHar, PSO_P->HarmonicToTime, NULL, PE); } } else{ /* PRINT_ONREGION: We work on the real mesh */ Element.GeoElement = Geo_GetGeoElement(PE->Index) ; Element.Num = Element.GeoElement->Num ; Element.Type = Element.GeoElement->Type ; Current.Region = Element.Region = Element.GeoElement->Region ; Get_NodesCoordinatesOfElement(&Element) ; for (iTime = 0 ; iTime < NbrTimeStep ; iTime++) { Pos_InitAllSolutions(PSO_P->TimeStep_L, iTime) ; for(iNode = 0 ; iNode < PE->NbrNodes ; iNode++){ Current.x = PE->x[iNode] ; Current.y = PE->y[iNode] ; Current.z = PE->z[iNode] ; Cal_PostQuantity(NCPQ_P, DefineQuantity_P0, QuantityStorage_P0, NULL, &Element, PE->u[iNode], PE->v[iNode], PE->w[iNode], &PE->Value[iNode]); if(CPQ_P) Combine_PostQuantity(PSO_P->CombinationType, Order, &PE->Value[iNode], &CumulativeValues[iTime]) ; } if(!Store) Format_PostElement(PSO_P, PSO_P->Iso, 0, Current.Time, iTime, NbrTimeStep, Current.NbrHar, PSO_P->HarmonicToTime, NULL, PE); } } } if(!Store) Destroy_PostElement(PE) ; } Message::ProgressMeter(iGeo + 1, NbrGeo, "Post-processing (Compute)"); if(Message::GetErrorCount()) break; } /* for iGeo */ /* Perform Smoothing */ if(PSO_P->Smoothing){ Message::Info("Smoothing (phase 1)"); xyzv_T = Tree_Create(sizeof(struct xyzv), fcmp_xyzv); for (iPost = 0 ; iPost < NbrPost ; iPost++){ PE = *(struct PostElement**)List_Pointer(PostElement_L, iPost) ; for(iNode = 0 ; iNode < PE->NbrNodes ; iNode++) { xyzv.x = PE->x[iNode]; xyzv.y = PE->y[iNode]; xyzv.z = PE->z[iNode]; if((xyzv_P = (struct xyzv*)Tree_PQuery(xyzv_T, &xyzv))){ x1 = (double)(xyzv_P->nboccurences)/ (double)(xyzv_P->nboccurences + 1.); x2 = 1./(double)(xyzv_P->nboccurences + 1); Cal_AddMultValue2(&xyzv_P->v, x1, &PE->Value[iNode], x2); xyzv_P->nboccurences++; } else{ Cal_CopyValue(&PE->Value[iNode],&xyzv.v); xyzv.nboccurences = 1; Tree_Add(xyzv_T, &xyzv); } } } Message::Info("Smoothing (phase 2)"); for(iPost = 0 ; iPost < NbrPost ; iPost++){ PE = *(struct PostElement**)List_Pointer(PostElement_L, iPost) ; for(iNode = 0 ; iNode < PE->NbrNodes ; iNode++) { xyzv.x = PE->x[iNode]; xyzv.y = PE->y[iNode]; xyzv.z = PE->z[iNode]; if((xyzv_P = (struct xyzv*)Tree_PQuery(xyzv_T, &xyzv))){ Cal_CopyValue(&xyzv_P->v, &PE->Value[iNode]); } else Message::Warning("Node (%g,%g,%g) not found", xyzv.x, xyzv.y, xyzv.z); } } Tree_Delete(xyzv_T); } /* if Smoothing */ /* Perform Adaption */ if(PSO_P->Adapt){ if(!Current.GeoData->H) Current.GeoData->H = (double*)Malloc((NbrGeo+2)*sizeof(double)) ; if(!Current.GeoData->P) Current.GeoData->P = (double*)Malloc((NbrGeo+2)*sizeof(double)) ; Error = (double*)Malloc((NbrGeo+1)*sizeof(double)) ; /* All elements are perfect... */ for(iGeo = 0 ; iGeo < NbrGeo ; iGeo++){ Element.GeoElement = Geo_GetGeoElement(iGeo) ; Element.Num = Element.GeoElement->Num ; Element.Type = Element.GeoElement->Type ; Element.Region = Element.GeoElement->Region ; Get_NodesCoordinatesOfElement(&Element) ; Current.GeoData->H[iGeo+1] = Cal_MaxEdgeLength(&Element) ; Current.GeoData->P[iGeo+1] = 1. ; Error[iGeo+1] = PSO_P->Target ; } /* ...except those we want to optimize */ for(iPost = 0 ; iPost < NbrPost ; iPost++){ PE = *(struct PostElement**)List_Pointer(PostElement_L, iPost); Error[PE->Index+1] = 0. ; for(iNode = 0 ; iNode < PE->NbrNodes ; iNode++) Error[PE->Index+1] += PE->Value[iNode].Val[0] ; Error[PE->Index+1] /= (double)PE->NbrNodes ; } Adapt (NbrGeo, PSO_P->Adapt, PSO_P->Dimension, Error, Current.GeoData->H, Current.GeoData->P, PSO_P->Target); /* Clean up the interpolation orders to fit to what's available */ if(List_Nbr(PSO_P->Value_L)){ for(iGeo = 0 ; iGeo < NbrGeo ; iGeo++){ for(jj = List_Nbr(PSO_P->Value_L)-1 ; jj >= 0 ; jj--){ d = *(double*)List_Pointer(PSO_P->Value_L, jj); if(Current.GeoData->P[iGeo+1] > d || jj == 0){ Current.GeoData->P[iGeo+1] = d ; break ; } } } } } /* if Adapt */ /* Print everything if we are in Store mode */ if(Store){ /* Sort the elements */ switch(PSO_P->Sort){ case SORT_BY_POSITION : List_Sort(PostElement_L, fcmp_PostElement) ; break ; case SORT_BY_CONNECTIVITY : Sort_PostElement_Connectivity(PostElement_L) ; break ; } Dummy[0] = Dummy[1] = Dummy[2] = Dummy[3] = Dummy[4] = 0. ; for(iPost = 0 ; iPost < NbrPost ; iPost++){ PE = *(struct PostElement**)List_Pointer(PostElement_L, iPost); /* Get the values from adaption */ if(PSO_P->Adapt){ Element.GeoElement = Geo_GetGeoElement(PE->Index) ; Dummy[0] = Element.GeoElement->Num ; Dummy[1] = Error[PE->Index+1] ; Dummy[2] = Current.GeoData->H[PE->Index+1] ; Dummy[3] = Current.GeoData->P[PE->Index+1] ; Dummy[4] = iPost ? 0 : NbrPost ; for(iNode = 0 ; iNode < PE->NbrNodes ; iNode++){ PE->Value[iNode].Type = SCALAR ; if(PSO_P->Adapt == H1 || PSO_P->Adapt == H2) PE->Value[iNode].Val[0] = Dummy[2] ; else PE->Value[iNode].Val[0] = Dummy[3] ; } } /* Compute curvilinear coord if connection sort */ if(PSO_P->Sort == SORT_BY_CONNECTIVITY){ Dummy[0] = Dummy[1] ; Dummy[1] = Dummy[0] + sqrt(SQU(PE->x[1]-PE->x[0])+ SQU(PE->y[1]-PE->y[0])+ SQU(PE->z[1]-PE->z[0])) ; Dummy[2] = PE->v[0] ; Dummy[3] = -1. ; } Format_PostElement(PSO_P, PSO_P->Iso, 1, Current.Time, 0, 1, Current.NbrHar, PSO_P->HarmonicToTime, Dummy, PE); } } Format_PostFooter(PSO_P, Store); if(Store) for(iPost = 0 ; iPost < NbrPost ; iPost++){ PE = *(struct PostElement**)List_Pointer(PostElement_L, iPost); Destroy_PostElement(PE) ; } List_Delete(PostElement_L); if(CPQ_P) Free(CumulativeValues); if(PSO_P->Adapt) Free(Error) ; } /* ------------------------------------------------------------------------ */ /* P o s _ P r i n t O n S e c t i o n */ /* ------------------------------------------------------------------------ */ double Plane(double a, double b, double c, double d, double x, double y, double z) { return (a*x+b*y+c*z+d); } static double DIRX[3], DIRY[3], DIRZ[3], XCP, YCP ; int fcmp_Angle (const void *a, const void *b) { struct CutEdge *q , *w; double x1,y1,x2,y2,ang1,ang2; q = (struct CutEdge*)a; w = (struct CutEdge*)b; x1 = q->xc*DIRX[0] + q->yc*DIRX[1] + q->zc*DIRX[2]; y1 = q->xc*DIRY[0] + q->yc*DIRY[1] + q->zc*DIRY[2]; x2 = w->xc*DIRX[0] + w->yc*DIRX[1] + w->zc*DIRX[2]; y2 = w->xc*DIRY[0] + w->yc*DIRY[1] + w->zc*DIRY[2]; ang1 = atan2(y1-YCP,x1-XCP); ang2 = atan2(y2-YCP,x2-XCP); if(ang1>ang2)return 1; return -1; } void prodvec (double *a , double *b , double *c) { c[0] = a[1]*b[2]-a[2]*b[1]; c[1] = a[2]*b[0]-a[0]*b[2]; c[2] = a[0]*b[1]-a[1]*b[0]; } void normvec(double *a) { double mod; mod = sqrt(SQU(a[0])+SQU(a[1])+SQU(a[2])); a[0]/=mod; a[1]/=mod; a[2]/=mod; } #define NBR_MAX_CUT 10 #define LETS_PRINT_THE_RESULT \ List_Reset(PE_L); \ if(PSO_P->Depth < 2) \ List_Add(PE_L, &PE) ; \ else \ Cut_PostElement(PE, Element.GeoElement, PE_L, PE->Index, \ PSO_P->Depth, 0, 1) ; \ for(iPost = 0 ; iPost < List_Nbr(PE_L) ; iPost++){ \ PE = *(struct PostElement **)List_Pointer(PE_L, iPost) ; \ for(iTime = 0 ; iTime < NbTimeStep ; iTime++){ \ Pos_InitAllSolutions(PSO_P->TimeStep_L, iTime) ; \ for(iNode = 0 ; iNode < PE->NbrNodes ; iNode++){ \ if(NCPQ_P){ \ Current.x = PE->x[iNode] ; \ Current.y = PE->y[iNode] ; \ Current.z = PE->z[iNode] ; \ Cal_PostQuantity(NCPQ_P, DefineQuantity_P0, QuantityStorage_P0, \ NULL, &Element, PE->u[iNode], PE->v[iNode], PE->w[iNode], \ &PE->Value[iNode]); \ if(CPQ_P) \ Combine_PostQuantity(PSO_P->CombinationType, Order, \ &PE->Value[iNode], &CumulativeValues[iTime]) ; \ } \ else \ Cal_CopyValue(&CumulativeValues[iTime],&PE->Value[iNode]); \ } \ Format_PostElement(PSO_P, PSO_P->Iso,0, \ Current.Time, iTime, NbTimeStep, \ Current.NbrHar, PSO_P->HarmonicToTime, \ NULL, PE); \ } \ } \ for(iPost = 0 ; iPost < List_Nbr(PE_L) ; iPost++) \ Destroy_PostElement(*(struct PostElement **)List_Pointer(PE_L, iPost)); void Pos_PrintOnSection(struct PostQuantity *NCPQ_P, struct PostQuantity *CPQ_P, int Order, struct DefineQuantity *DefineQuantity_P0, struct QuantityStorage *QuantityStorage_P0, struct PostSubOperation *PSO_P) { struct CutEdge e[NBR_MAX_CUT]; struct Element Element ; struct PostElement * PE ; struct Value * CumulativeValues ; List_T * PE_L ; int NbGeoElement, NbTimeStep, NbCut, * NumNodes ; int iPost, iNode, iGeo, iCut, iEdge, iTime ; double A, B, C, D, d1, d2, u, xcg, ycg, zcg ; double x[3], y[3], z[3] ; NbTimeStep = Pos_InitTimeSteps(PSO_P); PE_L = List_Create(10, 10, sizeof(struct PostElement *)) ; for(iCut = 0 ; iCut < NBR_MAX_CUT ; iCut++) e[iCut].Value = (struct Value*) Malloc(NbTimeStep*sizeof(struct Value)) ; Format_PostHeader(PSO_P, NbTimeStep, Order, PSO_P->Label ? PSO_P->Label : (NCPQ_P ? NCPQ_P->Name : NULL), PSO_P->Label ? NULL : (CPQ_P ? CPQ_P->Name : NULL)); if(CPQ_P){ Cal_PostCumulativeQuantity(NULL, PSO_P->PostQuantitySupport[Order], PSO_P->TimeStep_L, CPQ_P, DefineQuantity_P0, QuantityStorage_P0, &CumulativeValues); } switch(PSO_P->SubType) { case PRINT_ONSECTION_1D : Message::Error("Print on 1D cuts not done (use Print OnLine instead)"); break; case PRINT_ONSECTION_2D : /* Ax+By+Cz+D=0 from (x0,y0,z0),(x1,y1,z1),(x2,y2,z2) */ x[0] = PSO_P->Case.OnSection.x[0] ; y[0] = PSO_P->Case.OnSection.y[0] ; z[0] = PSO_P->Case.OnSection.z[0] ; x[1] = PSO_P->Case.OnSection.x[1] ; y[1] = PSO_P->Case.OnSection.y[1] ; z[1] = PSO_P->Case.OnSection.z[1] ; x[2] = PSO_P->Case.OnSection.x[2] ; y[2] = PSO_P->Case.OnSection.y[2] ; z[2] = PSO_P->Case.OnSection.z[2] ; A = (y[1]-y[0])*(z[2]-z[0]) - (z[1]-z[0])*(y[2]-y[0]) ; B = -(x[1]-x[0])*(z[2]-z[0]) + (z[1]-z[0])*(x[2]-x[0]) ; C = (x[1]-x[0])*(y[2]-y[0]) - (y[1]-y[0])*(x[2]-x[0]) ; D = -A*x[0]-B*y[0]-C*z[0] ; /* Cut each element */ NbGeoElement = Geo_GetNbrGeoElements() ; Message::ResetProgressMeter(); for(iGeo = 0 ; iGeo < NbGeoElement ; iGeo++) { Element.GeoElement = Geo_GetGeoElement(iGeo) ; Element.Num = Element.GeoElement->Num ; Element.Type = Element.GeoElement->Type ; Current.Region = Element.Region = Element.GeoElement->Region ; if((PSO_P->Dimension == _ALL && (Element.GeoElement->Type != POINT)) || (PSO_P->Dimension == _3D && (Element.GeoElement->Type & (TETRAHEDRON|HEXAHEDRON|PRISM|PYRAMID))) || (PSO_P->Dimension == _2D && (Element.GeoElement->Type & (TRIANGLE|QUADRANGLE))) || (PSO_P->Dimension == _1D && (Element.GeoElement->Type & LINE))){ Get_NodesCoordinatesOfElement(&Element) ; if(Element.GeoElement->NbrEdges == 0) Geo_CreateEdgesOfElement(Element.GeoElement) ; NbCut = 0; for(iEdge = 0 ; iEdge < Element.GeoElement->NbrEdges ; iEdge++){ NumNodes = Geo_GetNodesOfEdgeInElement(Element.GeoElement, iEdge) ; e[NbCut].x[0] = Element.x[abs(NumNodes[0])-1] ; e[NbCut].y[0] = Element.y[abs(NumNodes[0])-1] ; e[NbCut].z[0] = Element.z[abs(NumNodes[0])-1] ; e[NbCut].x[1] = Element.x[abs(NumNodes[1])-1] ; e[NbCut].y[1] = Element.y[abs(NumNodes[1])-1] ; e[NbCut].z[1] = Element.z[abs(NumNodes[1])-1] ; d1 = Plane(A,B,C,D,e[NbCut].x[0],e[NbCut].y[0],e[NbCut].z[0]); d2 = Plane(A,B,C,D,e[NbCut].x[1],e[NbCut].y[1],e[NbCut].z[1]); if(d1*d2 <= 0) { if(d1*d2 < 0.) u = -d2/(d1-d2) ; else if(d1 == 0.) u = 1. ; else u = 0. ; e[NbCut].xc = u*e[NbCut].x[0] + (1.-u)*e[NbCut].x[1]; e[NbCut].yc = u*e[NbCut].y[0] + (1.-u)*e[NbCut].y[1]; e[NbCut].zc = u*e[NbCut].z[0] + (1.-u)*e[NbCut].z[1]; if(NCPQ_P) xyz2uvwInAnElement(&Element, e[NbCut].xc, e[NbCut].yc, e[NbCut].zc, &e[NbCut].uc, &e[NbCut].vc, &e[NbCut].wc); NbCut++; } } if(NbCut > 3){ xcg = ycg = zcg = 0.; for(iCut = 0 ; iCut < NbCut ; iCut++){ xcg += e[iCut].xc; ycg += e[iCut].yc; zcg += e[iCut].zc; } xcg /= (double)NbCut; ycg /= (double)NbCut; zcg /= (double)NbCut; DIRZ[0] = A; DIRY[0] = xcg-e[0].xc; DIRZ[1] = B; DIRY[1] = ycg-e[0].yc; DIRZ[2] = C; DIRY[2] = zcg-e[0].zc; normvec(DIRZ); normvec(DIRY); prodvec(DIRY,DIRZ,DIRX); normvec(DIRX); XCP = xcg*DIRX[0] + ycg*DIRX[1] + zcg*DIRX[2]; YCP = xcg*DIRY[0] + ycg*DIRY[1] + zcg*DIRY[2]; qsort(e,NbCut,sizeof(struct CutEdge), fcmp_Angle); } if(NbCut > 2){ iCut = 2; while(iCut < NbCut){ if(PSO_P->Depth > 0){ PE = Create_PostElement(iGeo, TRIANGLE, 3, 1) ; PE->x[0] = e[0].xc; PE->x[1] = e[iCut-1].xc; PE->x[2] = e[iCut].xc; PE->y[0] = e[0].yc; PE->y[1] = e[iCut-1].yc; PE->y[2] = e[iCut].yc; PE->z[0] = e[0].zc; PE->z[1] = e[iCut-1].zc; PE->z[2] = e[iCut].zc; PE->u[0] = e[0].uc; PE->u[1] = e[iCut-1].uc; PE->u[2] = e[iCut].uc; PE->v[0] = e[0].vc; PE->v[1] = e[iCut-1].vc; PE->v[2] = e[iCut].vc; PE->w[0] = e[0].wc; PE->w[1] = e[iCut-1].wc; PE->w[2] = e[iCut].wc; LETS_PRINT_THE_RESULT ; } else{ PE = Create_PostElement(iGeo, POINT, 1, 0) ; PE->x[0] = (e[0].xc + e[iCut-1].xc + e[iCut].xc) / 3. ; PE->y[0] = (e[0].yc + e[iCut-1].yc + e[iCut].yc) / 3. ; PE->z[0] = (e[0].zc + e[iCut-1].zc + e[iCut].zc) / 3. ; PE->u[0] = (e[0].uc + e[iCut-1].uc + e[iCut].uc) / 3. ; PE->v[0] = (e[0].vc + e[iCut-1].vc + e[iCut].vc) / 3. ; PE->w[0] = (e[0].wc + e[iCut-1].wc + e[iCut].wc) / 3. ; LETS_PRINT_THE_RESULT ; } iCut++; } } if(NbCut == 2){ if(PSO_P->Depth > 0){ PE = Create_PostElement(iGeo, LINE, 2, 1) ; PE->x[0] = e[0].xc; PE->x[1] = e[1].xc; PE->y[0] = e[0].yc; PE->y[1] = e[1].yc; PE->z[0] = e[0].zc; PE->z[1] = e[1].zc; PE->u[0] = e[0].uc; PE->u[1] = e[1].uc; PE->v[0] = e[0].vc; PE->v[1] = e[1].vc; PE->w[0] = e[0].wc; PE->w[1] = e[1].wc; LETS_PRINT_THE_RESULT ; } else{ PE = Create_PostElement(iGeo, POINT, 1, 0) ; PE->x[0] = (e[0].xc + e[1].xc) / 2. ; PE->y[0] = (e[0].yc + e[1].yc) / 2. ; PE->z[0] = (e[0].zc + e[1].zc) / 2. ; PE->u[0] = (e[0].uc + e[1].uc) / 2. ; PE->v[0] = (e[0].vc + e[1].vc) / 2. ; PE->w[0] = (e[0].wc + e[1].wc) / 2. ; LETS_PRINT_THE_RESULT ; } } } Message::ProgressMeter(iGeo + 1, NbGeoElement, "Post-processing (Cut)") ; if(Message::GetErrorCount()) break; } Format_PostFooter(PSO_P, 0); break; default : Message::Error("Unknown operation in Print OnSection"); break; } List_Delete(PE_L) ; if(CPQ_P) Free(CumulativeValues); for(iCut = 0 ; iCut < NBR_MAX_CUT ; iCut++) Free(e[iCut].Value) ; } #undef NBR_MAX_CUT #undef LETS_PRINT_THE_RESULT /* ------------------------------------------------------------------------ */ /* P o s _ P r i n t O n G r i d */ /* ------------------------------------------------------------------------ */ #define LETS_PRINT_THE_RESULT \ PE->x[0] = Current.xp = Current.x ; \ PE->y[0] = Current.yp = Current.y ; \ PE->z[0] = Current.zp = Current.z ; \ if(!NCPQ_P){ \ for (ts = 0 ; ts < NbTimeStep ; ts++){ \ PE->Value[0] = CumulativeValues[ts] ; \ Format_PostElement(PSO_P, PSO_P->Iso, 0, \ Current.Time, ts, NbTimeStep, \ Current.NbrHar, PSO_P->HarmonicToTime, \ Normal, PE); \ } \ } \ else{ \ InWhichElement(Current.GeoData->Grid, NULL, &Element, PSO_P->Dimension, \ Current.x, Current.y, Current.z, &u, &v, &w) ; \ Current.Region = Element.Region ; \ if(Element.Num != NO_ELEMENT) \ PE->Index = Geo_GetGeoElementIndex(Element.GeoElement) ; \ else \ PE->Index = NO_ELEMENT ; \ for (ts = 0 ; ts < NbTimeStep ; ts++) { \ Pos_InitAllSolutions(PSO_P->TimeStep_L, ts) ; \ Cal_PostQuantity(NCPQ_P, DefineQuantity_P0, QuantityStorage_P0, \ NULL, &Element, u, v, w, &PE->Value[0]); \ if(CPQ_P) \ Combine_PostQuantity(PSO_P->CombinationType, Order, \ &PE->Value[0], &CumulativeValues[ts]) ; \ Format_PostElement(PSO_P, PSO_P->Iso, 0, \ Current.Time, ts, NbTimeStep, \ Current.NbrHar, PSO_P->HarmonicToTime, \ Normal, PE); \ } \ } #define ARRAY(i,j,k,t) \ Array[ (t) * Current.NbrHar * ((int)N[0]+1) * ((int)N[1]+1) + \ (k) * ((int)N[0]+1) * ((int)N[1]+1) + \ (j) * ((int)N[0]+1) + \ (i) ] #define LETS_STORE_THE_RESULT \ if(!NCPQ_P){ \ if(CumulativeValues[0].Type != SCALAR) \ Message::Error("Print OnPlane not designed for non scalars with Depth > 1"); \ else \ for (ts = 0 ; ts < NbTimeStep ; ts++) \ for(k = 0 ; k < Current.NbrHar ; k++) \ ARRAY(i1,i2,k,ts) = (float)CumulativeValues[ts].Val[MAX_DIM*k] ; \ } \ else{ \ InWhichElement(Current.GeoData->Grid, NULL, &Element, PSO_P->Dimension, \ Current.x, Current.y, Current.z, &u, &v, &w) ; \ Current.Region = Element.Region ; \ for (ts = 0 ; ts < NbTimeStep ; ts++) { \ Pos_InitAllSolutions(PSO_P->TimeStep_L, ts) ; \ Cal_PostQuantity(NCPQ_P, DefineQuantity_P0, QuantityStorage_P0, \ NULL, &Element, u, v, w, &PE->Value[0]); \ if(PE->Value[0].Type != SCALAR) \ Message::Error("Print OnPlane not designed for non scalars with Depth > 1"); \ if(CPQ_P) \ Combine_PostQuantity(PSO_P->CombinationType, Order, \ &PE->Value[0], &CumulativeValues[ts]) ; \ for(k = 0 ; k < Current.NbrHar ; k++) \ ARRAY(i1,i2,k,ts) = (float)PE->Value[0].Val[MAX_DIM*k] ; \ } \ } void Pos_PrintOnGrid(struct PostQuantity *NCPQ_P, struct PostQuantity *CPQ_P, int Order, struct DefineQuantity *DefineQuantity_P0, struct QuantityStorage *QuantityStorage_P0, struct PostSubOperation *PSO_P) { struct Element Element ; struct Value * CumulativeValues, Value ; struct PostElement * PE , * PE2 ; int i1, i2, i3, k, NbTimeStep, ts ; float *Array = NULL ; double u, v, w, Length, Normal[4] = {0., 0., 0., 0.} ; double X[4], Y[4], Z[4], S[4], N[4], tmp[3]; Get_InitDofOfElement(&Element) ; NbTimeStep = Pos_InitTimeSteps(PSO_P); if(CPQ_P){ Cal_PostCumulativeQuantity(NULL, PSO_P->PostQuantitySupport[Order], PSO_P->TimeStep_L, CPQ_P, DefineQuantity_P0, QuantityStorage_P0, &CumulativeValues); } Init_SearchGrid(&Current.GeoData->Grid) ; Format_PostHeader(PSO_P, NbTimeStep, Order, PSO_P->Label ? PSO_P->Label : (NCPQ_P ? NCPQ_P->Name : NULL), PSO_P->Label ? NULL : (CPQ_P ? CPQ_P->Name : NULL)); PE = Create_PostElement(0, POINT, 1, 0) ; switch(PSO_P->SubType) { case PRINT_ONGRID_0D : Current.x = PSO_P->Case.OnGrid.x[0] ; Current.y = PSO_P->Case.OnGrid.y[0] ; Current.z = PSO_P->Case.OnGrid.z[0] ; Normal[0] = Normal[1] = Normal[2] = 0.0 ; LETS_PRINT_THE_RESULT ; break; case PRINT_ONGRID_1D : X[0] = PSO_P->Case.OnGrid.x[0] ; X[1] = PSO_P->Case.OnGrid.x[1] ; Y[0] = PSO_P->Case.OnGrid.y[0] ; Y[1] = PSO_P->Case.OnGrid.y[1] ; Z[0] = PSO_P->Case.OnGrid.z[0] ; Z[1] = PSO_P->Case.OnGrid.z[1] ; N[0] = PSO_P->Case.OnGrid.n[0] ; Normal[1] = Normal[2] = 0.0 ; Length = sqrt(SQU(X[1]-X[0]) + SQU(Y[1]-Y[0]) + SQU(Z[1]-Z[0])) ; for (i1 = 0 ; i1 <= N[0] ; i1++) { S[0] = (double)i1 / (double)(N[0] ? N[0] : 1) ; Normal[0] = Length * S[0] ; Current.x = X[0] + (X[1] - X[0]) * S[0] ; Current.y = Y[0] + (Y[1] - Y[0]) * S[0] ; Current.z = Z[0] + (Z[1] - Z[0]) * S[0] ; LETS_PRINT_THE_RESULT ; } break; case PRINT_ONGRID_2D : X[0] = PSO_P->Case.OnGrid.x[0] ; X[1] = PSO_P->Case.OnGrid.x[1] ; Y[0] = PSO_P->Case.OnGrid.y[0] ; Y[1] = PSO_P->Case.OnGrid.y[1] ; Z[0] = PSO_P->Case.OnGrid.z[0] ; Z[1] = PSO_P->Case.OnGrid.z[1] ; X[2] = PSO_P->Case.OnGrid.x[2] ; Y[2] = PSO_P->Case.OnGrid.y[2] ; Z[2] = PSO_P->Case.OnGrid.z[2] ; S[0] = X[1]-X[0]; S[1] = Y[1]-Y[0]; S[2] = Z[1]-Z[0]; N[0] = X[2]-X[0]; N[1] = Y[2]-Y[0]; N[2] = Z[2]-Z[0]; prodvec(S,N,Normal); Length = sqrt(SQU(Normal[0])+SQU(Normal[1])+SQU(Normal[2])); if(!Length){ Message::Warning("Bad plane (null normal)"); return ; } Normal[0]/=Length ; Normal[1]/=Length ; Normal[2]/=Length ; N[0] = PSO_P->Case.OnGrid.n[0] ; N[1] = PSO_P->Case.OnGrid.n[1] ; if(PSO_P->Depth > 1) Array = (float*) Malloc(NbTimeStep*Current.NbrHar*(int)((N[0]+1)*(N[1]+1))*sizeof(float)) ; for (i1 = 0 ; i1 <= N[0] ; i1++) { S[0] = (double)i1 / (double)(N[0] ? N[0] : 1) ; for (i2 = 0 ; i2 <= N[1] ; i2++) { S[1] = (double)i2 / (double)(N[1] ? N[1] : 1) ; Current.x = X[0] + (X[1] - X[0]) * S[0] + (X[2] - X[0]) * S[1] ; Current.y = Y[0] + (Y[1] - Y[0]) * S[0] + (Y[2] - Y[0]) * S[1] ; Current.z = Z[0] + (Z[1] - Z[0]) * S[0] + (Z[2] - Z[0]) * S[1] ; if(PSO_P->Depth > 1){ LETS_STORE_THE_RESULT ; } else{ LETS_PRINT_THE_RESULT ; } } if(PSO_P->Depth < 2 && !Flag_BIN) fprintf(PostStream, "\n"); } if(PSO_P->Depth > 1){ PE2 = Create_PostElement(0, TRIANGLE, 3, 0); PE2->Value[0].Type = PE2->Value[1].Type = PE2->Value[2].Type = SCALAR ; for (i1 = 0 ; i1 < N[0] ; i1++) { S[0] = (double)i1 / (double)(N[0] ? N[0] : 1) ; S[2] = (double)(i1+1) / (double)(N[0] ? N[0] : 1) ; for (i2 = 0 ; i2 < N[1] ; i2++) { S[1] = (double)i2 / (double)(N[1] ? N[1] : 1) ; S[3] = (double)(i2+1) / (double)(N[1] ? N[1] : 1) ; PE2->x[0] = X[0] + (X[1] - X[0]) * S[0] + (X[2] - X[0]) * S[1] ; PE2->y[0] = Y[0] + (Y[1] - Y[0]) * S[0] + (Y[2] - Y[0]) * S[1] ; PE2->z[0] = Z[0] + (Z[1] - Z[0]) * S[0] + (Z[2] - Z[0]) * S[1] ; PE2->x[1] = X[0] + (X[1] - X[0]) * S[2] + (X[2] - X[0]) * S[1] ; PE2->y[1] = Y[0] + (Y[1] - Y[0]) * S[2] + (Y[2] - Y[0]) * S[1] ; PE2->z[1] = Z[0] + (Z[1] - Z[0]) * S[2] + (Z[2] - Z[0]) * S[1] ; PE2->x[2] = X[0] + (X[1] - X[0]) * S[0] + (X[2] - X[0]) * S[3] ; PE2->y[2] = Y[0] + (Y[1] - Y[0]) * S[0] + (Y[2] - Y[0]) * S[3] ; PE2->z[2] = Z[0] + (Z[1] - Z[0]) * S[0] + (Z[2] - Z[0]) * S[3] ; for (ts = 0 ; ts < NbTimeStep ; ts++){ for(k = 0 ; k < Current.NbrHar ; k++){ PE2->Value[0].Val[MAX_DIM*k] = ARRAY(i1,i2,k,ts) ; PE2->Value[1].Val[MAX_DIM*k] = ARRAY(i1+1,i2,k,ts) ; PE2->Value[2].Val[MAX_DIM*k] = ARRAY(i1,i2+1,k,ts) ; } Format_PostElement(PSO_P, PSO_P->Iso, 0, Current.Time, ts, NbTimeStep, Current.NbrHar, PSO_P->HarmonicToTime, Normal, PE2); } PE2->x[0] = X[0] + (X[1] - X[0]) * S[2] + (X[2] - X[0]) * S[3] ; PE2->y[0] = Y[0] + (Y[1] - Y[0]) * S[2] + (Y[2] - Y[0]) * S[3] ; PE2->z[0] = Z[0] + (Z[1] - Z[0]) * S[2] + (Z[2] - Z[0]) * S[3] ; tmp[0] = PE2->x[1]; PE2->x[1] = PE2->x[2]; PE2->x[2] = tmp[0]; tmp[1] = PE2->y[1]; PE2->y[1] = PE2->y[2]; PE2->y[2] = tmp[1]; tmp[2] = PE2->z[1]; PE2->z[1] = PE2->z[2]; PE2->z[2] = tmp[2]; for (ts = 0 ; ts < NbTimeStep ; ts++){ for(k = 0 ; k < Current.NbrHar ; k++){ PE2->Value[0].Val[MAX_DIM*k] = ARRAY(i1+1,i2+1,k,ts) ; PE2->Value[1].Val[MAX_DIM*k] = ARRAY(i1,i2+1,k,ts) ; PE2->Value[2].Val[MAX_DIM*k] = ARRAY(i1+1,i2,k,ts) ; } Format_PostElement(PSO_P, PSO_P->Iso, 0, Current.Time, ts, NbTimeStep, Current.NbrHar, PSO_P->HarmonicToTime, Normal, PE2); } } } Destroy_PostElement(PE2) ; Free(Array) ; } break; case PRINT_ONGRID_3D : X[0] = PSO_P->Case.OnGrid.x[0] ; X[1] = PSO_P->Case.OnGrid.x[1] ; Y[0] = PSO_P->Case.OnGrid.y[0] ; Y[1] = PSO_P->Case.OnGrid.y[1] ; Z[0] = PSO_P->Case.OnGrid.z[0] ; Z[1] = PSO_P->Case.OnGrid.z[1] ; X[2] = PSO_P->Case.OnGrid.x[2] ; X[3] = PSO_P->Case.OnGrid.x[3] ; Y[2] = PSO_P->Case.OnGrid.y[2] ; Y[3] = PSO_P->Case.OnGrid.y[3] ; Z[2] = PSO_P->Case.OnGrid.z[2] ; Z[3] = PSO_P->Case.OnGrid.z[3] ; N[0] = PSO_P->Case.OnGrid.n[0] ; N[1] = PSO_P->Case.OnGrid.n[1] ; N[2] = PSO_P->Case.OnGrid.n[2] ; Normal[0] = Normal[1] = Normal[2] = 0.0 ; for (i1 = 0 ; i1 <= N[0] ; i1++) { S[0] = (double)i1 / (double)(N[0] ? N[0] : 1) ; for (i2 = 0 ; i2 <= N[1] ; i2++) { S[1] = (double)i2 / (double)(N[1] ? N[1] : 1) ; for (i3 = 0 ; i3 <= N[2] ; i3++) { S[2] = (double)i3 / (double)(N[2] ? N[2] : 1) ; Current.x = X[0] + (X[1]-X[0])*S[0] + (X[2]-X[0])*S[1] + (X[3]-X[0])*S[2] ; Current.y = Y[0] + (Y[1]-Y[0])*S[0] + (Y[2]-Y[0])*S[1] + (Y[3]-Y[0])*S[2] ; Current.z = Z[0] + (Z[1]-Z[0])*S[0] + (Z[2]-Z[0])*S[1] + (Z[3]-Z[0])*S[2] ; LETS_PRINT_THE_RESULT ; } if(!Flag_BIN) fprintf(PostStream, "\n"); } if(!Flag_BIN) fprintf(PostStream, "\n\n"); /* two blanks lines for -index in gnuplot */ } break; case PRINT_ONGRID_PARAM : for (i1 = 0 ; i1 < List_Nbr(PSO_P->Case.OnParamGrid.ParameterValue[0]) ; i1++) { List_Read(PSO_P->Case.OnParamGrid.ParameterValue[0], i1, &Current.a) ; for (i2 = 0 ; i2 < List_Nbr(PSO_P->Case.OnParamGrid.ParameterValue[1]) ; i2++) { List_Read(PSO_P->Case.OnParamGrid.ParameterValue[1], i2, &Current.b) ; for (i3 = 0 ; i3 < List_Nbr(PSO_P->Case.OnParamGrid.ParameterValue[2]) ; i3++) { List_Read(PSO_P->Case.OnParamGrid.ParameterValue[2], i3, &Current.c) ; Get_ValueOfExpressionByIndex(PSO_P->Case.OnParamGrid.ExpressionIndex[0], NULL, 0., 0., 0., &Value) ; Current.x = Value.Val[0]; Get_ValueOfExpressionByIndex(PSO_P->Case.OnParamGrid.ExpressionIndex[1], NULL, 0., 0., 0., &Value) ; Current.y = Value.Val[0]; Get_ValueOfExpressionByIndex(PSO_P->Case.OnParamGrid.ExpressionIndex[2], NULL, 0., 0., 0., &Value) ; Current.z = Value.Val[0]; Normal[0] = Current.a ; Normal[1] = Current.b ; Normal[2] = Current.c ; LETS_PRINT_THE_RESULT ; } if(List_Nbr(PSO_P->Case.OnParamGrid.ParameterValue[2])>1 && !Flag_BIN) fprintf(PostStream, "\n"); } if(List_Nbr(PSO_P->Case.OnParamGrid.ParameterValue[1])>1 && !Flag_BIN) fprintf(PostStream, "\n\n"); /* two blanks lines for -index in gnuplot */ } break; } Destroy_PostElement(PE) ; Format_PostFooter(PSO_P, 0); if(CPQ_P) Free(CumulativeValues); } #undef LETS_PRINT_THE_RESULT #undef LETS_STORE_THE_RESULT #undef ARRAY /* ------------------------------------------------------------------------ */ /* P o s _ P r i n t O n R e g i o n */ /* ------------------------------------------------------------------------ */ void Pos_PrintOnRegion(struct PostQuantity *NCPQ_P, struct PostQuantity *CPQ_P, int Order, struct DefineQuantity *DefineQuantity_P0, struct QuantityStorage *QuantityStorage_P0, struct PostSubOperation *PSO_P) { struct Element Element ; struct Value Value, ValueSummed ; struct PostQuantity *PQ_P ; struct Group * Group_P ; List_T *Region_L, *Support_L ; int i, iTime, NbrTimeStep ; int Nbr_Region=0, Num_Region, Group_FunctionType ; int Type_Evaluation=0; double u, v, w; NbrTimeStep = Pos_InitTimeSteps(PSO_P); if (CPQ_P && NCPQ_P){ Message::Error("Only one PostProcessing Quantity allowed in PostOperation") ; return; } if (CPQ_P) { PQ_P = CPQ_P ; Support_L = /* for e.g. PQ[ Support ] ... */ ((struct Group *) List_Pointer(Problem_S.Group, PSO_P->PostQuantitySupport[Order]))->InitialList ; } else { PQ_P = NCPQ_P ; Support_L = NULL ; } Format_PostHeader(PSO_P, NbrTimeStep, Order, PSO_P->Label ? PSO_P->Label : (NCPQ_P ? NCPQ_P->Name : NULL), PSO_P->Label ? NULL : (CPQ_P ? CPQ_P->Name : NULL)); Group_P = (PSO_P->Case.OnRegion.RegionIndex < 0)? NULL : (struct Group *) List_Pointer(Problem_S.Group, PSO_P->Case.OnRegion.RegionIndex); Region_L = Group_P? Group_P->InitialList : NULL ; Group_FunctionType = Group_P? Group_P->FunctionType : REGION; if (!Support_L && List_Nbr(NCPQ_P->PostQuantityTerm) && ( ((struct PostQuantityTerm *)List_Pointer(NCPQ_P->PostQuantityTerm, 0)) ->Type == LOCALQUANTITY && ((struct PostQuantityTerm *)List_Pointer(NCPQ_P->PostQuantityTerm, 0)) ->EvaluationType == LOCAL) ) { if (Group_FunctionType == REGION){ Message::Error("Print OnRegion not valid for PostProcessing Quantity '%s'", NCPQ_P->Name); return; } else Type_Evaluation = LOCAL; } else Type_Evaluation = GLOBAL; if (Region_L) { if (Group_P->FunctionType == REGION) { List_Sort(Region_L, fcmp_int) ; Nbr_Region = List_Nbr(Region_L) ; if (!PSO_P->NoTitle && PSO_P->Format != FORMAT_SPACE_TABLE && PSO_P->Format != FORMAT_VALUE_ONLY) { std::ostringstream sstream; if (PSO_P->Format == FORMAT_GMSH) sstream << "// "; else sstream << "# "; sstream << PQ_P->Name << " on"; for(i = 0 ; i < Nbr_Region ; i++) { List_Read(Region_L, i, &Num_Region) ; sstream << " " << Num_Region; } if(PostStream == stdout || PostStream == stderr) Message::Direct(sstream.str().c_str()); else fprintf(PostStream, "%s\n", sstream.str().c_str()) ; } } else if (Group_P->FunctionType == NODESOF) { if (!Group_P->ExtendedList) Generate_ExtendedGroup(Group_P) ; Region_L = Group_P->ExtendedList ; /* Attention: new Region_L */ Nbr_Region = List_Nbr(Region_L) ; } else { Message::Error("Function type (%d) not allowed for PrintOnRegion", Group_P->FunctionType) ; return; } } else Nbr_Region = 1 ; if (Type_Evaluation == LOCAL) Init_SearchGrid(&Current.GeoData->Grid) ; for (iTime = 0 ; iTime < NbrTimeStep ; iTime++) { Pos_InitAllSolutions(PSO_P->TimeStep_L, iTime) ; if (PSO_P->Format == FORMAT_REGION_VALUE) { Cal_ZeroValue(&ValueSummed) ; } if(Nbr_Region > 1) Message::ResetProgressMeter(); for(i = 0 ; i < Nbr_Region ; i++) { if (Region_L) List_Read(Region_L, i, &Num_Region) ; else Num_Region = NO_REGION ; Current.SubRegion = Num_Region ; /* Region being a GlobalQuantity Entity no */ Current.NumEntity = Num_Region ; /* for OnRegion NodesOf */ Element.GeoElement = NULL ; Element.Num = NO_ELEMENT ; Element.Type = -1 ; Current.Region = Element.Region = Num_Region ; Current.x = Current.y = Current.z = 0. ; if (Type_Evaluation == GLOBAL) { Cal_PostQuantity(PQ_P, DefineQuantity_P0, QuantityStorage_P0, Support_L, &Element, 0., 0., 0., &Value) ; } else { if (Group_FunctionType == NODESOF) Geo_GetNodesCoordinates(1, &Num_Region, &Current.x, &Current.y, &Current.z) ; InWhichElement(Current.GeoData->Grid, NULL, &Element, PSO_P->Dimension, Current.x, Current.y, Current.z, &u, &v, &w) ; Cal_PostQuantity(PQ_P, DefineQuantity_P0, QuantityStorage_P0, Support_L, &Element, u, v, w, &Value) ; } if (PSO_P->Format != FORMAT_REGION_VALUE) { if (PSO_P->StoreInRegister >= 0) Cal_StoreInRegister(&Value, PSO_P->StoreInRegister) ; if (PSO_P->SendToServer && strcmp(PSO_P->SendToServer, "No")){ if(Value.Type == SCALAR) Message::AddOnelabNumberChoice(PSO_P->SendToServer, Value.Val[0], PSO_P->Color); else if(Message::UseOnelab()) Message::Warning("Cannot send non-scalar values to server (yet)"); } } Format_PostValue(PSO_P->Format, PSO_P->Comma, Group_FunctionType, Current.Time, i, Current.NumEntity, Nbr_Region, Current.NbrHar, PSO_P->HarmonicToTime, PSO_P->NoNewLine, &Value) ; if (PSO_P->Format == FORMAT_REGION_VALUE) { ValueSummed.Type = Value.Type ; Cal_AddValue(&ValueSummed, &Value, &ValueSummed); } if(Nbr_Region > 1) Message::ProgressMeter(i + 1, Nbr_Region, "Post-processing (OnRegion)"); } if (PSO_P->Format == FORMAT_REGION_VALUE) { fprintf(PostStream, "%s", Print_Value_ToString(&ValueSummed).c_str()); if (PSO_P->StoreInRegister >= 0) Cal_StoreInRegister(&ValueSummed, PSO_P->StoreInRegister) ; if (PSO_P->SendToServer && strcmp(PSO_P->SendToServer, "No")){ if(Value.Type == SCALAR) Message::AddOnelabNumberChoice(PSO_P->SendToServer, ValueSummed.Val[0], PSO_P->Color); else if(Message::UseOnelab()) Message::Warning("Cannot send non-scalar values to server (yet)"); } } } Format_PostFooter(PSO_P, 0); } /* ------------------------------------------------------------------------ */ /* P o s _ P r i n t W i t h A r g u m e n t */ /* ------------------------------------------------------------------------ */ void Pos_PrintWithArgument(struct PostQuantity *NCPQ_P, struct PostQuantity *CPQ_P, int Order, struct DefineQuantity *DefineQuantity_P0, struct QuantityStorage *QuantityStorage_P0, struct PostSubOperation *PSO_P) { struct Element Element ; struct Value Value ; struct Expression * Expression_P ; List_T *Region_L ; int i, N, Num_Region ; double X[2], S, x ; if(CPQ_P){ Message::Error("Cumulative PostProcessing Quantity in PrintWithArgument not done") ; return; } X[0] = PSO_P->Case.WithArgument.x[0] ; X[1] = PSO_P->Case.WithArgument.x[1] ; N = PSO_P->Case.WithArgument.n ; Expression_P = (struct Expression *) List_Pointer(Problem_S.Expression, PSO_P->Case.WithArgument.ArgumentIndex) ; Region_L = ((struct Group *) List_Pointer(Problem_S.Group, PSO_P->Case.WithArgument.RegionIndex)) ->InitialList ; if (List_Nbr(Region_L)) List_Read(Region_L, 0, &Num_Region) ; else Num_Region = NO_REGION ; for (i = 0 ; i <= N ; i++) { S = (double)i / (double)(N ? N : 1) ; x = X[0] + (X[1] - X[0]) * S ; Expression_P->Case.Constant = x ; Element.GeoElement = NULL ; Element.Num = NO_ELEMENT ; Element.Type = -1 ; Current.Region = Element.Region = Num_Region ; Current.x = Current.y = Current.z = 0. ; Cal_PostQuantity(NCPQ_P, DefineQuantity_P0, QuantityStorage_P0, NULL, &Element, 0., 0., 0., &Value) ; Format_PostValue(PSO_P->Format, PSO_P->Comma, REGION, x, 0, 0, 1, Current.NbrHar, PSO_P->HarmonicToTime, PSO_P->NoNewLine, &Value) ; } } /* ------------------------------------------------------------------------ */ /* P o s _ P r i n t E x p r e s s i o n */ /* ------------------------------------------------------------------------ */ void Pos_PrintExpression(struct PostSubOperation *PSO_P) { int NbrTimeStep, iTime; struct Value Value; char *str = PSO_P->Case.Expression.String; char *str2 = PSO_P->Case.Expression.String2; int expr = PSO_P->Case.Expression.ExpressionIndex; NbrTimeStep = Pos_InitTimeSteps(PSO_P); for(iTime = 0; iTime < NbrTimeStep; iTime++){ Pos_InitAllSolutions(PSO_P->TimeStep_L, iTime) ; if(expr >= 0){ Get_ValueOfExpressionByIndex(expr, NULL, 0., 0., 0., &Value) ; if(str) fprintf(PostStream, "%s", str); fprintf(PostStream, "%s", Print_Value_ToString(&Value).c_str()); } else if(str2){ if(str) fprintf(PostStream, "%s", str); fprintf(PostStream, "%s", str2); } else if(str){ fprintf(PostStream, "%s", str); } if(PSO_P->NoNewLine) fprintf(PostStream, " ") ; else fprintf(PostStream, "\n") ; } } /* ------------------------------------------------------------------------ */ /* P o s _ P r i n t G r o u p */ /* ------------------------------------------------------------------------ */ void Pos_PrintGroup(struct PostSubOperation *PSO_P) { struct Group *Group_P; struct Geo_Element *GeoElement; struct PostElement *SL, *ST, *SQ; List_T *Region_L; int i, NbrGeo, iGeo, *NumNodes; double x [NBR_MAX_NODES_IN_ELEMENT] ; double y [NBR_MAX_NODES_IN_ELEMENT] ; double z [NBR_MAX_NODES_IN_ELEMENT] ; NbrGeo = Geo_GetNbrGeoElements() ; Format_PostHeader(PSO_P, 1, 0, PSO_P->Label, NULL); Region_L = ((struct Group *) List_Pointer(Problem_S.Group, PSO_P->Case.Group.GroupIndex))->InitialList ; Group_P = (struct Group *) List_Pointer(Problem_S.Group, PSO_P->Case.Group.ExtendedGroupIndex); SL = Create_PostElement(0, LINE, 2, 1) ; ST = Create_PostElement(0, TRIANGLE, 3, 1) ; SQ = Create_PostElement(0, QUADRANGLE, 4, 1) ; if(!Group_P->ExtendedList) Generate_ExtendedGroup(Group_P) ; Message::ResetProgressMeter(); for(iGeo = 0 ; iGeo < NbrGeo ; iGeo++) { GeoElement = Geo_GetGeoElement(iGeo) ; if(List_Search(Region_L, &GeoElement->Region, fcmp_int)){ Geo_GetNodesCoordinates (GeoElement->NbrNodes, GeoElement->NumNodes, x, y, z) ; switch (Group_P->FunctionType) { case EDGESOFTREEIN : if(!GeoElement->NbrEdges) Geo_CreateEdgesOfElement(GeoElement) ; for(i=0 ; iNbrEdges ; i++){ if(List_Search(Group_P->ExtendedList, &GeoElement->NumEdges[i], fcmp_absint)){ NumNodes = Geo_GetNodesOfEdgeInElement(GeoElement, i) ; SL->Index = iGeo; SL->x[0] = x[abs(NumNodes[0])-1]; SL->x[1] = x[abs(NumNodes[1])-1]; SL->y[0] = y[abs(NumNodes[0])-1]; SL->y[1] = y[abs(NumNodes[1])-1]; SL->z[0] = z[abs(NumNodes[0])-1]; SL->z[1] = z[abs(NumNodes[1])-1]; SL->Value[0].Type = SL->Value[1].Type = SCALAR ; SL->Value[0].Val[0] = SL->Value[1].Val[0] = GeoElement->NumEdges[i]; Format_PostElement(PSO_P, PSO_P->Iso, 0, 0, 0, 1, 1, 1, NULL, SL); } } break ; case FACETSOFTREEIN : if(!GeoElement->NbrFacets) Geo_CreateFacetsOfElement(GeoElement) ; for(i=0 ; iNbrFacets ; i++){ if(List_Search(Group_P->ExtendedList, &GeoElement->NumFacets[i], fcmp_absint)){ NumNodes = Geo_GetNodesOfFacetInElement(GeoElement, i) ; if(!NumNodes[3]){ // we have triangle ST->Index = iGeo; ST->x[0] = x[abs(NumNodes[0])-1]; ST->x[1] = x[abs(NumNodes[1])-1]; ST->y[0] = y[abs(NumNodes[0])-1]; ST->y[1] = y[abs(NumNodes[1])-1]; ST->z[0] = z[abs(NumNodes[0])-1]; ST->z[1] = z[abs(NumNodes[1])-1]; ST->x[2] = x[abs(NumNodes[2])-1]; ST->y[2] = y[abs(NumNodes[2])-1]; ST->z[2] = z[abs(NumNodes[2])-1]; ST->Value[0].Type = ST->Value[1].Type = ST->Value[2].Type = SCALAR ; ST->Value[0].Val[0] = ST->Value[1].Val[0] = ST->Value[2].Val[0] = GeoElement->NumFacets[i]; Format_PostElement(PSO_P, PSO_P->Iso, 0, 0, 0, 1, 1, 1, NULL, ST); } else{ // we have a quad SQ->Index = iGeo; SQ->x[0] = x[abs(NumNodes[0])-1]; SQ->x[1] = x[abs(NumNodes[1])-1]; SQ->y[0] = y[abs(NumNodes[0])-1]; SQ->y[1] = y[abs(NumNodes[1])-1]; SQ->z[0] = z[abs(NumNodes[0])-1]; SQ->z[1] = z[abs(NumNodes[1])-1]; SQ->x[2] = x[abs(NumNodes[2])-1]; SQ->x[3] = x[abs(NumNodes[3])-1]; SQ->y[2] = y[abs(NumNodes[2])-1]; SQ->y[3] = y[abs(NumNodes[3])-1]; SQ->z[2] = z[abs(NumNodes[2])-1]; SQ->z[3] = z[abs(NumNodes[3])-1]; SQ->Value[0].Type = SQ->Value[1].Type = SQ->Value[2].Type = SQ->Value[3].Type = SCALAR ; SQ->Value[0].Val[0] = SQ->Value[1].Val[0] = SQ->Value[2].Val[0] = SQ->Value[3].Val[0] = GeoElement->NumFacets[i]; Format_PostElement(PSO_P, PSO_P->Iso, 0, 0, 0, 1, 1, 1, NULL, SQ); } } } break ; default : Message::Error("Print function not implemented for this kind of Group"); break ; } } Message::ProgressMeter(iGeo + 1, NbrGeo, "Post-processing (Compute)") ; if(Message::GetErrorCount()) break; } Destroy_PostElement(SL) ; Format_PostFooter(PSO_P, 0); } getdp-2.4.2-source/Legacy/BF_Facet.cpp000644 001750 001750 00000015030 12116424202 021072 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "ProData.h" #include "Message.h" #define NoFace Message::Error("Missing Face Entity in Element %d", Element->Num) /* ------------------------------------------------------------------------ */ /* B F _ F a c e t */ /* ------------------------------------------------------------------------ */ #define WrongNumFacet Message::Error("Wrong Facet number in 'BF_Facet'") void BF_Facet(struct Element * Element, int NumFacet, double u, double v, double w, double s[]) { switch (Element->Type) { case LINE : switch(NumFacet) { case 1 : s[0] = 1. ; s[1] = 0. ; s[2] = 0. ; break ; default : WrongNumFacet ; } break ; case TRIANGLE : switch(NumFacet) { case 1 : s[0] = 0. ; s[1] = 0. ; s[2] = 2. ; break ; default : WrongNumFacet ; } break ; case QUADRANGLE : switch(NumFacet) { case 1 : s[0] = 0. ; s[1] = 0. ; s[2] = 0.5 ; break ; default : WrongNumFacet ; } break ; case TETRAHEDRON : switch(NumFacet) { case 1 : s[0] = 2. * u ; s[1] = -2. * (1.- v) ; s[2] = 2. * w ; break ; case 2 : s[0] = 2. * u ; s[1] = 2. * v ; s[2] = -2. * (1.- w) ; break ; case 3 : s[0] = -2. * (1.- u) ; s[1] = 2. * v ; s[2] = 2. * w ; break ; case 4 : s[0] = 2. * u ; s[1] = 2. * v ; s[2] = 2. * w ; break ; default : WrongNumFacet ; } break ; case HEXAHEDRON : switch(NumFacet) { case 1 : s[0] = 0. ; s[1] = -0.25 * (1. - v) ; s[2] = 0. ; break ; case 2 : s[0] = 0. ; s[1] = 0. ; s[2] = -0.25 * (1. - w) ; break ; case 3 : s[0] = -0.25 * (1. - u) ; s[1] = 0. ; s[2] = 0. ; break ; case 4 : s[0] = 0.25 * (1. + u) ; s[1] = 0. ; s[2] = 0. ; break ; case 5 : s[0] = 0. ; s[1] = 0.25 * (1. + v) ; s[2] = 0. ; break ; case 6 : s[0] = 0. ; s[1] = 0. ; s[2] = 0.25 * (1. + w) ; break ; default : WrongNumFacet ; } break ; case PRISM : switch(NumFacet) { case 1 : s[0] = u ; s[1] = -(1. - v) ; s[2] = 0. ; break ; case 2 : s[0] = 0. ; s[1] = 0. ; s[2] = -(1. - w) ; break ; case 3 : s[0] = -(1. - u) ; s[1] = v ; s[2] = 0. ; break ; case 4 : s[0] = u ; s[1] = v ; s[2] = 0. ; break ; case 5 : s[0] = 0. ; s[1] = 0. ; s[2] = (1. + w) ; break ; default : WrongNumFacet ; } break ; case PYRAMID : if ( w == 1){ switch(NumFacet) { case 1 : s[0] = 0. ; s[1] = -0.5 ; s[2] = 0.25 ; break ; case 2 : s[0] = 0. ; s[1] = 0. ; s[2] = 0. ; break ; case 3 : s[0] = -0.5 ; s[1] = 0. ; s[2] = 0.25 ; break ; case 4 : s[0] = 0.5 ; s[1] = 0. ; s[2] = 0.25 ; break ; case 5 : s[0] = 0. ; s[1] = 0.5 ; s[2] = 0.25 ; break ; default : WrongNumFacet ; } } else { switch(NumFacet) { case 1 : s[0] = -0.25 * u * w / (1. - w) ; s[1] = 0.25 * (-2. + v + v / (1. - w)) ; s[2] = 0.25 * w ; break ; case 2 : s[0] = 0.25 * u ; s[1] = 0.25 * v ; s[2] = -0.25 * (1. - w) ; break ; case 3 : s[0] = 0.25 * (-2. + u + u / (1. - w)) ; s[1] = -0.25 * v * w / (1. - w) ; s[2] = 0.25 * w ; break ; case 4 : s[0] = 0.25 * ( 2. + u + u / (1. - w)) ; s[1] = -0.25 * v * w / (1. - w); s[2] = 0.25 * w ; break ; case 5 : s[0] = -0.25 * u * w / (1. - w) ; s[1] = 0.25 * ( 2. + v + v / (1. - w)) ; s[2] = 0.25 * w ; break ; default : WrongNumFacet ; } } break ; default : Message::Error("Unknown type of Element in BF_Facet"); break; } if (!Element->GeoElement->NumFacets) NoFace ; if (Element->GeoElement->NumFacets[NumFacet-1] < 0) { s[0] = - s[0] ; s[1] = - s[1] ; s[2] = - s[2] ; } } #undef WrongNumFacet /* ------------------------------------------------------------------------ */ /* B F _ D i v F a c e t */ /* ------------------------------------------------------------------------ */ #define WrongNumFacet Message::Error("Wrong Facet number in 'BF_DivFacet'") void BF_DivFacet(struct Element * Element, int NumFacet, double u, double v, double w, double *s) { switch (Element->Type) { case LINE : switch(NumFacet) { case 1 : *s = 0. ; break ; default : WrongNumFacet ; } break ; case TRIANGLE : switch(NumFacet) { case 1 : *s = 0. ; break ; default : WrongNumFacet ; } break ; case QUADRANGLE : switch(NumFacet) { case 1 : *s = 0. ; break ; default : WrongNumFacet ; } break ; case TETRAHEDRON : switch(NumFacet) { case 1 : *s = 6. ; break ; case 2 : *s = 6. ; break ; case 3 : *s = 6. ; break ; case 4 : *s = 6. ; break ; default : WrongNumFacet ; } break ; case HEXAHEDRON : switch(NumFacet) { case 1 : *s = 0.25 ; break ; case 2 : *s = 0.25 ; break ; case 3 : *s = 0.25 ; break ; case 4 : *s = 0.25 ; break ; case 5 : *s = 0.25 ; break ; case 6 : *s = 0.25 ; break ; default : WrongNumFacet ; } break ; case PRISM : switch(NumFacet) { case 1 : *s = 2. ; break ; case 2 : *s = 1. ; break ; case 3 : *s = 2. ; break ; case 4 : *s = 2. ; break ; case 5 : *s = 1. ; break ; default : WrongNumFacet ; } break ; case PYRAMID : if ( w == 1){ *s = 0. ; } else { switch(NumFacet) { case 1 : *s = -0.25 * w/(1. - w) + 0.25/(1. - w) + 0.5 ; break ; case 2 : *s = 0.75 ; break ; case 3 : *s = -0.25 * w/(1. - w) + 0.25/(1. - w) + 0.5 ; break ; case 4 : *s = -0.25 * w/(1. - w) + 0.25/(1. - w) + 0.5 ; break ; case 5 : *s = -0.25 * w/(1. - w) + 0.25/(1. - w) + 0.5 ; break ; default : WrongNumFacet ; } } break ; default : Message::Error("Unkown type of Element in BF_DivFacet"); break ; } if (!Element->GeoElement->NumFacets) NoFace ; if (Element->GeoElement->NumFacets[NumFacet-1] < 0) { *s = - *s ; } } #undef WrongNumFacet #undef NoFace getdp-2.4.2-source/Legacy/Operation_Update.cpp000644 001750 001750 00000033417 12166744450 022773 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include #include "ProData.h" #include "DofData.h" #include "SolvingAnalyse.h" #include "SolvingOperations.h" #include "Cal_Quantity.h" #include "Message.h" extern struct CurrentData Current ; extern int Init_Update ; #define SQU(a) ((a)*(a)) void Cal_ThetaCoefficients(double *coef) { coef[0] = 1./Current.DTime ; coef[1] = Current.Theta ; coef[2] = -1./Current.DTime ; coef[3] = 1.-Current.Theta ; } void Cal_ThetaMatrix(int *init, double *coef, gMatrix *M1, gMatrix *M2, gMatrix *A) { Message::Info("Generate Theta Iteration Matrix (Theta=%g, DTime=%g)", Current.Theta, Current.DTime) ; LinAlg_ZeroMatrix(A); // A = c0 * M2 + c1 * M1 if(init[2] && coef[0]) LinAlg_AddMatrixProdMatrixDouble(A, M2, coef[0], A) ; if(init[1] && coef[1]) LinAlg_AddMatrixProdMatrixDouble(A, M1, coef[1], A) ; } void Cal_ThetaRHS(int *init, double *coef, gMatrix *M1, gMatrix *M2, gVector *m1, gVector *m2, List_T *m1s, List_T *m2s, gVector *tmp, gVector *b, bool explicitTimeFunction) { double tfval, val ; LinAlg_ZeroVector(b) ; // b = [-c2 * M2 - c3 * M1 ] * x(n-1) if(init[2] && coef[2]){ LinAlg_ProdMatrixVector(M2, &(Current.DofData->CurrentSolution-1)->x, tmp); LinAlg_AddVectorProdVectorDouble(b, tmp, -coef[2], b) ; } if(init[1] && coef[3]){ LinAlg_ProdMatrixVector(M1, &(Current.DofData->CurrentSolution-1)->x, tmp); LinAlg_AddVectorProdVectorDouble(b, tmp, -coef[3], b) ; } if(explicitTimeFunction){ // + [ c0 * m2 + c1 * m1 ] * TimeFct(n) tfval = Current.DofData->CurrentSolution->ExplicitTimeFunctionValue ; if(init[2] && (val=coef[0]*tfval)) LinAlg_AddVectorProdVectorDouble(b, m2, val, b) ; if(init[1] && (val=coef[1]*tfval)) LinAlg_AddVectorProdVectorDouble(b, m1, val, b) ; // + [ c2 * m2 + c3 * m1 ] * TimeFct(n-1) tfval = (Current.DofData->CurrentSolution-1)->ExplicitTimeFunctionValue ; if(init[2] && (val=coef[2]*tfval)) LinAlg_AddVectorProdVectorDouble(b, m2, val, b) ; if(init[1] && (val=coef[3]*tfval)) LinAlg_AddVectorProdVectorDouble(b, m1, val, b) ; } else{ for(int i = 0; i < List_Nbr(Current.DofData->TimeFunctionIndex); i++){ gVector *mm1 = 0, *mm2 = 0; if(init[1]) mm1 = (gVector*)List_Pointer(m1s, i); if(init[2]) mm2 = (gVector*)List_Pointer(m2s, i); int tfindex; List_Read(Current.DofData->TimeFunctionIndex, i, &tfindex) ; // + [ c0 * m2 + c1 * m1 ] * TimeFct(n) tfval = Current.DofData->CurrentSolution->TimeFunctionValues[tfindex] ; if(init[2] && (val=coef[0]*tfval)) LinAlg_AddVectorProdVectorDouble(b, mm2, val, b) ; if(init[1] && (val=coef[1]*tfval)) LinAlg_AddVectorProdVectorDouble(b, mm1, val, b) ; // + [ c2 * m2 + c3 * m1 ] * TimeFct(n-1) tfval = (Current.DofData->CurrentSolution-1)->TimeFunctionValues[tfindex] ; if(init[2] && (val=coef[2]*tfval)) LinAlg_AddVectorProdVectorDouble(b, mm2, val, b) ; if(init[1] && (val=coef[3]*tfval)) LinAlg_AddVectorProdVectorDouble(b, mm1, val, b) ; } } } void Cal_NewmarkCoefficients(double *coef) { coef[0] = 1./SQU(Current.DTime) ; coef[1] = Current.Gamma/Current.DTime ; coef[2] = Current.Beta ; coef[3] = -2./SQU(Current.DTime) ; coef[4] = (1.-2.*Current.Gamma)/Current.DTime ; coef[5] = 0.5+Current.Gamma-2.*Current.Beta ; coef[6] = 1./SQU(Current.DTime) ; coef[7] = (Current.Gamma-1.)/Current.DTime ; coef[8] = 0.5-Current.Gamma+Current.Beta ; } void Cal_NewmarkMatrix(int *init, double *coef, gMatrix *M1, gMatrix *M2, gMatrix *M3, gMatrix *A) { Message::Info("Generate Newmark Iteration Matrix (Beta=%g, Gamma=%g, DTime=%g)", Current.Beta, Current.Gamma, Current.DTime) ; LinAlg_ZeroMatrix(A); // A = c0 * M3 + c1 * M2 + c2 * M3 if(init[3] && coef[0]) LinAlg_AddMatrixProdMatrixDouble(A, M3, coef[0], A); if(init[2] && coef[1]) LinAlg_AddMatrixProdMatrixDouble(A, M2, coef[1], A) ; if(init[1] && coef[2]) LinAlg_AddMatrixProdMatrixDouble(A, M1, coef[2], A) ; } void Cal_NewmarkRHS(int *init, double *coef, gMatrix *M1, gMatrix *M2, gMatrix *M3, gVector *m1, gVector *m2, gVector *m3, List_T *m1s, List_T *m2s, List_T *m3s, gVector *tmp, gVector *b, bool explicitTimeFunction) { double tfval, val ; LinAlg_ZeroVector(b) ; // b = [-c3 * M3 - c4 * M2 - c5 * M1] * x(n-1) if(init[3] && coef[3]){ LinAlg_ProdMatrixVector(M3, &(Current.DofData->CurrentSolution-1)->x, tmp); LinAlg_AddVectorProdVectorDouble(b, tmp, -coef[3], b) ; } if(init[2] && coef[4]){ LinAlg_ProdMatrixVector(M2, &(Current.DofData->CurrentSolution-1)->x, tmp); LinAlg_AddVectorProdVectorDouble(b, tmp, -coef[4], b) ; } if(init[1] && coef[5]){ LinAlg_ProdMatrixVector(M1, &(Current.DofData->CurrentSolution-1)->x, tmp); LinAlg_AddVectorProdVectorDouble(b, tmp, -coef[5], b) ; } // + [-c6 * M3 - c7 * M2 - c8 * M1] * x(n-2) if(init[3] && coef[6]){ LinAlg_ProdMatrixVector(M3, &(Current.DofData->CurrentSolution-2)->x, tmp); LinAlg_AddVectorProdVectorDouble(b, tmp, -coef[6], b) ; } if(init[2] && coef[7]){ LinAlg_ProdMatrixVector(M2, &(Current.DofData->CurrentSolution-2)->x, tmp); LinAlg_AddVectorProdVectorDouble(b, tmp, -coef[7], b) ; } if(init[1] && coef[8]){ LinAlg_ProdMatrixVector(M1, &(Current.DofData->CurrentSolution-2)->x, tmp); LinAlg_AddVectorProdVectorDouble(b, tmp, -coef[8], b) ; } if(explicitTimeFunction){ // + [ c0 * m3 + c1 * m2 + c2 * m1 ] * TimeFct(n) tfval = Current.DofData->CurrentSolution->ExplicitTimeFunctionValue ; if(init[3] && (val=coef[0]*tfval)) LinAlg_AddVectorProdVectorDouble(b, m3, val, b) ; if(init[2] && (val=coef[1]*tfval)) LinAlg_AddVectorProdVectorDouble(b, m2, val, b) ; if(init[1] && (val=coef[2]*tfval)) LinAlg_AddVectorProdVectorDouble(b, m1, val, b) ; // + [ c3 * m3 + c4 * m2 + c5 * m1 ] * TimeFct(n-1) tfval = (Current.DofData->CurrentSolution-1)->ExplicitTimeFunctionValue ; if(init[3] && (val=coef[3]*tfval)) LinAlg_AddVectorProdVectorDouble(b, m3, val, b) ; if(init[2] && (val=coef[4]*tfval)) LinAlg_AddVectorProdVectorDouble(b, m2, val, b) ; if(init[1] && (val=coef[5]*tfval)) LinAlg_AddVectorProdVectorDouble(b, m1, val, b) ; // + [ c6 * m3 + c7 * m2 + c8 * m1 ] * TimeFct(n-2) tfval = (Current.DofData->CurrentSolution-2)->ExplicitTimeFunctionValue ; if(init[3] && (val=coef[6]*tfval)) LinAlg_AddVectorProdVectorDouble(b, m3, val, b) ; if(init[2] && (val=coef[7]*tfval)) LinAlg_AddVectorProdVectorDouble(b, m2, val, b) ; if(init[1] && (val=coef[8]*tfval)) LinAlg_AddVectorProdVectorDouble(b, m1, val, b) ; } else{ for(int i = 0; i < List_Nbr(Current.DofData->TimeFunctionIndex); i++){ gVector *mm1 = 0, *mm2 = 0, *mm3 = 0; if(init[1]) mm1 = (gVector*)List_Pointer(m1s, i); if(init[2]) mm2 = (gVector*)List_Pointer(m2s, i); if(init[3]) mm3 = (gVector*)List_Pointer(m3s, i); int tfindex; List_Read(Current.DofData->TimeFunctionIndex, i, &tfindex) ; // + [ c0 * m3 + c1 * m2 + c2 * m1 ] * TimeFct(n) tfval = Current.DofData->CurrentSolution->TimeFunctionValues[tfindex] ; if(init[3] && (val=coef[0]*tfval)) LinAlg_AddVectorProdVectorDouble(b, mm3, val, b) ; if(init[2] && (val=coef[1]*tfval)) LinAlg_AddVectorProdVectorDouble(b, mm2, val, b) ; if(init[1] && (val=coef[2]*tfval)) LinAlg_AddVectorProdVectorDouble(b, mm1, val, b) ; // + [ c3 * m3 + c4 * m2 + c5 * m1 ] * TimeFct(n-1) tfval = (Current.DofData->CurrentSolution-1)->TimeFunctionValues[tfindex] ; if(init[3] && (val=coef[3]*tfval)) LinAlg_AddVectorProdVectorDouble(b, mm3, val, b) ; if(init[2] && (val=coef[4]*tfval)) LinAlg_AddVectorProdVectorDouble(b, mm2, val, b) ; if(init[1] && (val=coef[5]*tfval)) LinAlg_AddVectorProdVectorDouble(b, mm1, val, b) ; // + [ c6 * m3 + c7 * m2 + c8 * m1 ] * TimeFct(n-2) tfval = (Current.DofData->CurrentSolution-2)->TimeFunctionValues[tfindex] ; if(init[3] && (val=coef[6]*tfval)) LinAlg_AddVectorProdVectorDouble(b, mm3, val, b) ; if(init[2] && (val=coef[7]*tfval)) LinAlg_AddVectorProdVectorDouble(b, mm2, val, b) ; if(init[1] && (val=coef[8]*tfval)) LinAlg_AddVectorProdVectorDouble(b, mm1, val, b) ; } } } void Operation_Update(struct DefineSystem * DefineSystem_P, struct DofData * DofData_P, struct DofData * DofData_P0, int TimeFunctionIndex) { int i, i_TimeStep ; struct Solution * Solution_P, Solution_S ; struct Value Value ; static gVector TmpVect ; static double coef[9] ; static double Save_Num, Save_DTime, Save_Theta, Save_Beta, Save_Gamma ; if (!DofData_P->Solutions) Message::Error("No initialized solution available for update") ; i_TimeStep = (int)Current.TimeStep ; if (!(Solution_P = (struct Solution*) List_PQuery(DofData_P->Solutions, &i_TimeStep, fcmp_int))) { Solution_S.TimeStep = (int)Current.TimeStep ; Solution_S.Time = Current.Time ; Solution_S.TimeImag = Current.TimeImag ; Solution_S.TimeFunctionValues = Get_TimeFunctionValues(DofData_P); if(TimeFunctionIndex >= 0){ Get_ValueOfExpressionByIndex(TimeFunctionIndex, NULL, 0., 0., 0., &Value) ; Solution_S.ExplicitTimeFunctionValue = Value.Val[0] ; } Solution_S.SolutionExist = 1 ; LinAlg_CreateVector(&Solution_S.x, &DofData_P->Solver, DofData_P->NbrDof) ; LinAlg_ZeroVector(&Solution_S.x) ; List_Add(DofData_P->Solutions, &Solution_S) ; DofData_P->CurrentSolution = (struct Solution*) List_Pointer(DofData_P->Solutions, List_Nbr(DofData_P->Solutions)-1) ; } else if (Solution_P != DofData_P->CurrentSolution) { Message::Error("Incompatible time") ; } switch (Current.TypeTime) { case TIME_THETA : if(!DofData_P->Flag_Init[1] && !DofData_P->Flag_Init[2]) Message::Error("No system available for Update") ; if(!Init_Update){ Init_Update = 1; /* bidouillage provisoire : a revoir qd les conditions initiales multiples seront mieux traitees */ Current.Time -= Current.DTime ; Current.TimeStep -= 1. ; if(TimeFunctionIndex >= 0){ Get_ValueOfExpressionByIndex(TimeFunctionIndex, NULL, 0., 0., 0., &Value) ; (DofData_P->CurrentSolution-1)->ExplicitTimeFunctionValue = Value.Val[0] ; } Current.Time += Current.DTime ; Current.TimeStep += 1. ; /* */ LinAlg_CreateVector(&TmpVect, &DofData_P->Solver, DofData_P->NbrDof) ; Save_Num = DofData_P->Num ; Save_DTime = Current.DTime ; Save_Theta = Current.Theta ; Cal_ThetaCoefficients(coef) ; Cal_ThetaMatrix(DofData_P->Flag_Init, coef, &DofData_P->M1, &DofData_P->M2, &DofData_P->A) ; LinAlg_AssembleMatrix(&DofData_P->A) ; } if(Save_Num != DofData_P->Num || Current.DTime != Save_DTime || Current.Theta != Save_Theta){ Save_Num = DofData_P->Num ; Save_DTime = Current.DTime ; Save_Theta = Current.Theta ; Cal_ThetaCoefficients(coef) ; Cal_ThetaMatrix(DofData_P->Flag_Init, coef, &DofData_P->M1, &DofData_P->M2, &DofData_P->A) ; LinAlg_AssembleMatrix(&DofData_P->A) ; } Cal_ThetaRHS(DofData_P->Flag_Init, coef, &DofData_P->M1, &DofData_P->M2, &DofData_P->m1, &DofData_P->m2, DofData_P->m1s, DofData_P->m2s, &TmpVect, &DofData_P->b, (TimeFunctionIndex >= 0)); LinAlg_AssembleVector(&DofData_P->b) ; break ; case TIME_NEWMARK : if(!DofData_P->Flag_Init[1] && !DofData_P->Flag_Init[2] && !DofData_P->Flag_Init[3]) Message::Error("No system available for Update") ; if(!Init_Update){ Init_Update = 1; /* bidouillage provisoire : a revoir qd les conditions initiales multiples seront mieux traitees */ Current.Time -= Current.DTime ; Current.TimeStep -= 1. ; if(TimeFunctionIndex >= 0){ Get_ValueOfExpressionByIndex(TimeFunctionIndex, NULL, 0., 0., 0., &Value) ; (DofData_P->CurrentSolution-1)->ExplicitTimeFunctionValue = Value.Val[0] ; (DofData_P->CurrentSolution-2)->ExplicitTimeFunctionValue = Value.Val[0] ; } Current.Time += Current.DTime ; Current.TimeStep += 1. ; /* */ LinAlg_CreateVector(&TmpVect, &DofData_P->Solver, DofData_P->NbrDof) ; Save_Num = DofData_P->Num ; Save_DTime = Current.DTime ; Save_Beta = Current.Beta ; Save_Gamma = Current.Gamma ; Cal_NewmarkCoefficients(coef) ; Cal_NewmarkMatrix(DofData_P->Flag_Init, coef, &DofData_P->M1, &DofData_P->M2, &DofData_P->M3, &DofData_P->A) ; LinAlg_AssembleMatrix(&DofData_P->A) ; } if(Save_Num != DofData_P->Num || Current.DTime != Save_DTime || Current.Beta != Save_Beta || Current.Gamma != Save_Gamma){ Save_Num = DofData_P->Num ; Save_DTime = Current.DTime ; Save_Beta = Current.Beta ; Save_Gamma = Current.Gamma ; Cal_NewmarkCoefficients(coef) ; Cal_NewmarkMatrix(DofData_P->Flag_Init, coef, &DofData_P->M1, &DofData_P->M2, &DofData_P->M3, &DofData_P->A) ; LinAlg_AssembleMatrix(&DofData_P->A) ; } Cal_NewmarkRHS(DofData_P->Flag_Init, coef, &DofData_P->M1, &DofData_P->M2, &DofData_P->M3, &DofData_P->m1, &DofData_P->m2, &DofData_P->m3, DofData_P->m1s, DofData_P->m2s, DofData_P->m3s, &TmpVect, &DofData_P->b, (TimeFunctionIndex >= 0)); LinAlg_AssembleVector(&DofData_P->b) ; break ; default : Message::Error("Wrong type of analysis for update") ; } LinAlg_GetVectorSize(&DofData_P->b, &i) ; if(!i) Message::Error("Generated system is of dimension zero"); Free_UnusedSolutions(DofData_P); } getdp-2.4.2-source/Legacy/GetDP.h000644 001750 001750 00000000523 12142254330 020114 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _GETDP_H_ #define _GETDP_H_ #include #include int GetDP(std::vector &args, void *ptr=NULL); #endif getdp-2.4.2-source/Legacy/Pos_Search.h000644 001750 001750 00000001623 12116424202 021177 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _POS_SEARCH_H_ #define _POS_SEARCH_H_ #include "ProData.h" #include "ListUtils.h" struct Brick { List_T *p[3]; } ; struct ElementBox { double Xmin, Xmax ; double Ymin, Ymax ; double Zmin, Zmax ; } ; struct PointElement { double d; double xp, yp, zp; int ElementIndex; } ; void Init_SearchGrid(struct Grid * Grid); void Free_SearchGrid(struct Grid * Grid); void InWhichElement(struct Grid Grid, List_T *ExcludeRegion, struct Element * Element, int Flag, double x, double y, double z, double *u, double *v, double *w); void xyz2uvwInAnElement(struct Element *Element, double x, double y, double z, double *u, double *v, double *w); #endif getdp-2.4.2-source/Legacy/LinAlg_SPARSKIT.cpp000644 001750 001750 00000031764 12116424202 022203 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Ruth Sabariego // #include #include #include "GetDPConfig.h" #include "LinAlg.h" #include "ProData.h" #include "DofData.h" #include "MallocUtils.h" #include "Message.h" extern struct CurrentData Current ; extern char *Name_Path; #if defined(HAVE_SPARSKIT) static const char *Name_SolverFile = NULL, *Name_DefaultSolverFile = "solver.par" ; static char *SolverOptions[100]; void LinAlg_InitializeSolver(int* sargc, char*** sargv) { int i=1, argc, iopt=0; char **argv; argc = *sargc ; argv = *sargv ; SolverOptions[0] = NULL; while (i < argc) { if (argv[i][0] == '-') { if (!strcmp(argv[i]+1, "solver") || !strcmp(argv[i]+1, "s")) { i++ ; if (i absolute if it starts with '/' or '\' strcpy(FileName, SolverDataFileName); } else{ // -> relative otherwise strcat(FileName, SolverDataFileName); } } else if (Name_SolverFile){ // name on command line -> always absolute strcpy(FileName, Name_SolverFile); } else{ // default file name -> always relative strcat(FileName, Name_DefaultSolverFile); } Message::Info("Loading parameter file '%s'", FileName); init_solver(&Solver->Params, FileName) ; i = 0; while(SolverOptions[i] && SolverOptions[i+1]){ init_solver_option(&Solver->Params, SolverOptions[i], SolverOptions[i+1]) ; i+=2; } } void LinAlg_CreateVector(gVector *V, gSolver *Solver, int n) { init_vector(n, &V->V) ; V->N = n ; } void LinAlg_CreateMatrix(gMatrix *M, gSolver *Solver, int n, int m) { init_matrix(n, &M->M, &Solver->Params) ; } void LinAlg_DestroySolver(gSolver *Solver) { Message::Debug("'LinAlg_DestroySolver' not yet implemented"); } void LinAlg_DestroyVector(gVector *V) { Free(V->V); } void LinAlg_DestroyMatrix(gMatrix *M) { free_matrix(&M->M) ; } void LinAlg_CopyScalar(gScalar *S1, gScalar *S2) { S2->s = S1->s ; } void LinAlg_CopyVector(gVector *V1, gVector *V2) { memcpy(V2->V, V1->V, V1->N*sizeof(double)) ; } void LinAlg_CopyMatrix(gMatrix *M1, gMatrix *M2) { Message::Error("'LinAlg_CopyMatrix' not yet implemented"); } void LinAlg_ZeroScalar(gScalar *S) { S->s = 0. ; } void LinAlg_ZeroVector(gVector *V) { zero_vector(V->N, V->V) ; } void LinAlg_ZeroMatrix(gMatrix *M) { int i ; zero_matrix(&M->M) ; // la routine de produit matrice vecteur est buggee s'il existe des // lignes sans aucun element dans la matrice... for(i=0 ; iM.N ; i++) add_matrix_double(&M->M, i+1, i+1, 0.0) ; } void LinAlg_ScanScalar(FILE *file, gScalar *S) { fscanf(file, "%lf", &S->s) ; } void LinAlg_ScanVector(FILE *file, gVector *V) { int i ; for(i=0 ; iN ; i++) fscanf(file, "%lf", &V->V[i]) ; } void LinAlg_ScanMatrix(FILE *file, gMatrix *M) { Message::Error("'LinAlg_ScanMatrix' not yet implemented"); } void LinAlg_ReadScalar(FILE *file, gScalar *S) { Message::Error("'LinAlg_ReadScalar' not yet implemented"); } void LinAlg_ReadVector(FILE *file, gVector *V) { fread(V->V, sizeof(double), V->N, file); } void LinAlg_ReadMatrix(FILE *file, gMatrix *M) { Message::Error("'LinAlg_ReadMatrix' not yet implemented"); } void LinAlg_PrintScalar(FILE *file, gScalar *S) { fprintf(file, "%.16g", S->s) ; } void LinAlg_PrintVector(FILE *file, gVector *V, bool matlab, const char* fileName, const char* varName) { if(matlab) Message::Error("Matlab output not available for this vector"); formatted_write_vector(file, V->N, V->V, KUL) ; } void LinAlg_PrintMatrix(FILE *file, gMatrix *M, bool matlab, const char* fileName, const char* varName) { if(matlab) Message::Error("Matlab output not available for this matrix"); formatted_write_matrix(file, &M->M, KUL) ; } void LinAlg_WriteScalar(FILE *file, gScalar *S) { Message::Error("'LinAlg_WriteScalar' not yet implemented"); } void LinAlg_WriteVector(FILE *file, gVector *V) { fwrite(V->V, sizeof(double), V->N, file); fprintf(file, "\n"); } void LinAlg_WriteMatrix(FILE *file, gMatrix *M) { binary_write_matrix(&M->M, "A", ".mat") ; } void LinAlg_GetVectorSize(gVector *V, int *i) { *i = V->N ; } void LinAlg_GetLocalVectorRange(gVector *V, int *low, int *high) { *low = 0 ; *high = V->N ; } void LinAlg_GetMatrixSize(gMatrix *M, int *i, int *j) { *i = *j = M->M.N ; } void LinAlg_GetLocalMatrixRange(gMatrix *M, int *low, int *high) { *low = 0 ; *high = M->M.N ; } void LinAlg_GetDoubleInScalar(double *d, gScalar *S) { *d = S->s ; } void LinAlg_GetComplexInScalar(double *d1, double *d2, gScalar *S) { Message::Error("'LinAlg_GetComplexInScalar' not available with this Solver"); } void LinAlg_GetScalarInVector(gScalar *S, gVector *V, int i) { S->s = V->V[i] ; } void LinAlg_GetDoubleInVector(double *d, gVector *V, int i) { *d = V->V[i] ; } void LinAlg_GetAbsDoubleInVector(double *d, gVector *V, int i) { *d = fabs(V->V[i]) ; } void LinAlg_GetComplexInVector(double *d1, double *d2, gVector *V, int i, int j) { *d1 = V->V[i] ; *d2 = V->V[j] ; } void LinAlg_GetScalarInMatrix(gScalar *S, gMatrix *M, int i, int j) { Message::Error("'LinAlg_GetScalarInMatrix' not yet implemented"); } void LinAlg_GetDoubleInMatrix(double *d, gMatrix *M, int i, int j) { get_element_in_matrix(&M->M, i, j, d); } void LinAlg_GetComplexInMatrix(double *d1, double *d2, gMatrix *M, int i, int j, int k, int l) { Message::Error("'LinAlg_GetScalarInMatrix' not yet implemented"); } void LinAlg_GetColumnInMatrix(gMatrix *M, int col, gVector *V1) { get_column_in_matrix(&M->M, col, V1->V); } void LinAlg_SetScalar(gScalar *S, double *d) { S->s = d[0] ; } void LinAlg_SetVector(gVector *V, double *v) { int i; for(i=0; iN; i++) V->V[i] = *v ; } void LinAlg_SetScalarInVector(gScalar *S, gVector *V, int i) { V->V[i] = S->s ; } void LinAlg_SetDoubleInVector(double d, gVector *V, int i) { V->V[i] = d ; } void LinAlg_SetComplexInVector(double d1, double d2, gVector *V, int i, int j) { V->V[i] = d1 ; V->V[j] = d2 ; } void LinAlg_SetScalarInMatrix(gScalar *S, gMatrix *M, int i, int j) { Message::Error("'LinAlg_SetScalarInMatrix' not yet implemented"); } void LinAlg_SetDoubleInMatrix(double d, gMatrix *M, int i, int j) { Message::Error("'LinAlg_SetScalarInMatrix' not yet implemented"); } void LinAlg_SetComplexInMatrix(double d1, double d2, gMatrix *M, int i, int j, int k, int l) { Message::Error("'LinAlg_SetScalarInMatrix' not yet implemented"); } void LinAlg_AddScalarScalar(gScalar *S1, gScalar *S2, gScalar *S3) { S3->s = S1->s + S2->s ; } void LinAlg_DummyVector(gVector *V) { int * DummyDof, i; DummyDof = Current.DofData->DummyDof; if (DummyDof == NULL) return ; for (i=0 ; iN ; i++) if (DummyDof[i] == 1) V->V[i] = 0 ; } void LinAlg_AddScalarInVector(gScalar *S, gVector *V, int i) { int * DummyDof; if ((DummyDof = Current.DofData->DummyDof)) if (DummyDof[i] == 1) return ; V->V[i] += S->s ; } void LinAlg_AddDoubleInVector(double d, gVector *V, int i) { int * DummyDof; if ((DummyDof = Current.DofData->DummyDof)) if (DummyDof[i] == 1) return ; V->V[i] += d ; } void LinAlg_AddComplexInVector(double d1, double d2, gVector *V, int i, int j) { int * DummyDof, iok,jok; iok=jok=1; if ((DummyDof = Current.DofData->DummyDof)) { if (DummyDof[i] == 1) iok=0; if (DummyDof[j] == 1) jok=0; } if (iok) V->V[i] += d1 ; if (jok) V->V[j] += d2 ; } void LinAlg_AddScalarInMatrix(gScalar *S, gMatrix *M, int i, int j) { add_matrix_double(&M->M, i+1, j+1, S->s) ; } void LinAlg_AddDoubleInMatrix(double d, gMatrix *M, int i, int j) { int * DummyDof; if ((DummyDof = Current.DofData->DummyDof)) if ( (DummyDof[i] == 1 || DummyDof[j] == 1) && (i != j) ) return ; add_matrix_double(&M->M, i+1, j+1, d) ; } void LinAlg_AddComplexInMatrix(double d1, double d2, gMatrix *M, int i, int j, int k, int l) { if(d1){ add_matrix_double(&M->M, i+1, j+1, d1) ; add_matrix_double(&M->M, k+1, l+1, d1) ; } if(d2){ add_matrix_double(&M->M, i+1, l+1, -d2) ; add_matrix_double(&M->M, k+1, j+1, d2) ; } } void LinAlg_AddVectorVector(gVector *V1, gVector *V2, gVector *V3) { if(V3 == V1) add_vector_vector(V1->N, V1->V, V2->V) ; else Message::Error("Wrong arguments in 'LinAlg_AddVectorVector'"); } void LinAlg_AddVectorProdVectorDouble(gVector *V1, gVector *V2, double d, gVector *V3) { if(V3 == V1) add_vector_prod_vector_double(V1->N, V1->V, V2->V, d) ; else Message::Error("Wrong arguments in 'LinAlg_AddVectorProdVectorDouble'"); } void LinAlg_AddMatrixMatrix(gMatrix *M1, gMatrix *M2, gMatrix *M3) { if(M3 == M1) add_matrix_matrix(&M1->M, &M2->M) ; else Message::Error("Wrong arguments in 'LinAlg_AddMatrixMatrix'"); } void LinAlg_AddMatrixProdMatrixDouble(gMatrix *M1, gMatrix *M2, double d, gMatrix *M3) { if(M3 == M1) add_matrix_prod_matrix_double(&M1->M, &M2->M, d) ; else Message::Error("Wrong arguments in 'LinAlg_AddMatrixProdMatrixDouble'"); } void LinAlg_SubScalarScalar(gScalar *S1, gScalar *S2, gScalar *S3) { S3->s = S1->s - S2->s ; } void LinAlg_SubVectorVector(gVector *V1, gVector *V2, gVector *V3) { if(V3 == V1) sub_vector_vector_1(V1->N, V1->V, V2->V) ; else if (V3 == V2) sub_vector_vector_2(V1->N, V1->V, V2->V) ; else Message::Error("Wrong arguments in 'LinAlg_SubVectorVector'"); } void LinAlg_SubMatrixMatrix(gMatrix *M1, gMatrix *M2, gMatrix *M3) { Message::Error("'LinAlg_SubMatrixMatrix' not yet implemented"); } void LinAlg_ProdScalarScalar(gScalar *S1, gScalar *S2, gScalar *S3) { S3->s = S1->s * S2->s ; } void LinAlg_ProdScalarDouble(gScalar *S1, double d, gScalar *S2) { S2->s = S1->s * d ; } void LinAlg_ProdScalarComplex(gScalar *S, double d1, double d2, double *d3, double *d4) { *d3 = S->s * d1 ; *d4 = S->s * d2 ; } void LinAlg_ProdVectorScalar(gVector *V1, gScalar *S, gVector *V2) { Message::Error("'LinAlg_ProdVectorScalar' not yet implemented"); } void LinAlg_ProdVectorDouble(gVector *V1, double d, gVector *V2) { if(V2 == V1) prod_vector_double(V1->N, V1->V, d); else Message::Error("Wrong arguments in 'LinAlg_ProdVectorDouble'"); } void LinAlg_ProdVectorComplex(gVector *V1, double d1, double d2, gVector *V2) { Message::Error("'LinAlg_ProdVectorComplex' not yet implemented"); } void LinAlg_ProdVectorVector(gVector *V1, gVector *V2, double *d) { prodsc_vector_vector (V1->N, V1->V, V2->V, d) ; } void LinAlg_ProdMatrixVector(gMatrix *M, gVector *V1, gVector *V2) { if(V2 == V1) Message::Error("Wrong arguments in 'LinAlg_ProdMatrixVector'"); else prod_matrix_vector(&M->M, V1->V, V2->V); } void LinAlg_ProdMatrixScalar(gMatrix *M1, gScalar *S, gMatrix *M2) { if(M2 == M1) prod_matrix_double (&M1->M, S->s); else Message::Error("Wrong arguments in 'LinAlg_ProdMatrixScalar'"); } void LinAlg_ProdMatrixDouble(gMatrix *M1, double d, gMatrix *M2) { if(M2 == M1) prod_matrix_double (&M1->M, d); else Message::Error("Wrong arguments in 'LinAlg_ProdMatrixDouble'"); } void LinAlg_ProdMatrixComplex(gMatrix *M1, double d1, double d2, gMatrix *M2) { Message::Error("'LinAlg_ProdMatrixComplex' not yet implemented"); } void LinAlg_DivScalarScalar(gScalar *S1, gScalar *S2, gScalar *S3) { S3->s = S1->s / S2->s ; } void LinAlg_DivScalarDouble(gScalar *S1, double d, gScalar *S2) { S2->s = S1->s / d ; } void LinAlg_VectorNorm2(gVector *V1, double *norm) { norm2_vector(V1->N, V1->V, norm); } void LinAlg_VectorNormInf(gVector *V1, double *norm) { norminf_vector(V1->N, V1->V, norm); } void LinAlg_AssembleMatrix(gMatrix *M) { } void LinAlg_AssembleVector(gVector *V) { } void LinAlg_Solve(gMatrix *A, gVector *B, gSolver *Solver, gVector *X, int solverIndex) { solve_matrix(&A->M, &Solver->Params, B->V, X->V); } void LinAlg_SolveAgain(gMatrix *A, gVector *B, gSolver *Solver, gVector *X, int solverIndex) { int tmp = Solver->Params.Re_Use_LU; Solver->Params.Re_Use_LU = 1; solve_matrix(&A->M, &Solver->Params, B->V, X->V); Solver->Params.Re_Use_LU = tmp; } void LinAlg_SolveNL(gMatrix *A, gVector *B, gMatrix *J, gVector *R, gSolver *Solver, gVector *X, int solverIndex) { Message::Error("'LinAlg_SolveNL' not yet implemented for Sparskit"); } #endif getdp-2.4.2-source/Legacy/SolvingOperations.cpp000644 001750 001750 00000300051 12221300353 023163 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Johan Gyselinck // Ruth Sabariego // #include #include #include "GetDPConfig.h" #include "ProData.h" #include "ProDefine.h" #include "GeoData.h" #include "DofData.h" #include "Cal_Quantity.h" #include "Cal_Value.h" #include "MovingBand2D.h" #include "EigenSolve.h" #include "Treatment_Formulation.h" #include "SolvingAnalyse.h" #include "SolvingOperations.h" #include "MallocUtils.h" #include "OS.h" #include "Message.h" #if defined(HAVE_GMSH) #include #include #endif #define TWO_PI 6.2831853071795865 // for performance tests #if !defined(WIN32) //#define TIMER #endif extern struct Problem Problem_S ; extern struct CurrentData Current ; extern int TreatmentStatus ; extern int Flag_POS ; extern int Flag_RESTART ; extern int Flag_BIN, Flag_SPLIT ; extern char *Name_Generic, *Name_Path ; extern char *Name_MshFile, *Name_ResFile[NBR_MAX_RES] ; extern List_T *GeoData_L ; static int Flag_IterativeLoop = 0 ; /* Attention: phase de test */ struct Group * Generate_Group = NULL; static int Flag_Break = 0; // For adaptive time stepper (ugly, I know...) int Flag_IterativeLoopConverged = 1; int Flag_IterativeLoopN = 0; // For IterativeTimeReduction (ugly also...) int Flag_NextThetaFixed = 0 ; // For Update int Init_Update = 0 ; // For Johan's multi-harmonic stiff (even uglier :-) int Flag_RHS = 0, *DummyDof ; double **MH_Moving_Matrix = NULL ; int MH_Moving_Matrix_simple = 0 ; int MH_Moving_Matrix_probe = 0 ; int MH_Moving_Matrix_separate = 0; Tree_T * DofTree_MH_moving ; /* ------------------------------------------------------------------------ */ /* F r e e _ U n u s e d S o l u t i o n s */ /* ------------------------------------------------------------------------ */ void Free_UnusedSolutions(struct DofData * DofData_P) { struct Solution * Solution_P ; int index = -1; // We store 1 solution too much (to allow for an imbricated iterative loop) if(!Flag_POS){ switch (Current.TypeTime) { case TIME_THETA : index = List_Nbr(DofData_P->Solutions)-4 ; // Fore TimeLoopAdaptive (Trapezoidal) we need 3 past solutions for the predictor index = Message::GetOperatingInTimeLoopAdaptive() ? index - 1 : index; break; case TIME_GEAR : // With -9 we store 7 past solutions (for Gear_6) index = List_Nbr(DofData_P->Solutions)-9 ; break; case TIME_NEWMARK : index = List_Nbr(DofData_P->Solutions)-4 ; break; } if(index >= 0){ Solution_P = (struct Solution*)List_Pointer(DofData_P->Solutions, index); if(Solution_P->SolutionExist){ Message::Info("Freeing Solution %d", index); LinAlg_DestroyVector(&Solution_P->x); Free(Solution_P->TimeFunctionValues) ; Solution_P->SolutionExist = 0 ; } } } } /* ------------------------------------------------------------------------ */ /* I n i t _ S y s t e m D a t a */ /* ------------------------------------------------------------------------ */ void Init_SystemData(struct DofData * DofData_P, int Flag_Jac) { if (DofData_P->Flag_Init[0] < 1) { DofData_P->Flag_Init[0] = 1 ; LinAlg_CreateSolver(&DofData_P->Solver, DofData_P->SolverDataFileName) ; LinAlg_CreateMatrix(&DofData_P->A, &DofData_P->Solver, DofData_P->NbrDof, DofData_P->NbrDof) ; LinAlg_CreateVector(&DofData_P->b, &DofData_P->Solver, DofData_P->NbrDof) ; } /* GenerateOnly: Taking advantage of the invariant parts of the matrix in every time-step */ if(DofData_P->Flag_InitOnly[0]==1){ DofData_P->Flag_InitOnly[0] = 2; Message::Info("Initializing System {A1,b1}"); LinAlg_CreateMatrix(&DofData_P->A1, &DofData_P->Solver, DofData_P->NbrDof, DofData_P->NbrDof) ; LinAlg_CreateVector(&DofData_P->b1, &DofData_P->Solver, DofData_P->NbrDof) ; } if(DofData_P->Flag_InitOnly[1]==1){ DofData_P->Flag_InitOnly[1] = 2; Message::Info("Initializing System {A2,b2}"); LinAlg_CreateMatrix(&DofData_P->A2, &DofData_P->Solver, DofData_P->NbrDof, DofData_P->NbrDof) ; LinAlg_CreateVector(&DofData_P->b2, &DofData_P->Solver, DofData_P->NbrDof) ; } if(DofData_P->Flag_InitOnly[2]==1){ DofData_P->Flag_InitOnly[2] = 2; Message::Info("Initializing System {A3,b3}"); LinAlg_CreateMatrix(&DofData_P->A3, &DofData_P->Solver, DofData_P->NbrDof, DofData_P->NbrDof) ; LinAlg_CreateVector(&DofData_P->b3, &DofData_P->Solver, DofData_P->NbrDof) ; } if (DofData_P->Flag_Init[0] < 2 && Flag_Jac) { DofData_P->Flag_Init[0] = 2 ; LinAlg_CreateMatrix(&DofData_P->Jac, &DofData_P->Solver, DofData_P->NbrDof, DofData_P->NbrDof) ; LinAlg_CreateVector(&DofData_P->res, &DofData_P->Solver, DofData_P->NbrDof) ; LinAlg_CreateVector(&DofData_P->dx, &DofData_P->Solver, DofData_P->NbrDof) ; } } /* ------------------------------------------------------------------------ */ /* G e n e r a t e _ S y s t e m */ /* ------------------------------------------------------------------------ */ static void ZeroMatrix(gMatrix *M, gSolver *S, int N) { // We destroy and recreate the matrix to avoid filling-in the mask when // generating systems on meshes with changing topologies (remeshing, moving // band, ..., e.g. in time loops) or when constraints are updated. Using // LinAlg_ZeroMatrix preserves the mask from iteration to iteration, which // increases memory every time we reassemble. LinAlg_DestroyMatrix(M); LinAlg_CreateMatrix(M, S, N, N); } void Generate_System(struct DefineSystem * DefineSystem_P, struct DofData * DofData_P, struct DofData * DofData_P0, int Flag_Jac, int Flag_Separate) { int i, Nbr_Formulation, Index_Formulation, i_TimeStep, iMat ; struct Solution * Solution_P, Solution_S ; struct Formulation * Formulation_P ; /* (Re)creation des liens entre FunctionSpace et DofData: seuls les FS n'intervenant pas dans le DD courant peuvent pointer vers un autre DD */ Init_DofDataInFunctionSpace(1, DofData_P) ; if (!DofData_P->Solutions) DofData_P->Solutions = List_Create(20, 20, sizeof(struct Solution)) ; i_TimeStep = (int)Current.TimeStep ; if (!(Solution_P = (struct Solution*) List_PQuery(DofData_P->Solutions, &i_TimeStep, fcmp_int))) { Solution_S.TimeStep = (int)Current.TimeStep ; Solution_S.Time = Current.Time ; Solution_S.TimeImag = Current.TimeImag ; Solution_S.TimeFunctionValues = Get_TimeFunctionValues(DofData_P) ; Solution_S.SolutionExist = 1 ; LinAlg_CreateVector(&Solution_S.x, &DofData_P->Solver, DofData_P->NbrDof) ; if (List_Nbr(DofData_P->Solutions)) { LinAlg_CopyVector(&((struct Solution *) List_Pointer(DofData_P->Solutions, List_Nbr(DofData_P->Solutions)-1))->x, &Solution_S.x) ; } else { LinAlg_ZeroVector(&Solution_S.x) ; } List_Add(DofData_P->Solutions, &Solution_S) ; DofData_P->CurrentSolution = (struct Solution*) List_Pointer(DofData_P->Solutions, List_Nbr(DofData_P->Solutions)-1) ; } else if (Solution_P != DofData_P->CurrentSolution && !Flag_Separate) { /* the test on Flag_Separate is necessary for high order time schemes, where InitSolution[] gets called multiple times, resulting in multiple stored solutions with the same TimeStep number. Since GenerateSeparate[] is called outside the time loop (i.e. before TimeStep+=1), the List_PQuery may return (in an unpredictable way) any of the initial solutions. */ Message::Error("Incompatible time") ; } else{ // fix time values if we recompute the same step (with different time) Solution_P->Time = Current.Time ; Solution_P->TimeImag = Current.TimeImag ; Free(Solution_P->TimeFunctionValues) ; Solution_P->TimeFunctionValues = Get_TimeFunctionValues(DofData_P) ; } if(Flag_Separate){ for(i=0 ; iTimeFunctionIndex) ; i++) if(*(int*)List_Pointer(DofData_P->TimeFunctionIndex, i) > 0) Message::Warning("Ignored TimeFunction in Constraint for GenerateSeparate") ; for(i=0 ; iCurrentSolution->TimeFunctionValues[i] = 1. ; } if(Current.DofData->Flag_Init[1]){ ZeroMatrix(&Current.DofData->M1, &Current.DofData->Solver, Current.DofData->NbrDof) ; LinAlg_ZeroVector(&Current.DofData->m1); for(int i = 0; i < List_Nbr(DofData_P->m1s); i++) LinAlg_ZeroVector((gVector*)List_Pointer(DofData_P->m1s, i)); } if(Current.DofData->Flag_Init[2]){ ZeroMatrix(&Current.DofData->M2, &Current.DofData->Solver, Current.DofData->NbrDof) ; LinAlg_ZeroVector(&Current.DofData->m2); for(int i = 0; i < List_Nbr(DofData_P->m2s); i++) LinAlg_ZeroVector((gVector*)List_Pointer(DofData_P->m2s, i)); } if(Current.DofData->Flag_Init[3]){ ZeroMatrix(&Current.DofData->M3, &Current.DofData->Solver, Current.DofData->NbrDof) ; LinAlg_ZeroVector(&Current.DofData->m3); for(int i = 0; i < List_Nbr(DofData_P->m3s); i++) LinAlg_ZeroVector((gVector*)List_Pointer(DofData_P->m3s, i)); } } else{ if(!Current.DofData->Flag_RHS){ ZeroMatrix(&Current.DofData->A, &Current.DofData->Solver, Current.DofData->NbrDof); } LinAlg_ZeroVector(&Current.DofData->b) ; if(DofData_P->Flag_Only){ for(i = 0 ; i < List_Nbr( DofData_P->OnlyTheseMatrices ); i++){ List_Read(DofData_P->OnlyTheseMatrices, i, &iMat); if(iMat){ // Message::Info("Setting System {A%d,b%d} to zero",iMat,iMat); switch(iMat){ case 1 : ZeroMatrix(&Current.DofData->A1, &Current.DofData->Solver, Current.DofData->NbrDof) ; LinAlg_ZeroVector(&Current.DofData->b1) ; break; case 2 : ZeroMatrix(&Current.DofData->A2, &Current.DofData->Solver, Current.DofData->NbrDof) ; LinAlg_ZeroVector(&Current.DofData->b2) ; break; case 3 : ZeroMatrix(&Current.DofData->A3, &Current.DofData->Solver, Current.DofData->NbrDof) ; LinAlg_ZeroVector(&Current.DofData->b3) ; break; } } } } } if(Flag_Jac) ZeroMatrix(&Current.DofData->Jac, &Current.DofData->Solver, Current.DofData->NbrDof) ; Nbr_Formulation = List_Nbr(DefineSystem_P->FormulationIndex) ; for (i = 0 ; i < Nbr_Formulation ; i++) { List_Read(DefineSystem_P->FormulationIndex, i, &Index_Formulation) ; Formulation_P = (struct Formulation*) List_Pointer(Problem_S.Formulation, Index_Formulation) ; Init_DofDataInDefineQuantity(DefineSystem_P, DofData_P0, Formulation_P); Treatment_Formulation(Formulation_P) ; } if(Flag_Separate){ DofData_P->CurrentSolution->TimeFunctionValues = Get_TimeFunctionValues(DofData_P) ; if(DofData_P->Flag_Init[1]){ LinAlg_AssembleMatrix(&DofData_P->M1) ; LinAlg_AssembleVector(&DofData_P->m1) ; for(int i = 0; i < List_Nbr(DofData_P->m1s); i++) LinAlg_AssembleVector((gVector*)List_Pointer(DofData_P->m1s, i)); } if(DofData_P->Flag_Init[2]){ LinAlg_AssembleMatrix(&DofData_P->M2) ; LinAlg_AssembleVector(&DofData_P->m2) ; for(int i = 0; i < List_Nbr(DofData_P->m2s); i++) LinAlg_AssembleVector((gVector*)List_Pointer(DofData_P->m2s, i)); } if(DofData_P->Flag_Init[3]){ LinAlg_AssembleMatrix(&DofData_P->M3) ; LinAlg_AssembleVector(&DofData_P->m3) ; for(int i = 0; i < List_Nbr(DofData_P->m3s); i++) LinAlg_AssembleVector((gVector*)List_Pointer(DofData_P->m3s, i)); } } else{ LinAlg_AssembleMatrix(&DofData_P->A) ; LinAlg_AssembleVector(&DofData_P->b) ; LinAlg_GetVectorSize(&DofData_P->b, &i) ; if(!i) Message::Warning("Generated system is of dimension zero"); if(DofData_P->Flag_Only){ for(i = 0 ; i < List_Nbr( DofData_P->OnlyTheseMatrices ); i++){ List_Read(DofData_P->OnlyTheseMatrices, i, &iMat); switch(iMat){ case 1 : LinAlg_AssembleMatrix(&Current.DofData->A1) ; LinAlg_AssembleVector(&Current.DofData->b1) ; break; case 2 : LinAlg_AssembleMatrix(&Current.DofData->A2) ; LinAlg_AssembleVector(&Current.DofData->b2) ; break; case 3: LinAlg_AssembleMatrix(&Current.DofData->A3) ; LinAlg_AssembleVector(&Current.DofData->b3) ; break; } } } } if(Flag_Jac){ /* This should in fact only be done if a JacNL term exists in the formulation... */ LinAlg_AssembleMatrix(&DofData_P->Jac) ; } Free_UnusedSolutions(DofData_P); } void ReGenerate_System(struct DefineSystem * DefineSystem_P, struct DofData * DofData_P, struct DofData * DofData_P0, int Flag_Jac=0) { int i, Nbr_Formulation, Index_Formulation ; struct Formulation * Formulation_P ; LinAlg_ZeroMatrix(&Current.DofData->A) ; LinAlg_ZeroVector(&Current.DofData->b) ; if(Flag_Jac) LinAlg_ZeroMatrix(&Current.DofData->Jac) ; Nbr_Formulation = List_Nbr(DefineSystem_P->FormulationIndex) ; for (i = 0 ; i < Nbr_Formulation ; i++) { List_Read(DefineSystem_P->FormulationIndex, i, &Index_Formulation) ; Formulation_P = (struct Formulation*) List_Pointer(Problem_S.Formulation, Index_Formulation) ; Init_DofDataInDefineQuantity(DefineSystem_P, DofData_P0, Formulation_P); Treatment_Formulation(Formulation_P) ; } LinAlg_AssembleMatrix(&DofData_P->A) ; LinAlg_AssembleVector(&DofData_P->b) ; LinAlg_GetVectorSize(&DofData_P->b, &i) ; if(!i) Message::Warning("ReGenerated system is of dimension zero"); if(Flag_Jac){ /* This should in fact only be done if a JacNL term exists in the formulation... */ LinAlg_AssembleMatrix(&DofData_P->Jac) ; } } void Generate_Residual(gVector *x, gVector *f) { struct DefineSystem * DefineSystem_P ; struct DofData * DofData_P ; struct DofData * DofData_P0 ; int Flag_Jac = 1 ; if(Message::GetVerbosity() == 10) Message::Info("Generating Residual = b(xn)-A(xn)*xn"); DofData_P = Current.DofData ; DofData_P0 = Current.DofData_P0; DefineSystem_P = Current.DefineSystem_P ; // new trial solution LinAlg_CopyVector(x, &DofData_P->dx); LinAlg_AddVectorProdVectorDouble(&DofData_P->CurrentSolution->x, &DofData_P->dx, -1., &DofData_P->CurrentSolution->x); // calculate residual with new solution ReGenerate_System(DefineSystem_P, DofData_P, DofData_P0, Flag_Jac) ; // calculate residual with new solution LinAlg_ProdMatrixVector(&DofData_P->A, &DofData_P->CurrentSolution->x, &DofData_P->res) ; // res = b(xn)-A(xn)*xn LinAlg_SubVectorVector(&DofData_P->b, &DofData_P->res, &DofData_P->res) ; if(Message::GetVerbosity() == 10){ Message::Info("dx"); LinAlg_PrintVector(stdout, &DofData_P->dx) ; Message::Info("A"); LinAlg_PrintMatrix(stdout, &DofData_P->A) ; } *f = DofData_P->res ; LinAlg_AssembleVector(f) ; } void Generate_FullJacobian(gVector *x, gMatrix *Jac) { struct DofData * DofData_P ; Message::Debug("Generating Full Jacobian = A(x) + DofData_P->Jac"); DofData_P = Current.DofData ; LinAlg_CopyVector(x, &DofData_P->dx); LinAlg_AddVectorVector(&DofData_P->CurrentSolution->x, &DofData_P->dx, &DofData_P->CurrentSolution->x); // updating solution solution LinAlg_AddMatrixMatrix(&DofData_P->A, &DofData_P->Jac, &DofData_P->Jac) ; *Jac = DofData_P->Jac ; LinAlg_AssembleMatrix(Jac) ; } /* ------------------------------------------------------------------------ */ /* U p d a t e _ C o n s t r a i n t S y s t e m */ /* ------------------------------------------------------------------------ */ void UpdateConstraint_System(struct DefineSystem * DefineSystem_P, struct DofData * DofData_P, struct DofData * DofData_P0, int GroupIndex, int Type_Constraint, int Flag_Jac) { // Update constraints, i.e. new preprocessing of _CST type int k, Nbr_Formulation, Index_Formulation, Save_TreatmentStatus ; struct Formulation * Formulation_P ; Save_TreatmentStatus = TreatmentStatus ; TreatmentStatus = _CST ; Nbr_Formulation = List_Nbr(DefineSystem_P->FormulationIndex) ; for (k = 0 ; k < Nbr_Formulation ; k++) { List_Read(DefineSystem_P->FormulationIndex, k, &Index_Formulation) ; Formulation_P = (struct Formulation*) List_Pointer(Problem_S.Formulation, Index_Formulation) ; Message::Info("UpdateConstraint: Treatment Formulation '%s'", Formulation_P->Name) ; Init_DofDataInDefineQuantity(DefineSystem_P, DofData_P0, Formulation_P) ; Treatment_Formulation(Formulation_P) ; } Dof_InitDofType(DofData_P) ; /* Attention: Init for only one DofData */ TreatmentStatus = Save_TreatmentStatus ; } /* ------------------------------------------------------------------------ */ /* I n i t _ O p e r a t i o n O n S y s t e m */ /* ------------------------------------------------------------------------ */ void Init_OperationOnSystem(const char * Name, struct Resolution * Resolution_P, struct Operation * Operation_P , struct DofData * DofData_P0, struct GeoData * GeoData_P0, struct DefineSystem ** DefineSystem_P, struct DofData ** DofData_P, struct Resolution * Resolution2_P) { int i ; *DefineSystem_P = (struct DefineSystem*) List_Pointer(Resolution_P->DefineSystem,Operation_P->DefineSystemIndex) ; Current.DefineSystem_P = *DefineSystem_P ; //+++ *DofData_P = DofData_P0 + Operation_P->DefineSystemIndex ; Dof_SetCurrentDofData(Current.DofData = *DofData_P) ; Current.NbrHar = Current.DofData->NbrHar ; Geo_SetCurrentGeoData(Current.GeoData = GeoData_P0 + (*DofData_P)->GeoDataIndex) ; if((*DefineSystem_P)->DestinationSystemName && (*DefineSystem_P)->DestinationSystemIndex == -1){ if(Resolution2_P){ /* pre-resolution */ if ((i = List_ISearchSeq(Resolution2_P->DefineSystem, (*DefineSystem_P)->DestinationSystemName, fcmp_DefineSystem_Name)) < 0){ Message::Error("Unknown DestinationSystem (%s) in System (%s)", (*DefineSystem_P)->DestinationSystemName, (*DefineSystem_P)->Name) ; return; } (*DefineSystem_P)->DestinationSystemIndex = i ; Dof_DefineUnknownDofFromSolveOrInitDof(DofData_P) ; } else { /* a changer !!! */ if ((i = List_ISearchSeq(Resolution_P->DefineSystem, (*DefineSystem_P)->DestinationSystemName, fcmp_DefineSystem_Name)) < 0){ Message::Error("Unknown DestinationSystem (%s) in System (%s)", (*DefineSystem_P)->DestinationSystemName, (*DefineSystem_P)->Name) ; return; } (*DefineSystem_P)->DestinationSystemIndex = i ; } } const char *str = Name ? Name : Get_StringForDefine(Operation_Type, Operation_P->Type); Message::Info("%s[%s]", str, (*DefineSystem_P)->Name) ; Message::ProgressMeter(0, 0, "Processing (%s)", str); } /* ------------------------------------------------------------------------ */ /* T r e a t m e n t _ O p e r a t i o n */ /* ------------------------------------------------------------------------ */ void Treatment_Operation(struct Resolution * Resolution_P, List_T * Operation_L, struct DofData * DofData_P0, struct GeoData * GeoData_P0, struct Resolution * Resolution2_P, struct DofData * DofData2_P0) { int i, j, k, l ; double d, d1, d2, *Scales ; int Nbr_Operation, Nbr_Sol, i_Operation, Num_Iteration ; int Flag_Jac, Flag_CPU, Flag_Binary = 0 ; int Save_TypeTime ; double Save_Time, Save_DTime ; double Save_Iteration ; double MeanError, RelFactor_Modified ; char ResName[256], ResNum[256] ; char FileName[256]; char FileName_exMH[256]; gScalar tmp ; FILE *fp = stdout; struct Operation * Operation_P ; struct DefineSystem * DefineSystem_P ; struct DofData * DofData_P, * DofData2_P ; struct Solution * Solution_P, Solution_S ; struct Dof Dof, * Dof_P ; struct Value Value ; int N ; static int RES0 = -1 ; /* adaptive relaxation */ gVector x_Save; int NbrSteps_relax; double Norm; double Frelax, Frelax_Opt, Error_Prev; int istep; int Nbr_Formulation, Index_Formulation ; struct Formulation * Formulation_P ; int iTime ; double *Val_Pulsation ; double hop[NBR_MAX_HARMONIC][NBR_MAX_HARMONIC] ; double DCfactor ; int NbrHar1, NbrHar2, NbrDof1, NbrDof2 ; double dd ; int NumDof, iMat ; int row_old, row_new, col_old, col_new; double aii, ajj; int nnz__; List_T * DofList_MH_moving ; static int NbrDof_MH_moving; static int *NumDof_MH_moving ; static struct Dof ** Dof_MH_moving ; Nbr_Operation = List_Nbr(Operation_L) ; for (i_Operation = 0 ; i_Operation < Nbr_Operation ; i_Operation++) { Operation_P = (struct Operation*)List_Pointer(Operation_L, i_Operation) ; if(Message::GetCommSize() > 1 && Operation_P->Rank >= 0 && Message::GetCommRank() != (Operation_P->Rank % Message::GetCommSize())) continue; Flag_CPU = 0 ; Flag_Jac = 0 ; if(Message::GetOnelabAction() == "stop" || Message::GetErrorCount()) break; switch (Operation_P->Type) { /* --> S y s t e m C o m m a n d */ /* ------------------------------------------ */ case OPERATION_SYSTEMCOMMAND : BlockingSystemCall(Operation_P->Case.SystemCommand.String); break ; /* --> G e n e r a t e */ /* ------------------------------------------ */ case OPERATION_GENERATEJAC : Flag_Jac = 1 ; case OPERATION_GENERATERHS : case OPERATION_GENERATE : #ifdef TIMER {double tstart = MPI_Wtime(); #endif Init_OperationOnSystem(Get_StringForDefine(Operation_Type, Operation_P->Type), Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; if(Operation_P->Type == OPERATION_GENERATERHS) DofData_P->Flag_RHS = 1; Current.TypeAssembly = ASSEMBLY_AGGREGATE ; Init_SystemData(DofData_P, Flag_Jac) ; if (Operation_P->Case.Generate.GroupIndex >= 0) Generate_Group = (struct Group *) List_Pointer(Problem_S.Group, Operation_P->Case.Generate.GroupIndex) ; Generate_System(DefineSystem_P, DofData_P, DofData_P0, Flag_Jac, 0) ; if (Operation_P->Case.Generate.GroupIndex >= 0) Generate_Group = NULL ; DofData_P->Flag_RHS = 0; if(!Flag_Jac) Flag_CPU = 1 ; #ifdef TIMER double timer = MPI_Wtime() - tstart; if(Operation_P->Type == OPERATION_GENERATERHS) printf("Proc %d, time spent in Generate_RHS %.16g\n", Message::GetCommRank(), timer); else printf("Proc %d, time spent in Generate %.16g\n", Message::GetCommRank(), timer); } #endif break ; /* --> G e n e r a t e S e p a r a t e */ /* ------------------------------------------ */ case OPERATION_GENERATESEPARATE : Init_OperationOnSystem("GenerateSeparate", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; if (Operation_P->Case.Generate.GroupIndex >= 0) Generate_Group = (struct Group *) List_Pointer(Problem_S.Group, Operation_P->Case.Generate.GroupIndex) ; Current.TypeAssembly = ASSEMBLY_SEPARATE ; Init_Update = 0 ; /* modif... ! */ Init_SystemData(DofData_P, Flag_Jac) ; Generate_System(DefineSystem_P, DofData_P, DofData_P0, Flag_Jac, 1) ; if (Operation_P->Case.Generate.GroupIndex >= 0) Generate_Group = NULL ; Flag_CPU = 1 ; break ; /* --> G e n e r a t e O n l y */ /* ------------------------------------------ */ case OPERATION_GENERATEONLYJAC : Flag_Jac = 1 ; case OPERATION_GENERATEONLY: Init_OperationOnSystem(Get_StringForDefine(Operation_Type, Operation_P->Type), Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; if(DofData_P->Flag_Only < 2) DofData_P->Flag_Only += 1 ; DofData_P->OnlyTheseMatrices = Operation_P->Case.GenerateOnly.MatrixIndex_L ; if (DofData_P->Flag_Only <= 2) for (i = 0 ; i < List_Nbr(DofData_P->OnlyTheseMatrices); i++){ List_Read( DofData_P->OnlyTheseMatrices, i, &iMat); switch(iMat){ case 1: DofData_P->Flag_InitOnly[0] = 1 ; break ; case 2: DofData_P->Flag_InitOnly[1] = 1 ; break ; case 3: DofData_P->Flag_InitOnly[2] = 1 ; break ; } } Current.TypeAssembly = ASSEMBLY_AGGREGATE ; Init_SystemData(DofData_P, Flag_Jac) ; Generate_System(DefineSystem_P, DofData_P, DofData_P0, Flag_Jac, 0) ; if(!Flag_Jac) Flag_CPU = 1 ; break; /* --> U p d a t e */ /* ------------------------------------------ */ case OPERATION_UPDATE : Init_OperationOnSystem("Update", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; Operation_Update(DefineSystem_P, DofData_P, DofData_P0, Operation_P->Case.Update.ExpressionIndex) ; Flag_CPU = 1 ; break ; /* --> U p d a t e C o n s t r a i n t */ /* ------------------------------------------ */ case OPERATION_UPDATECONSTRAINT : Init_OperationOnSystem("UpdateConstraint", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; UpdateConstraint_System(DefineSystem_P, DofData_P, DofData_P0, Operation_P->Case.UpdateConstraint.GroupIndex, Operation_P->Case.UpdateConstraint.Type, Flag_Jac) ; Flag_CPU = 1 ; break ; /* --> S e l e c t C o r r e c t i o n */ /* ------------------------------------------ */ case OPERATION_SELECTCORRECTION : Init_OperationOnSystem("SelectCorrection", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; if (!Operation_P->Case.SelectCorrection.Iteration) { /* Full solution to be considered again */ Message::Info(" Full solution to be considered again"); if (DofData_P->CorrectionSolutions.Flag) { DofData_P->CorrectionSolutions.Flag = 0; DofData_P->Solutions = DofData_P->CorrectionSolutions.Save_FullSolutions ; DofData_P->CurrentSolution = DofData_P->CorrectionSolutions.Save_CurrentFullSolution ; } else { Message::Error("SelectCorrection: DofData #%d already selected as a full solution", DofData_P->Num); } } else { /* Last correction to be considered */ if (!DofData_P->CorrectionSolutions.Flag) { DofData_P->CorrectionSolutions.Flag = 1; DofData_P->CorrectionSolutions.Save_FullSolutions = DofData_P->Solutions ; DofData_P->CorrectionSolutions.Save_CurrentFullSolution = DofData_P->CurrentSolution ; /* last correction solutions */ if ((i = List_Nbr(DofData_P->CorrectionSolutions.AllSolutions)-1) >= 0) { List_Read(DofData_P->CorrectionSolutions.AllSolutions, i, &DofData_P->Solutions); } else { DofData_P->CorrectionSolutions.AllSolutions = List_Create(10, 10, sizeof(List_T*)); DofData_P->Solutions = List_Create(20, 20, sizeof(struct Solution)) ; List_Add(DofData_P->CorrectionSolutions.AllSolutions, &DofData_P->Solutions); } /* last time step correction */ if ((i = List_Nbr(DofData_P->Solutions)-1) >= 0) { DofData_P->CurrentSolution = (struct Solution*) List_Pointer(DofData_P->Solutions, i) ; } else { DofData_P->CurrentSolution = NULL; /* CurrentSolution will be defined later */ } } else { Message::Error("SelectCorrection: DofData #%d already selected as a correction", DofData_P->Num); } } break ; /* --> A d d C o r r e c t i o n */ /* ------------------------------------------ */ case OPERATION_ADDCORRECTION : Init_OperationOnSystem("AddCorrection", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; if (DofData_P->CorrectionSolutions.Flag) { if (DofData_P->CorrectionSolutions.Save_CurrentFullSolution->TimeStep != DofData_P->CurrentSolution->TimeStep) { Solution_S.TimeStep = (int)Current.TimeStep ; Solution_S.Time = Current.Time ; Solution_S.TimeImag = Current.TimeImag ; Solution_S.TimeFunctionValues = Get_TimeFunctionValues(DofData_P) ; Solution_S.SolutionExist = 1 ; LinAlg_CreateVector(&Solution_S.x, &DofData_P->Solver, DofData_P->NbrDof) ; LinAlg_ZeroVector(&Solution_S.x) ; List_Add(DofData_P->CorrectionSolutions.Save_FullSolutions, &Solution_S) ; DofData_P->CorrectionSolutions.Save_CurrentFullSolution = (struct Solution*) List_Pointer(DofData_P->CorrectionSolutions.Save_FullSolutions, List_Nbr(DofData_P->CorrectionSolutions.Save_FullSolutions)-1) ; } Cal_SolutionError (&DofData_P->CurrentSolution->x, &DofData_P->CorrectionSolutions.Save_CurrentFullSolution->x, 0, &MeanError) ; //LinAlg_VectorNorm2(&DofData_P->CurrentSolution->x, &MeanError); Message::Info("Mean error: %.3e (after %d iteration%s)", MeanError, (int)Current.Iteration, ((int)Current.Iteration==1)?"":"s") ; if(Message::GetProgressMeterStep() > 0 && Message::GetProgressMeterStep() < 100) Message::AddOnelabNumberChoice(Message::GetOnelabClientName() + "/Residual", MeanError); Current.RelativeDifference += MeanError * Operation_P->Case.AddCorrection.Alpha ; LinAlg_AddVectorVector (&DofData_P->CorrectionSolutions.Save_CurrentFullSolution->x, &DofData_P->CurrentSolution->x, &DofData_P->CorrectionSolutions.Save_CurrentFullSolution->x) ; } else { Message::Error("AddCorrection: DofData #%d is not selected as a correction", DofData_P->Num); } break ; /* --> I n i t C o r r e c t i o n */ /* ------------------------------------------ */ case OPERATION_INITCORRECTION : Init_OperationOnSystem("InitCorrection", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; if (DofData_P->CorrectionSolutions.Flag) { Solution_S.TimeStep = (int)Current.TimeStep ; Solution_S.Time = Current.Time ; Solution_S.TimeImag = Current.TimeImag ; Solution_S.TimeFunctionValues = Get_TimeFunctionValues(DofData_P) ; Solution_S.SolutionExist = 1 ; LinAlg_CreateVector(&Solution_S.x, &DofData_P->Solver, DofData_P->NbrDof) ; /* The last full solution, if any, initializes the current correction */ if (List_Nbr(DofData_P->CorrectionSolutions.Save_FullSolutions)) { LinAlg_CopyVector (&((struct Solution *) List_Pointer (DofData_P->CorrectionSolutions.Save_FullSolutions, List_Nbr(DofData_P->CorrectionSolutions.Save_FullSolutions)-1))->x, &Solution_S.x) ; } else { LinAlg_ZeroVector(&Solution_S.x) ; } List_Add(DofData_P->Solutions, &Solution_S) ; DofData_P->CurrentSolution = (struct Solution*) List_Pointer(DofData_P->Solutions, List_Nbr(DofData_P->Solutions)-1) ; } else { Message::Error("InitCorrection: DofData #%d is not selected as a correction", DofData_P->Num); } break ; /* --> M u l t i p l y S o l u t i o n */ /* ------------------------------------------ */ case OPERATION_MULTIPLYSOLUTION : Init_OperationOnSystem("MultiplySolution", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; LinAlg_ProdVectorDouble(&DofData_P->CurrentSolution->x, Operation_P->Case.MultiplySolution.Alpha, &DofData_P->CurrentSolution->x) ; break ; /* --> A d d O p p o s i t e F u l l S o l u t i o n */ /* -------------------------------------------------- */ case OPERATION_ADDOPPOSITEFULLSOLUTION : Init_OperationOnSystem("AddOppositeFullSolution", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; LinAlg_AddVectorProdVectorDouble (&DofData_P->CurrentSolution->x, &DofData_P->CorrectionSolutions.Save_CurrentFullSolution->x, -1., &DofData_P->CurrentSolution->x) ; break ; /* --> S o l v e */ /* ------------------------------------------ */ case OPERATION_SOLVEAGAINWITHOTHER : case OPERATION_SOLVEAGAIN : case OPERATION_SOLVE : { int again = (Operation_P->Type == OPERATION_SOLVEAGAINWITHOTHER) ? 2 : (Operation_P->Type == OPERATION_SOLVEAGAIN) ? 1 : 0; #ifdef TIMER double tstart = MPI_Wtime(); #endif /* Solve : A x = b */ Init_OperationOnSystem((again == 2) ? "SolveAgainWithOther" : (again == 1) ? "SolveAgain" : "Solve", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; if (DofData_P->Flag_Only){ if(DofData_P->Flag_InitOnly[0]){ LinAlg_AddMatrixMatrix(&DofData_P->A, &DofData_P->A1, &DofData_P->A); LinAlg_AddVectorVector(&DofData_P->b, &DofData_P->b1, &DofData_P->b) ; } if(DofData_P->Flag_InitOnly[1]){ LinAlg_AddMatrixMatrix(&DofData_P->A, &DofData_P->A2, &DofData_P->A) ; LinAlg_AddVectorVector(&DofData_P->b, &DofData_P->b2, &DofData_P->b) ; } if(DofData_P->Flag_InitOnly[2]){ LinAlg_AddMatrixMatrix(&DofData_P->A, &DofData_P->A3, &DofData_P->A) ; LinAlg_AddVectorVector(&DofData_P->b, &DofData_P->b3, &DofData_P->b) ; } LinAlg_AssembleMatrix(&DofData_P->A) ; LinAlg_AssembleVector(&DofData_P->b) ; } // By default, Operation_P->Rank = -1. // If Operation_P->Rank >= 0 then OPERATION_SOLVE is achieved sequentially on processus // Operation_P->Rank only. // If Operation_P->Rank < 0 then OPERATION_SOLVE is launched "classically" in parallel // with a choice of the solver. // The last argument of function "_solve" called by LinAlg_Solve defines which solver // to use, from 0 to 9 (0=default, 1,2,... see "_solve" function) // Thus, if Operation_P->Rank < 0, then we have to substitute Operation_P->Rank // to (-Operation_P->Rank-1) in the last argument to recover the solver number (0,1,2, ...) // This modification permits to do numerical simulations of Domain Decomposition Method // The same applies for LinAlg_SolveAgain, bellow if(!again){ LinAlg_Solve(&DofData_P->A, &DofData_P->b, &DofData_P->Solver, &DofData_P->CurrentSolution->x, (Operation_P->Rank < 0) ? (-Operation_P->Rank-1) : 0) ; } else{ DofData *d = (again == 1) ? DofData_P : DofData_P0 + Operation_P->Case.SolveAgainWithOther.DefineSystemIndex; LinAlg_SolveAgain(&d->A, &DofData_P->b, &d->Solver, &DofData_P->CurrentSolution->x, (Operation_P->Rank < 0) ? (-Operation_P->Rank-1) : 0) ; } Flag_CPU = 1 ; #ifdef TIMER double timer = MPI_Wtime() - tstart; printf("Proc %d, time spent in %s %.16g\n", again ? "SolveAgain" : "Solve", Message::GetCommRank(), timer); #endif } break ; // Using PETSC nonlinear solvers - SNES, nonlinear loop internal to PETSC // Jacobian furnished or not (finite differences)... case OPERATION_SOLVENL : /* Solve nonlinear system: A(x) x = b(x) */ Init_OperationOnSystem("Using SNES: SolveNL", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; if(DofData_P->Flag_Init[0] < 2){ Message::Info("Initializing Jacobian system: no JacNL term"); LinAlg_CreateMatrix(&DofData_P->Jac, &DofData_P->Solver, DofData_P->NbrDof, DofData_P->NbrDof) ; LinAlg_CreateVector(&DofData_P->res, &DofData_P->Solver, DofData_P->NbrDof) ; LinAlg_CreateVector(&DofData_P->dx, &DofData_P->Solver, DofData_P->NbrDof) ; LinAlg_ZeroMatrix(&DofData_P->Jac) ; LinAlg_ZeroVector(&DofData_P->res) ; LinAlg_ZeroVector(&DofData_P->dx) ; LinAlg_AssembleMatrix(&DofData_P->Jac) ; LinAlg_AssembleVector(&DofData_P->res) ; LinAlg_AssembleVector(&DofData_P->dx) ; } LinAlg_SolveNL(&DofData_P->A, &DofData_P->b, &DofData_P->Jac, &DofData_P->res, &DofData_P->Solver, &DofData_P->dx, (Message::GetCommSize() > 1 || Operation_P->Rank < 0) ? 0 : Operation_P->Rank) ; Flag_CPU = 1 ; break ; /* --> S o l v e J a c */ /* ------------------------------------------ */ case OPERATION_SOLVEJACAGAIN : case OPERATION_SOLVEJAC : { /* SolveJac : J(xn) dx = b(xn) - A(xn) xn ; x = xn + dx */ int again = (Operation_P->Type == OPERATION_SOLVEJACAGAIN) ? 1 : 0; Flag_Jac = 1 ; Init_OperationOnSystem(again ? "SolveJacAgain" : "SolveJac", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; if(DofData_P->Flag_Init[0] < 2){ Message::Error("Jacobian system not initialized (missing GenerateJac?)"); break; } if (DofData_P->Flag_Only){ if(DofData_P->Flag_InitOnly[0]){ LinAlg_AddMatrixMatrix(&DofData_P->A, &DofData_P->A1, &DofData_P->A); LinAlg_AddVectorVector(&DofData_P->b, &DofData_P->b1, &DofData_P->b) ; } if(DofData_P->Flag_InitOnly[1]){ LinAlg_AddMatrixMatrix(&DofData_P->A, &DofData_P->A2, &DofData_P->A) ; LinAlg_AddVectorVector(&DofData_P->b, &DofData_P->b2, &DofData_P->b) ; } if(DofData_P->Flag_InitOnly[2]){ LinAlg_AddMatrixMatrix(&DofData_P->A, &DofData_P->A3, &DofData_P->A) ; LinAlg_AddVectorVector(&DofData_P->b, &DofData_P->b3, &DofData_P->b) ; } LinAlg_AssembleMatrix(&DofData_P->A) ; LinAlg_AssembleVector(&DofData_P->b) ; } // Store sum in A (not in Jac) for performance reasons (the sparsity // pattern of Jac is a subset of the sparsity pattern of A) LinAlg_ProdMatrixVector(&DofData_P->A, &DofData_P->CurrentSolution->x, &DofData_P->res) ; LinAlg_AddMatrixMatrix(&DofData_P->A, &DofData_P->Jac, &DofData_P->A) ; // Problem with PETSc 3.3 // res = b(xn)-A(xn)*xn LinAlg_SubVectorVector(&DofData_P->b, &DofData_P->res, &DofData_P->res) ; LinAlg_DummyVector(&DofData_P->res) ; if(!again) LinAlg_Solve(&DofData_P->A, &DofData_P->res, &DofData_P->Solver, &DofData_P->dx) ; else LinAlg_SolveAgain(&DofData_P->A, &DofData_P->res, &DofData_P->Solver, &DofData_P->dx) ; Cal_SolutionError(&DofData_P->dx, &DofData_P->CurrentSolution->x, 0, &MeanError) ; //LinAlg_VectorNorm2(&DofData_P->dx, &MeanError); if(!Flag_IterativeLoopN){ Message::Info("%3ld Nonlinear Residual norm %14.12e", (int)Current.Iteration, MeanError); if(Message::GetProgressMeterStep() > 0 && Message::GetProgressMeterStep() < 100) Message::AddOnelabNumberChoice(Message::GetOnelabClientName() + "/Residual", MeanError); } Current.RelativeDifference += MeanError ; if (!Flag_IterativeLoop) { LinAlg_ProdVectorDouble(&DofData_P->dx, Current.RelaxationFactor, &DofData_P->dx) ; } else { // Attention: phase test ... Technique bricolee ... provisoire if (Current.Iteration == 1. || MeanError < Current.RelativeDifferenceOld) LinAlg_ProdVectorDouble(&DofData_P->dx, Current.RelaxationFactor, &DofData_P->dx) ; else { RelFactor_Modified = Current.RelaxationFactor / (MeanError / Current.RelativeDifferenceOld) ; Message::Info("RelFactor modified = %g", RelFactor_Modified) ; LinAlg_ProdVectorDouble(&DofData_P->dx, RelFactor_Modified, &DofData_P->dx) ; Cal_SolutionError(&DofData_P->dx, &DofData_P->CurrentSolution->x, 0, &MeanError) ; //LinAlg_VectorNorm2(&DofData_P->dx, &MeanError); Message::Info("Mean error: %.3e", MeanError) ; } } LinAlg_AddVectorVector(&DofData_P->CurrentSolution->x, &DofData_P->dx, &DofData_P->CurrentSolution->x) ; Flag_CPU = 1 ; } break ; /* --> S o l v e J a c _ A d a p t R e l a x */ /* ------------------------------------------ */ case OPERATION_SOLVEJACADAPTRELAX : /* get increment dx by solving : J(xn) dx = b(xn) - A(xn) xn */ Flag_Jac = 1 ; Init_OperationOnSystem("SolveJacAdaptRelax", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; if(DofData_P->Flag_Init[0] < 2){ Message::Error("Jacobian system not initialized (missing GenerateJac?)"); break; } LinAlg_AddMatrixMatrix(&DofData_P->Jac, &DofData_P->A, &DofData_P->Jac) ; LinAlg_ProdMatrixVector(&DofData_P->A, &DofData_P->CurrentSolution->x, &DofData_P->res) ; LinAlg_SubVectorVector(&DofData_P->b, &DofData_P->res, &DofData_P->res) ; LinAlg_DummyVector(&DofData_P->res) ; LinAlg_Solve(&DofData_P->Jac, &DofData_P->res, &DofData_P->Solver, &DofData_P->dx) ; Message::Cpu(""); /* save CurrentSolution */ LinAlg_CreateVector(&x_Save, &DofData_P->Solver, DofData_P->NbrDof) ; LinAlg_CopyVector(&DofData_P->CurrentSolution->x, &x_Save); Flag_RHS = 1; /* MHJacNL-terms don't contribute to the RHS and residu, and are thus disregarded */ Error_Prev = 1e99 ; Frelax_Opt = 1. ; if (!(NbrSteps_relax = List_Nbr(Operation_P->Case.SolveJac_AdaptRelax.Factor_L))){ Message::Error("No factors provided for Adaptive Relaxation"); break; } for( istep = 0 ; istep < NbrSteps_relax ; istep++ ){ if(Message::GetOnelabAction() == "stop" || Message::GetErrorCount()) break; List_Read(Operation_P->Case.SolveJac_AdaptRelax.Factor_L, istep, &Frelax); /* new trial solution = x + Frelax * dx */ LinAlg_CopyVector(&x_Save, &DofData_P->CurrentSolution->x); LinAlg_AddVectorProdVectorDouble(&DofData_P->CurrentSolution->x, &DofData_P->dx, Frelax, &DofData_P->CurrentSolution->x); /* LinAlg_PrintVector(stdout, &DofData_P->CurrentSolution->x); */ /* calculate residual with trial solution */ ReGenerate_System(DefineSystem_P, DofData_P, DofData_P0) ; LinAlg_ProdMatrixVector(&DofData_P->A, &DofData_P->CurrentSolution->x, &DofData_P->res) ; LinAlg_SubVectorVector(&DofData_P->b, &DofData_P->res, &DofData_P->res) ; /* check whether norm of residual is smaller than previous ones */ LinAlg_VectorNorm2(&DofData_P->res, &Norm); LinAlg_GetVectorSize(&DofData_P->res, &N); Norm /= (double)N; Message::Info(" adaptive relaxation : factor = %8f Norm residual = %10.4e", Frelax, Norm) ; if (Norm < Error_Prev) { Error_Prev = Norm; Frelax_Opt = Frelax; } else if ( !Operation_P->Case.SolveJac_AdaptRelax.CheckAll && istep > 0 ) break ; } Message::Info(" => optimal relaxation factor = %f", Frelax_Opt) ; /* solution = x + Frelax_Opt * dx */ LinAlg_CopyVector(&x_Save, &DofData_P->CurrentSolution->x); LinAlg_AddVectorProdVectorDouble(&DofData_P->CurrentSolution->x, &DofData_P->dx, Frelax_Opt, &DofData_P->CurrentSolution->x); MeanError = Error_Prev ; Message::Info("Mean error: %.3e (after %d iteration%s)", MeanError, (int)Current.Iteration, ((int)Current.Iteration==1)?"":"s") ; if(Message::GetProgressMeterStep() > 0 && Message::GetProgressMeterStep() < 100) Message::AddOnelabNumberChoice(Message::GetOnelabClientName() + "/Residual", MeanError); Current.RelativeDifference = MeanError; Flag_CPU = 1 ; Flag_RHS = 0 ; LinAlg_DestroyVector(&x_Save); break ; /* --> EigenSolve */ /* ------------------------------------------ */ case OPERATION_EIGENSOLVE : Init_OperationOnSystem("EigenSolve", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; EigenSolve(DofData_P, Operation_P->Case.EigenSolve.NumEigenvalues, Operation_P->Case.EigenSolve.Shift_r, Operation_P->Case.EigenSolve.Shift_i) ; Flag_CPU = 1 ; break ; /* --> EigenSolveJac */ /* ------------------------------------------ */ case OPERATION_EIGENSOLVEJAC : Init_OperationOnSystem("EigenSolveJac", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; EigenSolve(DofData_P, Operation_P->Case.EigenSolve.NumEigenvalues, Operation_P->Case.EigenSolve.Shift_r, Operation_P->Case.EigenSolve.Shift_i) ; /* Insert intelligent convergence test here :-) */ Current.RelativeDifference = 1.0 ; Flag_CPU = 1 ; break ; /* --> Perturbation */ /* ------------------------------------------ */ case OPERATION_PERTURBATION : Init_OperationOnSystem("Perturbation", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; /* Perturbation(DofData_P, DofData_P0+Operation_P->Case.Perturbation.DefineSystemIndex2, DofData_P0+Operation_P->Case.Perturbation.DefineSystemIndex3, Operation_P->Case.Perturbation.Size, Operation_P->Case.Perturbation.Save, Operation_P->Case.Perturbation.Shift, Operation_P->Case.Perturbation.PertFreq) ; */ Flag_CPU = 1 ; break ; /* --> S e t C u r r e n t S y s t e m */ /* ------------------------------------------ */ case OPERATION_SETCURRENTSYSTEM : Init_OperationOnSystem("SetCurrentSystem", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; break ; /* --> I n i t S o l u t i o n */ /* ------------------------------------------ */ case OPERATION_INITSOLUTION : case OPERATION_INITSOLUTION1 : Init_OperationOnSystem("InitSolution", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; if(Flag_RESTART){ if (!DofData_P->Solutions){ Message::Error("No solution to restart the computation"); break; } for(i = 0 ; i < DofData_P->NbrAnyDof ; i++){ Dof_P = (struct Dof *)List_Pointer(DofData_P->DofList, i) ; if(Dof_P->Type == DOF_UNKNOWN_INIT) Dof_P->Type = DOF_UNKNOWN ; } for(i = 0; i < List_Nbr(DofData_P->Solutions); i++){ Solution_P = (struct Solution*)List_Pointer(DofData_P->Solutions, i); Free(Solution_P->TimeFunctionValues); Solution_P->TimeFunctionValues = Get_TimeFunctionValues(DofData_P) ; /* The last solution is the current one */ if(i == List_Nbr(DofData_P->Solutions) - 1) DofData_P->CurrentSolution = Solution_P; } RES0 = (int)Current.TimeStep ; } else{ if (!DofData_P->Solutions) DofData_P->Solutions = List_Create( 20, 20, sizeof(struct Solution)) ; Solution_S.TimeStep = (int)Current.TimeStep ; Solution_S.Time = Current.Time ; Solution_S.TimeImag = Current.TimeImag ; Solution_S.TimeFunctionValues = Get_TimeFunctionValues(DofData_P) ; Solution_S.SolutionExist = 1 ; LinAlg_CreateVector(&Solution_S.x, &DofData_P->Solver, DofData_P->NbrDof) ; /* The last solution, if any, initializes the current one. Otherwise a null solution is used. a revoir qd les conditions initiales multiples seront mieux traitees */ if (List_Nbr(DofData_P->Solutions)) { LinAlg_CopyVector(&((struct Solution *) List_Pointer(DofData_P->Solutions, List_Nbr(DofData_P->Solutions)-1))->x, &Solution_S.x) ; } else { LinAlg_ZeroVector(&Solution_S.x) ; } for(i=0 ; iNbrAnyDof ; i++){ Dof_P = (struct Dof *)List_Pointer(DofData_P->DofList, i) ; if(Dof_P->Type == DOF_UNKNOWN_INIT){ /* Init values loaded */ if(Operation_P->Type == OPERATION_INITSOLUTION){ Dof_P->Type = DOF_UNKNOWN ; LinAlg_SetScalarInVector (&Dof_P->Val, &Solution_S.x, Dof_P->Case.Unknown.NumDof-1) ; } else{ LinAlg_SetScalarInVector (&Dof_P->Val2, &Solution_S.x, Dof_P->Case.Unknown.NumDof-1) ; } } } // FIXME: required by parallel version LinAlg_AssembleVector(&Solution_S.x) ; List_Add(DofData_P->Solutions, &Solution_S) ; DofData_P->CurrentSolution = (struct Solution*) List_Pointer(DofData_P->Solutions, List_Nbr(DofData_P->Solutions)-1) ; } break ; /* --> S a v e S o l u t i o n */ /* ------------------------------------------ */ case OPERATION_SAVESOLUTION : Init_OperationOnSystem("SaveSolution", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; strcpy(ResName, Name_Generic) ; if(!Flag_SPLIT){ strcat(ResName, ".res") ; if(RES0 < 0){ Dof_WriteFileRES0(ResName, Flag_BIN) ; RES0 = 1 ; } } else{ strcat(ResName, "-") ; sprintf(ResNum, "%d.res", (int)Current.TimeStep) ; for(i = 0 ; i < 5+4-(int)strlen(ResNum) ; i++) strcat(ResName, "0") ; strcat(ResName, ResNum) ; if(RES0 != (int)Current.TimeStep){ Dof_WriteFileRES0(ResName, Flag_BIN) ; RES0 = (int)Current.TimeStep ; } } Dof_WriteFileRES(ResName, DofData_P, Flag_BIN, Current.Time, Current.TimeImag, (int)Current.TimeStep) ; break ; /* --> S a v e S o l u t i o n W i t h E n t i t y N u m */ /* ------------------------------------------------ */ case OPERATION_SAVESOLUTION_WITH_ENTITY_NUM : Init_OperationOnSystem("SaveSolutionWithEntityNum", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; strcpy(ResName, Name_Generic) ; //strcat(ResName, ".txt") ; { int num = Operation_P->Case.SaveSolutionWithEntityNum.GroupIndex; Group *g = 0; if (num >= 0) g = (Group*)List_Pointer(Problem_S.Group, num); bool saveFixed = Operation_P->Case.SaveSolutionWithEntityNum.SaveFixed; Dof_WriteFileRES_WithEntityNum(ResName, DofData_P, GeoData_P0, g, saveFixed) ; } break ; /* --> S a v e S o l u t i o n s */ /* ------------------------------------------ */ case OPERATION_SAVESOLUTIONS : Init_OperationOnSystem("SaveSolutions", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; strcpy(ResName, Name_Generic) ; strcat(ResName, ".res") ; if(RES0 < 0){ Dof_WriteFileRES0(ResName, Flag_BIN) ; RES0 = 1 ; } for(i=0 ; iSolutions) ; i++){ DofData_P->CurrentSolution = (struct Solution*) List_Pointer(DofData_P->Solutions, i) ; if (!DofData_P->CurrentSolution->SolutionExist) Message::Warning("Solution #%d doesn't exist anymore: skipping", i) ; else Dof_WriteFileRES(ResName, DofData_P, Flag_BIN, DofData_P->CurrentSolution->Time, DofData_P->CurrentSolution->TimeImag, i) ; } break ; /* --> M o v i n g B a n d */ /* ------------------------------------------ */ case OPERATION_INIT_MOVINGBAND2D : Message::Info("InitMovingBand2D") ; Init_MovingBand2D( (struct Group *) List_Pointer(Problem_S.Group, Operation_P->Case.Init_MovingBand2D.GroupIndex)) ; break ; case OPERATION_MESH_MOVINGBAND2D : Message::Info("MeshMovingBand2D") ; Mesh_MovingBand2D( (struct Group *) List_Pointer(Problem_S.Group, Operation_P->Case.Mesh_MovingBand2D.GroupIndex)) ; break ; case OPERATION_GENERATE_MH_MOVING : Init_OperationOnSystem("Generate_MH_Moving", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; if(gSCALAR_SIZE == 2){ Message::Error("FIXME: Generate_MH_Moving will not work in complex arithmetic"); break; } Nbr_Formulation = List_Nbr(DefineSystem_P->FormulationIndex) ; Generate_Group = (struct Group *) List_Pointer(Problem_S.Group, Operation_P->Case.Generate_MH_Moving.GroupIndex) ; MH_Moving_Matrix = (double **) Malloc(Current.NbrHar*sizeof(double *)) ; for (k = 0 ; k < Current.NbrHar ; k++) MH_Moving_Matrix[k] = (double *) Malloc(Current.NbrHar*sizeof(double)) ; if (! (Val_Pulsation = Current.DofData->Val_Pulsation)){ Message::Error("Generate_MH_moving can only be used for harmonic problems"); break; } for (k = 0 ; k < Current.NbrHar ; k++) for (l = 0 ; l < Current.NbrHar ; l++) hop[k][l] = 0.; MH_Moving_Matrix_simple = 1; for (iTime = 0 ; iTime < Operation_P->Case.Generate_MH_Moving.NbrStep ; iTime++) { Current.Time = (double)iTime/(double)Operation_P->Case.Generate_MH_Moving.NbrStep * Operation_P->Case.Generate_MH_Moving.Period ; Current.DTime = 1./(double)Operation_P->Case.Generate_MH_Moving.NbrStep * Operation_P->Case.Generate_MH_Moving.Period ; Current.TimeStep = iTime; Message::Info("Generate_MH_Moving : Step %d/%d (Time = %e DTime %e)", (int)(Current.TimeStep+1), Operation_P->Case.Generate_MH_Moving.NbrStep, Current.Time, Current.DTime) ; Treatment_Operation(Resolution_P, Operation_P->Case.Generate_MH_Moving.Operation, DofData_P0, GeoData_P0, NULL, NULL) ; for (k = 0 ; k < Current.NbrHar ; k++) for (l = 0 ; l < Current.NbrHar ; l++) { if (Val_Pulsation[k/2]) DCfactor = 2. ; else DCfactor = 1. ; MH_Moving_Matrix[k][l] = DCfactor / (double)Operation_P->Case.Generate_MH_Moving.NbrStep * ( fmod(k,2) ? -sin(Val_Pulsation[k/2]*Current.Time) : cos(Val_Pulsation[k/2]*Current.Time) ) * ( fmod(l,2) ? -sin(Val_Pulsation[l/2]*Current.Time) : cos(Val_Pulsation[l/2]*Current.Time) ) ; hop[k][l] += MH_Moving_Matrix[k][l] ; } for (k = 0 ; k < Current.NbrHar/2 ; k++) if (!Val_Pulsation[k]) MH_Moving_Matrix[2*k+1][2*k+1] = 1. ; for (i = 0 ; i < Nbr_Formulation ; i++) { List_Read(DefineSystem_P->FormulationIndex, i, &Index_Formulation) ; Formulation_P = (struct Formulation*) List_Pointer(Problem_S.Formulation, Index_Formulation) ; Treatment_Formulation(Formulation_P) ; } } Current.TimeStep = 0; Current.Time = 0.; for (k = 0 ; k < Current.NbrHar ; k++) Free (MH_Moving_Matrix[k]) ; Free (MH_Moving_Matrix) ; MH_Moving_Matrix = NULL ; MH_Moving_Matrix_simple = 0 ; Generate_Group = NULL; Message::Cpu(""); break ; case OPERATION_GENERATE_MH_MOVING_S : Init_OperationOnSystem("Generate_MH_Moving_Separate", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; Nbr_Formulation = List_Nbr(DefineSystem_P->FormulationIndex) ; Generate_Group = (struct Group *) List_Pointer(Problem_S.Group, Operation_P->Case.Generate_MH_Moving_S.GroupIndex) ; MH_Moving_Matrix = (double **) Malloc(Current.NbrHar*sizeof(double *)) ; for (k = 0 ; k < Current.NbrHar ; k++) MH_Moving_Matrix[k] = (double *) Malloc(Current.NbrHar*sizeof(double)) ; if (! (Val_Pulsation = Current.DofData->Val_Pulsation)){ Message::Error("Generate_MH_moving can only be used for harmonic problems"); break; } for (k = 0 ; k < Current.NbrHar ; k++) for (l = 0 ; l < Current.NbrHar ; l++) hop[k][l] = 0.; DummyDof = DofData_P->DummyDof ; DofData_P->DummyDof = NULL ; for (iTime = 0 ; iTime < Operation_P->Case.Generate_MH_Moving_S.NbrStep ; iTime++) { Current.Time = (double)iTime/(double)Operation_P->Case.Generate_MH_Moving_S.NbrStep * Operation_P->Case.Generate_MH_Moving_S.Period ; Current.DTime = 1./(double)Operation_P->Case.Generate_MH_Moving_S.NbrStep * Operation_P->Case.Generate_MH_Moving_S.Period ; Current.TimeStep = iTime; if (!iTime) { Message::Info("Generate_MH_Moving_Separate : probing for any degrees of freedom"); DofTree_MH_moving = Tree_Create(sizeof(struct Dof), fcmp_Dof) ; /* probing assembly */ MH_Moving_Matrix_probe = 1; for (i = 0 ; i < Nbr_Formulation ; i++) { List_Read(DefineSystem_P->FormulationIndex, i, &Index_Formulation) ; Formulation_P = (struct Formulation*) List_Pointer(Problem_S.Formulation, Index_Formulation) ; Treatment_Formulation(Formulation_P) ; } MH_Moving_Matrix_probe = 0; DofList_MH_moving = Tree2List(DofTree_MH_moving) ; Tree_Delete(DofTree_MH_moving) ; NbrDof_MH_moving = List_Nbr(DofList_MH_moving) ; Message::Info("Generate_MH_Moving : NbrDof = %d", NbrDof_MH_moving); Dof_MH_moving = (struct Dof **)Malloc(NbrDof_MH_moving * sizeof(struct Dof *)) ; NumDof_MH_moving = (int *)Malloc(NbrDof_MH_moving * sizeof(int)) ; for (i = 0 ; i < NbrDof_MH_moving ; i++) { Dof_P = (struct Dof*)List_Pointer(DofList_MH_moving,i) ; if (Dof_P->Type != DOF_UNKNOWN){ Message::Error("Dof_MH_moving not of type unknown !?"); break; } NumDof_MH_moving[i] = Dof_P->Case.Unknown.NumDof; if(!(Dof_MH_moving[i] = (struct Dof *)List_PQuery(Current.DofData->DofList, Dof_P, fcmp_Dof))){ Message::Error("Troubles") ; break; } for (k = 0 ; k < Current.NbrHar ; k++) { (Dof_MH_moving[i]+k)->Case.Unknown.NumDof = i*Current.NbrHar+k+1 ; } } /* if (!iTime) */ Message::Cpu(""); LinAlg_CreateSolver(&DofData_P->Solver_MH_moving, "MH_moving.par") ; LinAlg_CreateMatrix(&DofData_P->A_MH_moving, &DofData_P->Solver_MH_moving, NbrDof_MH_moving*Current.NbrHar, NbrDof_MH_moving*Current.NbrHar) ; LinAlg_CreateVector(&DofData_P->b_MH_moving, &DofData_P->Solver_MH_moving, NbrDof_MH_moving*Current.NbrHar) ; LinAlg_ZeroMatrix(&DofData_P->A_MH_moving) ; LinAlg_ZeroVector(&DofData_P->b_MH_moving) ; } Message::Info("Generate_MH_Moving_Separate : Step %d/%d (Time = %e DTime %e)", (int)(Current.TimeStep+1), Operation_P->Case.Generate_MH_Moving_S.NbrStep, Current.Time, Current.DTime) ; Treatment_Operation(Resolution_P, Operation_P->Case.Generate_MH_Moving.Operation, DofData_P0, GeoData_P0, NULL, NULL) ; for (k = 0 ; k < Current.NbrHar ; k++) for (l = 0 ; l < Current.NbrHar ; l++) { if (Val_Pulsation[k/2]) DCfactor = 2. ; else DCfactor = 1. ; MH_Moving_Matrix[k][l] = DCfactor / (double)Operation_P->Case.Generate_MH_Moving.NbrStep * ( fmod(k,2) ? -sin(Val_Pulsation[k/2]*Current.Time) : cos(Val_Pulsation[k/2]*Current.Time) ) * ( fmod(l,2) ? -sin(Val_Pulsation[l/2]*Current.Time) : cos(Val_Pulsation[l/2]*Current.Time) ) ; hop[k][l] += MH_Moving_Matrix[k][l] ; } for (k = 0 ; k < Current.NbrHar/2 ; k++) if (!Val_Pulsation[k]) MH_Moving_Matrix[2*k+1][2*k+1] = 1. ; /* separate assembly */ MH_Moving_Matrix_separate = 1 ; for (i = 0 ; i < Nbr_Formulation ; i++) { List_Read(DefineSystem_P->FormulationIndex, i, &Index_Formulation) ; Formulation_P = (struct Formulation*) List_Pointer(Problem_S.Formulation, Index_Formulation) ; Treatment_Formulation(Formulation_P) ; } MH_Moving_Matrix_separate = 0 ; } /* for iTime */ Message::Cpu("Full matrix assembly done"); for (k = 0 ; k < Current.NbrHar ; k++) Free (MH_Moving_Matrix[k]) ; Free (MH_Moving_Matrix) ; MH_Moving_Matrix = NULL ; Generate_Group = NULL; for (i = 0 ; i < NbrDof_MH_moving ; i++) { for (k = 0 ; k < Current.NbrHar ; k++) (Dof_MH_moving[i]+k)->Case.Unknown.NumDof = NumDof_MH_moving[i] + k ; } LinAlg_CreateMatrix(&DofData_P->A_MH_moving2, &DofData_P->Solver, DofData_P->NbrDof, DofData_P->NbrDof) ; LinAlg_CreateVector(&DofData_P->b_MH_moving2, &DofData_P->Solver, Current.DofData->NbrDof) ; LinAlg_ZeroMatrix(&DofData_P->A_MH_moving2) ; LinAlg_ZeroVector(&DofData_P->b_MH_moving2) ; Message::Cpu(""); nnz__=0; for (i = 0 ; i < NbrDof_MH_moving ; i++) { for (k = 0 ; k < Current.NbrHar ; k++) { row_old = Current.NbrHar*i+k ; row_new = NumDof_MH_moving[i]+k-1 ; LinAlg_GetDoubleInVector(&d, &DofData_P->b_MH_moving, row_old) ; LinAlg_SetDoubleInVector( d, &DofData_P->b_MH_moving2, row_new) ; for (j = 0 ; j < NbrDof_MH_moving ; j++) { for (l = 0 ; l < Current.NbrHar ; l++) { col_old = Current.NbrHar*j+l ; col_new = NumDof_MH_moving[j]+l-1 ; /* LinAlg_GetDoubleInMatrix(&d, &DofData_P->A_MH_moving, i, j) ; */ #if defined(HAVE_SPARSKIT) d = DofData_P->A_MH_moving.M.F.a[NbrDof_MH_moving*Current.NbrHar*col_old+row_old]; aii = DofData_P->A_MH_moving.M.F.a[NbrDof_MH_moving*Current.NbrHar*row_old+row_old]; ajj = DofData_P->A_MH_moving.M.F.a[NbrDof_MH_moving*Current.NbrHar*col_old+col_old]; #else aii = ajj = 0.; Message::Error("FIXME: Generate_MH_Moving works only with Sparskit"); break; #endif if(d*d > 1e-12 * aii*ajj && ( (DummyDof[row_new]==0 && DummyDof[col_new] == 0) || (row_new == col_new) ) ){ LinAlg_AddDoubleInMatrix(d, &DofData_P->A_MH_moving2, col_new, row_new) ; nnz__++; } } } } } printf("Matrix converted : nnz in MH_moving %d \n", nnz__); #if defined(HAVE_SPARSKIT) Free(DofData_P->A_MH_moving.M.F.a); #endif Current.DTime = 0.; Message::Cpu(""); DofData_P->DummyDof = DummyDof ; break; case OPERATION_DUMMYDOFS : Init_OperationOnSystem("DummyDofs", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; Message::Cpu(""); Dof_GetDummies(DefineSystem_P, DofData_P); Message::Cpu(""); break ; case OPERATION_ADD_MH_MOVING : LinAlg_AddMatrixMatrix(&DofData_P->A, &DofData_P->A_MH_moving2,&DofData_P->A) ; /* LinAlg_AddVectorVector(&DofData_P->b, &DofData_P->b_MH_moving2,&DofData_P->b) ; */ Message::Cpu(""); break ; /* --> S a v e S o l u t i o n E x t e n d e d M H */ /* ----------------------------------------------------------- */ case OPERATION_SAVESOLUTIONEXTENDEDMH : if (Current.NbrHar == 1) { Message::Warning("ExtendSolutionMH can only to be used with multi-harmonics") ; break ; } else if (!List_Nbr(DofData_P->Solutions)) { Message::Warning("No solution available for ExtendSolutionMH"); break ; } else if (List_Nbr(DofData_P->Solutions) > 1) { Message::Warning("Only last solution will be extended multi-harmonically and saved"); } Init_OperationOnSystem("SaveSolutionExtendedMH", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; strcpy(FileName_exMH, Name_Generic) ; strcat(FileName_exMH, Operation_P->Case.SaveSolutionExtendedMH.ResFile) ; strcat(FileName_exMH, ".res") ; Dof_WriteFileRES0(FileName_exMH, Flag_BIN) ; Dof_WriteFileRES_ExtendMH(FileName_exMH, DofData_P, Flag_BIN, Current.NbrHar + 2*Operation_P->Case.SaveSolutionExtendedMH.NbrFreq); Message::Direct(" > '%s' (%d to %d frequencies)", FileName_exMH, Current.NbrHar/2, Current.NbrHar/2 + Operation_P->Case.SaveSolutionExtendedMH.NbrFreq) ; DofData_P->CurrentSolution = (struct Solution*) List_Pointer(DofData_P->Solutions, List_Nbr(DofData_P->Solutions)-1); break ; /* --> S a v e S o l u t i o n M H T o T i m e */ /* ----------------------------------------------------------- */ case OPERATION_SAVESOLUTIONMHTOTIME : if (Current.NbrHar == 1) { Message::Warning("SaveSolutionMHtoTime can only to be used with multi-harmonics") ; break ; } else if (!List_Nbr(DofData_P->Solutions)) { Message::Warning("No solution available for SaveSolutionMHtoTime"); break ; } else if (List_Nbr(DofData_P->Solutions) > 1) { Message::Warning("Only last mult-harmonic solution will be saved for time X"); } Init_OperationOnSystem("SaveSolutionMHtoTime", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; strcpy(FileName_exMH, Name_Generic) ; strcat(FileName_exMH, Operation_P->Case.SaveSolutionMHtoTime.ResFile) ; strcat(FileName_exMH, ".res") ; Dof_WriteFileRES0(FileName_exMH, Flag_BIN) ; Dof_WriteFileRES_MHtoTime(FileName_exMH, DofData_P, Flag_BIN, Operation_P->Case.SaveSolutionMHtoTime.Time) ; Message::Direct(" > '%s' (time = %e)", FileName_exMH, Operation_P->Case.SaveSolutionMHtoTime.Time) ; DofData_P->CurrentSolution = (struct Solution*) List_Pointer(DofData_P->Solutions, List_Nbr(DofData_P->Solutions)-1); break ; /* --> R e a d S o l u t i o n */ /* ------------------------------------------ */ case OPERATION_READSOLUTION : Init_OperationOnSystem("ReadSolution", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; i = 0 ; while(Name_ResFile[i]){ Message::Info("Loading Processing data '%s'", Name_ResFile[i]) ; Dof_OpenFile(DOF_TMP, Name_ResFile[i], "rb"); Dof_ReadFileRES(NULL, DofData_P, DofData_P->Num, &Current.Time, &Current.TimeImag, &Current.TimeStep) ; Dof_CloseFile(DOF_TMP); i++ ; } if(!List_Nbr(DofData_P->Solutions)){ Message::Error("No valid data found for ReadSolution[%s]", DefineSystem_P->Name); break; } DofData_P->CurrentSolution = (struct Solution*) List_Pointer(DofData_P->Solutions, List_Nbr(DofData_P->Solutions)-1) ; Free(DofData_P->CurrentSolution->TimeFunctionValues); DofData_P->CurrentSolution->TimeFunctionValues = Get_TimeFunctionValues(DofData_P) ; break ; /* --> G m s h R e a d */ /* ------------------------------------------ */ case OPERATION_GMSHREAD : #if defined(HAVE_GMSH) if(Operation_P->Case.GmshRead.ViewTag >= 0) PView::setGlobalTag(Operation_P->Case.GmshRead.ViewTag); //GmshMergeFile(Operation_P->Case.GmshRead.FileName); //GmshOpenProject(Operation_P->Case.GmshRead.FileName); GmshMergePostProcessingFile(Operation_P->Case.GmshRead.FileName); Operation_P->Rank = -1; #else Message::Error("You need to compile GetDP with Gmsh support to use 'GmshRead'"); #endif break ; case OPERATION_GMSHCLEARALL : #if defined(HAVE_GMSH) while(PView::list.size()) delete PView::list[0]; PView::setGlobalTag(0); Operation_P->Rank = -1; #else Message::Error("You need to compile GetDP with Gmsh support to use 'GmshRead'"); #endif break ; /* --> S a v e M e s h */ /* ------------------------------------------ */ case OPERATION_SAVEMESH : Init_OperationOnSystem("SaveMesh", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; if(Operation_P->Case.SaveMesh.FileName[0] == '/' || Operation_P->Case.SaveMesh.FileName[0] == '\\'){ strcpy(FileName, Operation_P->Case.SaveMesh.FileName); } else { strcpy(FileName, Name_Path); strcat(FileName, Operation_P->Case.SaveMesh.FileName); } if (Operation_P->Case.SaveMesh.ExprIndex >= 0) { Get_ValueOfExpressionByIndex(Operation_P->Case.SaveMesh.ExprIndex, NULL, 0., 0., 0., &Value) ; char fmt[256]; strcpy(fmt, FileName); sprintf(FileName, fmt, Value.Val[0]); } Geo_SaveMesh(Current.GeoData, ((struct Group*) List_Pointer(Problem_S.Group, Operation_P->Case.SaveMesh.GroupIndex))->InitialList, FileName) ; break ; /* --> T r a n s f e r S o l u t i o n */ /* ------------------------------------------ */ case OPERATION_TRANSFERSOLUTION : Init_OperationOnSystem("TransferSolution", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; if(Resolution2_P){ /* pre-resolution */ DofData2_P = DofData2_P0 + DefineSystem_P->DestinationSystemIndex ; Dof_TransferDof(DofData_P, &DofData2_P); } else{ /* a changer!!! Il faut se mettre d'accord sur ce que doit faire Dof_TransferDof. Ceci sert a transferer la derniere solution d'un DofData dans un autre (ds la meme resolution), base sur le meme espace fonctionnel. */ DofData2_P = DofData_P0 + DefineSystem_P->DestinationSystemIndex ; if(DofData_P->NbrAnyDof != DofData2_P->NbrAnyDof){ Message::Error("Dimensions do not match for TransferSolution"); break; } Solution_S.TimeStep = (int)Current.TimeStep ; Solution_S.Time = Current.Time ; Solution_S.TimeImag = Current.TimeImag ; Solution_S.TimeFunctionValues = Get_TimeFunctionValues(DofData2_P) ; Solution_S.SolutionExist = 1 ; LinAlg_CreateVector(&Solution_S.x, &DofData2_P->Solver, DofData2_P->NbrDof) ; LinAlg_ZeroVector(&Solution_S.x) ; if (List_Nbr(DofData_P->Solutions)) { Solution_P = (struct Solution *)List_Pointer(DofData_P->Solutions, List_Nbr(DofData_P->Solutions)-1) ; for(i=0 ; iNbrAnyDof ; i++){ Dof = *(struct Dof *)List_Pointer(DofData_P->DofList, i) ; if(Dof.Type == DOF_UNKNOWN){ LinAlg_GetScalarInVector(&tmp, &Solution_P->x, Dof.Case.Unknown.NumDof-1) ; if((Dof_P = (struct Dof*)List_PQuery(DofData2_P->DofList, &Dof, fcmp_Dof))){ LinAlg_SetScalarInVector(&tmp, &Solution_S.x, Dof_P->Case.Unknown.NumDof-1) ; Dof_P->Type = DOF_UNKNOWN ; } else{ Message::Warning("Unknown Dof in TransferSolution") ; } } else{ Message::Warning("Trying to transfer a non symmetrical Dof"); } } // FIXME: required by parallel version LinAlg_AssembleVector(&Solution_S.x) ; if (!DofData2_P->Solutions) DofData2_P->Solutions = List_Create( 20, 20, sizeof(struct Solution)) ; List_Add(DofData2_P->Solutions, &Solution_S) ; DofData2_P->CurrentSolution = (struct Solution*) List_Pointer(DofData2_P->Solutions, List_Nbr(DofData2_P->Solutions)-1) ; } } break ; /* --> E v a l u a t e */ /* ------------------------------------------ */ case OPERATION_EVALUATE : Get_ValueOfExpressionByIndex(Operation_P->Case.Evaluate.ExpressionIndex, NULL, 0., 0., 0., &Value) ; break ; /* --> S e t T i m e */ /* ------------------------------------------ */ case OPERATION_SETTIME : Get_ValueOfExpressionByIndex(Operation_P->Case.SetTime.ExpressionIndex, NULL, 0., 0., 0., &Value) ; Current.Time = Value.Val[0] ; break ; /* --> S e t F r e q u e n c y */ /* ------------------------------------------ */ case OPERATION_SETFREQUENCY : DefineSystem_P = (struct DefineSystem*) List_Pointer(Resolution_P->DefineSystem, Operation_P->DefineSystemIndex) ; DofData_P = DofData_P0 + Operation_P->DefineSystemIndex ; if (DefineSystem_P->Type == VAL_COMPLEX){ if(DefineSystem_P->FrequencyValue) List_Reset(DefineSystem_P->FrequencyValue); else DefineSystem_P->FrequencyValue = List_Create(1, 1, sizeof(double)) ; /* Provisoire: une seule frequence */ Get_ValueOfExpressionByIndex(Operation_P->Case.SetFrequency.ExpressionIndex, NULL, 0., 0., 0., &Value) ; List_Add(DefineSystem_P->FrequencyValue, &Value.Val[0]); if (DofData_P->Pulsation == NULL) DofData_P->Pulsation = List_Create(1, 2, sizeof(double)) ; List_Reset(DofData_P->Pulsation); Init_HarInDofData(DefineSystem_P, DofData_P) ; } else Message::Error("Invalid SetFrequency for real system '%s'", DefineSystem_P->Name) ; break; /* --> T i m e L o o p T h e t a */ /* ------------------------------------------ */ case OPERATION_TIMELOOPTHETA : if(!List_Nbr(Current.DofData->Solutions)){ Message::Error("Not enough initial solutions for TimeLoopTheta"); break; } Message::Info("TimeLoopTheta ...") ; Save_TypeTime = Current.TypeTime ; Save_DTime = Current.DTime ; Flag_NextThetaFixed = 0 ; /* Attention: Test */ Current.TypeTime = TIME_THETA ; if(Flag_RESTART) { if (Current.Time < Operation_P->Case.TimeLoopTheta.TimeMax * 0.999999) Flag_RESTART = 0 ; } else Current.Time = Operation_P->Case.TimeLoopTheta.Time0 ; while (Current.Time < Operation_P->Case.TimeLoopTheta.TimeMax * 0.999999) { if(Message::GetOnelabAction() == "stop" || Message::GetErrorCount()) break; if (!Flag_NextThetaFixed) { /* Attention: Test */ Get_ValueOfExpressionByIndex(Operation_P->Case.TimeLoopTheta.ThetaIndex, NULL, 0., 0., 0., &Value) ; Current.Theta = Value.Val[0] ; } if (Flag_NextThetaFixed != 2) { /* Attention: Test */ Get_ValueOfExpressionByIndex(Operation_P->Case.TimeLoopTheta.DTimeIndex, NULL, 0., 0., 0., &Value) ; Current.DTime = Value.Val[0] ; } Flag_NextThetaFixed = 0 ; Current.Time += Current.DTime ; Current.TimeStep += 1. ; Message::Info(3, "Theta Time = %.8g s (TimeStep %d)", Current.Time, (int)Current.TimeStep) ; if(Message::GetProgressMeterStep() > 0 && Message::GetProgressMeterStep() < 100) Message::AddOnelabNumberChoice(Message::GetOnelabClientName() + "/Time", Current.Time); Save_Time = Current.Time ; Treatment_Operation(Resolution_P, Operation_P->Case.TimeLoopTheta.Operation, DofData_P0, GeoData_P0, NULL, NULL) ; Current.Time = Save_Time ; if(Flag_Break){ Flag_Break = 0; break; } } Current.TypeTime = Save_TypeTime ; Current.DTime = Save_DTime ; break ; /* --> T i m e L o o p N e w m a r k */ /* ------------------------------------------ */ case OPERATION_TIMELOOPNEWMARK : if(List_Nbr(Current.DofData->Solutions) < 2){ Message::Error("Not enough initial solutions for TimeLoopNewmark"); break; } Message::Info("TimeLoopNewmark ...") ; Save_TypeTime = Current.TypeTime ; Save_DTime = Current.DTime ; Current.Beta = Operation_P->Case.TimeLoopNewmark.Beta ; Current.Gamma = Operation_P->Case.TimeLoopNewmark.Gamma ; Current.TypeTime = TIME_NEWMARK ; if(Flag_RESTART){ if (Current.Time < Operation_P->Case.TimeLoopNewmark.TimeMax * 0.999999) Flag_RESTART = 0 ; } else Current.Time = Operation_P->Case.TimeLoopNewmark.Time0 ; while (Current.Time < Operation_P->Case.TimeLoopNewmark.TimeMax * 0.999999) { if(Message::GetOnelabAction() == "stop" || Message::GetErrorCount()) break; Get_ValueOfExpressionByIndex(Operation_P->Case.TimeLoopNewmark.DTimeIndex, NULL, 0., 0., 0., &Value) ; Current.DTime = Value.Val[0] ; Current.Time += Current.DTime ; Current.TimeStep += 1. ; Message::Info(3, "Newmark Time = %.8g s (TimeStep %d)", Current.Time, (int)Current.TimeStep) ; if(Message::GetProgressMeterStep() > 0 && Message::GetProgressMeterStep() < 100) Message::AddOnelabNumberChoice(Message::GetOnelabClientName() + "/Time", Current.Time); Treatment_Operation(Resolution_P, Operation_P->Case.TimeLoopNewmark.Operation, DofData_P0, GeoData_P0, NULL, NULL) ; if(Flag_Break){ Flag_Break = 0; break; } } Current.TypeTime = Save_TypeTime ; Current.DTime = Save_DTime ; break ; /* --> I t e r a t i v e L o o p */ /* ------------------------------------------ */ case OPERATION_ITERATIVELOOP : Message::Info("IterativeLoop ...") ; Save_Iteration = Current.Iteration ; for (Num_Iteration = 1 ; Num_Iteration <= Operation_P->Case.IterativeLoop.NbrMaxIteration ; Num_Iteration++) { if(Message::GetOnelabAction() == "stop" || Message::GetErrorCount()) break; Current.Iteration = (double)Num_Iteration ; Current.RelativeDifference = 0. ; Get_ValueOfExpressionByIndex (Operation_P->Case.IterativeLoop.RelaxationFactorIndex, NULL, 0., 0., 0., &Value) ; if(Current.RelaxationFactor != Value.Val[0] || Num_Iteration == 1){ Current.RelaxationFactor = Value.Val[0] ; Message::Info("Non Linear Iteration Relaxation %g", Current.RelaxationFactor) ; } Flag_IterativeLoop = Operation_P->Case.IterativeLoop.Flag ; /* Attention: Test */ // Resolution2_P and DofData2_P0 added as arguments for allowing TransferSolution of a nonlinear resolution Treatment_Operation(Resolution_P, Operation_P->Case.IterativeLoop.Operation, DofData_P0, GeoData_P0, Resolution2_P, DofData2_P0) ; if (Current.RelativeDifference <= Operation_P->Case.IterativeLoop.Criterion) break ; if(Flag_Break){ Flag_Break = 0; break; } Current.RelativeDifferenceOld = Current.RelativeDifference ; /* Attention: pt */ } if (Num_Iteration > Operation_P->Case.IterativeLoop.NbrMaxIteration){ Num_Iteration = Operation_P->Case.IterativeLoop.NbrMaxIteration ; Flag_IterativeLoopConverged = 0; Message::Info(3, "IterativeLoop did not converge (%d iterations, residual %g)", Num_Iteration, Current.RelativeDifference); } else{ Message::Info(3, "IterativeLoop converged (%d iteration%s, residual %g)", Num_Iteration, Num_Iteration > 1 ? "s" : "", Current.RelativeDifference); } Current.Iteration = Save_Iteration ; break ; case OPERATION_ITERATIVELINEARSOLVER : Message::Info("IterativeLinearSolver ...") ; Operation_IterativeLinearSolver (Resolution_P, Operation_P, DofData_P0, GeoData_P0) ; break; /* --> I t e r a t i v e T i m e R e d u c t i o n */ /* ------------------------------------------------ */ case OPERATION_ITERATIVETIMEREDUCTION : Message::Info("IterativeTimeReduction ...") ; Operation_IterativeTimeReduction (Resolution_P, Operation_P, DofData_P0, GeoData_P0) ; break ; /* --> T e s t */ /* ------------------------------------------ */ case OPERATION_TEST : Message::Info("Test") ; Get_ValueOfExpressionByIndex(Operation_P->Case.Test.ExpressionIndex, NULL, 0., 0., 0., &Value) ; if(Value.Val[0]){ Treatment_Operation(Resolution_P, Operation_P->Case.Test.Operation_True, DofData_P0, GeoData_P0, NULL, NULL) ; } else{ if(Operation_P->Case.Test.Operation_False) Treatment_Operation(Resolution_P, Operation_P->Case.Test.Operation_False, DofData_P0, GeoData_P0, NULL, NULL) ; } break ; /* --> F o u r i e r T r a n s f o r m */ /* ------------------------------------------ */ case OPERATION_FOURIERTRANSFORM2 : Message::Info("FourierTransform") ; if(gSCALAR_SIZE == 2){ Message::Error("FIXME: FourierTransform2 will not work in complex arithmetic"); break; } DofData_P = DofData_P0 + Operation_P->Case.FourierTransform2.DefineSystemIndex[0] ; DofData2_P = DofData_P0 + Operation_P->Case.FourierTransform2.DefineSystemIndex[1] ; NbrHar1 = DofData_P->NbrHar ; NbrDof1 = List_Nbr(DofData_P->DofList) ; NbrHar2 = DofData2_P->NbrHar ; NbrDof2 = List_Nbr(DofData2_P->DofList) ; if (NbrHar1 != 1 || NbrHar2 < 2 || NbrDof2 != (NbrDof1*NbrHar2)){ Message::Error("Uncompatible System definitions for FourierTransform" " (NbrHar = %d|%d NbrDof = %d|%d)", NbrHar1, NbrHar2, NbrDof1, NbrDof2) ; break; } if(!DofData2_P->Solutions){ DofData2_P->Solutions = List_Create(1, 1, sizeof(struct Solution)) ; Operation_P->Case.FourierTransform2.Scales = (double *)Malloc(NbrHar2*sizeof(double)) ; } Nbr_Sol = List_Nbr(DofData2_P->Solutions) ; Scales = Operation_P->Case.FourierTransform2.Scales ; if ( (Operation_P->Case.FourierTransform2.Period_sofar + Current.DTime > Operation_P->Case.FourierTransform2.Period) && Nbr_Sol ) { Message::Info("Normalizing and finalizing Fourier Analysis" " (solution %d) (Period: %e out of %e)", Nbr_Sol, Operation_P->Case.FourierTransform2.Period_sofar, Operation_P->Case.FourierTransform2.Period); for (i=0 ; iSolutions, Nbr_Sol-1); for(j=0 ; jNbrDof ; j+=NbrHar2){ NumDof = ((struct Dof *)List_Pointer(DofData2_P->DofList,j))->Case.Unknown.NumDof - 1 ; for(k=0 ; kx, NumDof+k) ; if (Scales[k]) d1 /= Scales[k] ; LinAlg_SetDoubleInVector(d1, &Solution_P->x, NumDof+k) ; } } Operation_P->Case.FourierTransform2.Period_sofar = 0 ; break; } if (Operation_P->Case.FourierTransform2.Period_sofar == 0) { Message::Info("Starting new Fourier Analysis : solution %d ", Nbr_Sol); Solution_S.TimeStep = Nbr_Sol; Solution_S.Time = Nbr_Sol; Solution_S.TimeFunctionValues = NULL; Solution_S.SolutionExist = 1 ; LinAlg_CreateVector(&Solution_S.x, &DofData2_P->Solver, DofData2_P->NbrDof) ; LinAlg_ZeroVector(&Solution_S.x) ; List_Add(DofData2_P->Solutions, &Solution_S) ; Nbr_Sol++ ; for (k=0 ; kCurrentSolution = Solution_P = (struct Solution*)List_Pointer(DofData2_P->Solutions, Nbr_Sol-1) ; for (k=0 ; kVal_Pulsation[k/2] * Current.Time ; Scales[k ] += cos(d) * cos(d) * Current.DTime ; Scales[k+1] += sin(d) * sin(d) * Current.DTime ; } for(j=0 ; jDofList,j), &dd) ; NumDof = ((struct Dof *)List_Pointer(DofData2_P->DofList, j*NbrHar2))->Case.Unknown.NumDof - 1 ; if (((struct Dof *)List_Pointer(DofData2_P->DofList,j*NbrHar2))->Type != DOF_UNKNOWN) Message::Info("Dof not unknown %d", j) ; for (k=0 ; kVal_Pulsation[k/2] * Current.Time ; LinAlg_AddDoubleInVector( dd*cos(d)*Current.DTime, &Solution_P->x, NumDof+k ) ; LinAlg_AddDoubleInVector(-dd*sin(d)*Current.DTime, &Solution_P->x, NumDof+k+1) ; } } Operation_P->Case.FourierTransform2.Period_sofar += Current.DTime ; break; case OPERATION_FOURIERTRANSFORM : Message::Info("FourierTransform") ; DofData_P = DofData_P0 + Operation_P->Case.FourierTransform.DefineSystemIndex[0] ; DofData2_P = DofData_P0 + Operation_P->Case.FourierTransform.DefineSystemIndex[1] ; if(!DofData2_P->Solutions){ k = List_Nbr(Operation_P->Case.FourierTransform.Frequency) ; if(DofData2_P->NbrDof != gCOMPLEX_INCREMENT * DofData_P->NbrDof){ Message::Error("Uncompatible System definitions for FourierTransform") ; break; } DofData2_P->Solutions = List_Create(k, 1, sizeof(struct Solution)) ; for(i=0 ; iCase.FourierTransform.Frequency, i, &d) ; Solution_S.TimeStep = i ; Solution_S.Time = TWO_PI * d; Solution_S.TimeImag = 0.; Solution_S.TimeFunctionValues = NULL; Solution_S.SolutionExist = 1 ; LinAlg_CreateVector(&Solution_S.x, &DofData2_P->Solver, DofData2_P->NbrDof) ; LinAlg_ZeroVector(&Solution_S.x) ; List_Add(DofData2_P->Solutions, &Solution_S) ; } DofData2_P->CurrentSolution = (struct Solution*)List_Pointer(DofData2_P->Solutions, k/2) ; } for(i=0 ; iSolutions) ; i++){ Solution_P = (struct Solution*)List_Pointer(DofData2_P->Solutions, i); d = Solution_P->Time * Current.Time ; for(j=0,k=0 ; jNbrDof ; j++,k+=gCOMPLEX_INCREMENT){ LinAlg_GetDoubleInVector(&d2, &DofData_P->CurrentSolution->x, j); LinAlg_AddComplexInVector( d2 * cos(d) * Current.DTime, -d2 * sin(d) * Current.DTime, &Solution_P->x, k, k+1) ; } } break; /* --> P r i n t / W r i t e */ /* ------------------------------------------ */ case OPERATION_WRITE : Flag_Binary = 1 ; case OPERATION_PRINT : if(Operation_P->Case.Print.FileOut){ if(Operation_P->Case.Print.FileOut[0] == '/' || Operation_P->Case.Print.FileOut[0] == '\\'){ strcpy(FileName, Operation_P->Case.Print.FileOut); } else{ strcpy(FileName, Name_Path); strcat(FileName, Operation_P->Case.Print.FileOut); } if(!(fp = FOpen(FileName, "ab"))){ Message::Error("Unable to open file '%s'", FileName) ; break; } Message::Info("Print -> '%s'", FileName) ; } else{ fp = stdout ; Message::Info("Print") ; } if(Operation_P->Case.Print.Expression){ for(i=0 ; iCase.Print.Expression) ; i++){ j = *(int*)List_Pointer(Operation_P->Case.Print.Expression, i) ; Get_ValueOfExpressionByIndex(j, NULL, 0., 0., 0., &Value) ; Print_Value(&Value) ; } } else if (Operation_P->Case.Print.DofNumber){ DofData_P = DofData_P0 + Operation_P->DefineSystemIndex ; for(i=0 ; iCase.Print.DofNumber) ; i++){ j = *(int*)List_Pointer(Operation_P->Case.Print.DofNumber, i) ; if(j>=0 && jNbrDof){ if(Operation_P->Case.Print.TimeStep) for(k=0 ; kCase.Print.TimeStep) ; k++){ l = *(int*)List_Pointer(Operation_P->Case.Print.TimeStep, k) ; if(l>=0 && lSolutions)){ Solution_P = (struct Solution*)List_Pointer(DofData_P->Solutions, l) ; LinAlg_GetScalarInVector(&tmp, &Solution_P->x, j) ; if(Flag_Binary){ LinAlg_WriteScalar(fp, &tmp) ; } else{ LinAlg_PrintScalar(fp, &tmp) ; fprintf(fp, " ") ; } } else Message::Warning("Print of Dof out of TimeStep range [0,%d]", List_Nbr(DofData_P->Solutions)-1); } else{ LinAlg_GetScalarInVector(&tmp, &DofData_P->CurrentSolution->x, j) ; if(Flag_Binary){ LinAlg_WriteScalar(fp, &tmp) ; } else{ LinAlg_PrintScalar(fp, &tmp) ; fprintf(fp, " ") ; } } } else Message::Warning("Wrong number of Dof to Print (%d is out of [0,%d])", j, DofData_P->NbrDof-1); } fprintf(fp, "\n") ; } else{ DofData_P = DofData_P0 + Operation_P->DefineSystemIndex ; if(Flag_Binary){ LinAlg_WriteMatrix(fp, &DofData_P->A) ; LinAlg_WriteVector(fp, &DofData_P->b) ; } else{ // use matlab format if available DefineSystem_P = (struct DefineSystem*) List_Pointer(Resolution_P->DefineSystem, Operation_P->DefineSystemIndex) ; std::string path(Name_Path), file("file_"), mat("mat_"), vec("vec_"); std::string name(Operation_P->Case.Print.FileOut ? Operation_P->Case.Print.FileOut : DefineSystem_P->Name); LinAlg_PrintMatrix(fp, &DofData_P->A, true, (path + file + mat + name + ".m").c_str(), (mat + name).c_str()) ; LinAlg_PrintVector(fp, &DofData_P->b, true, (path + file + vec + name + ".m").c_str(), (vec + name).c_str()) ; } } fflush(fp); if(Operation_P->Case.Print.FileOut){ fclose(fp); fp = stdout ; } Flag_Binary = 0; break; /* --> C h a n g e O f C o o r d i n a t e s */ /* ------------------------------------------ */ case OPERATION_CHANGEOFCOORDINATES : Message::Info("ChangeOfCoordinates") ; /* Geo_SetCurrentGeoData(Current.GeoData = GeoData_P0) ; */ Operation_ChangeOfCoordinates (Resolution_P, Operation_P, DofData_P0, GeoData_P0) ; break ; /* --> D e f o r m e M e s h */ /* ------------------------------------------ */ case OPERATION_DEFORMEMESH : if (Operation_P->Case.DeformeMesh.Name_MshFile == NULL) Operation_P->Case.DeformeMesh.Name_MshFile = Name_MshFile ; Message::Info("DeformeMesh[%s, %s, '%s']", ((struct DefineSystem *) List_Pointer(Resolution_P->DefineSystem, Operation_P->DefineSystemIndex))->Name, Operation_P->Case.DeformeMesh.Quantity, Operation_P->Case.DeformeMesh.Name_MshFile) ; if ((i = List_ISearchSeq(GeoData_L, Operation_P->Case.DeformeMesh.Name_MshFile, fcmp_GeoData_Name)) < 0){ Message::Error("DeformeMesh: Wrong NameOfMeshFile %s", Operation_P->Case.DeformeMesh.Name_MshFile); break; } Operation_P->Case.DeformeMesh.GeoDataIndex = i ; Operation_DeformeMesh (Resolution_P, Operation_P, DofData_P0, GeoData_P0) ; break; /* --> P o s t O p e r a t i o n */ /* ------------------------------- */ case OPERATION_POSTOPERATION : #ifdef TIMER {double tstart = MPI_Wtime(); #endif Message::Info("PostOperation") ; Operation_PostOperation(Resolution_P, DofData_P0, GeoData_P0, Operation_P->Case.PostOperation.PostOperations); #ifdef TIMER double timer = MPI_Wtime() - tstart; printf("Proc %d, time spent in PostOperation %.16g\n", Message::GetCommRank(), timer); } #endif break ; /* --> D e l e t e F i l e */ /* ------------------------- */ case OPERATION_DELETEFILE : Message::Info("DeleteFile[%s]", Operation_P->Case.DeleteFile.FileName) ; RemoveFile(Operation_P->Case.DeleteFile.FileName); break ; /* --> C r e a t e D i r */ /* ------------------------ */ case OPERATION_CREATEDIR : Message::Info("CreateDir[%s]", Operation_P->Case.CreateDir.DirName) ; CreateDir(Operation_P->Case.CreateDir.DirName); break ; /* --> T i m e L o o p A d a p t i v e */ /* ------------------------------------- */ case OPERATION_TIMELOOPADAPTIVE : Message::Info("TimeLoopAdaptve ...") ; Save_TypeTime = Current.TypeTime ; Save_DTime = Current.DTime ; Operation_TimeLoopAdaptive(Resolution_P, Operation_P, DofData_P0, GeoData_P0, &Flag_Break) ; Current.TypeTime = Save_TypeTime ; Current.DTime = Save_DTime ; break; /* --> I t e r a t i v e L o o p N */ /* ------------------------------------------ */ case OPERATION_ITERATIVELOOPN : Message::Info("IterativeLoopN ...") ; Save_Iteration = Current.Iteration ; Operation_IterativeLoopN(Resolution_P, Operation_P, DofData_P0, GeoData_P0, Resolution2_P, DofData2_P0, &Flag_Break) ; Current.Iteration = Save_Iteration ; break; /* --> T i m e L o o p R u n g e K u t t a */ /* ----------------------------------------- */ case OPERATION_TIMELOOPRUNGEKUTTA : { Init_OperationOnSystem("TimeLoopRungeKutta", Resolution_P, Operation_P, DofData_P0, GeoData_P0, &DefineSystem_P, &DofData_P, Resolution2_P) ; int numStepRK = List_Nbr(Operation_P->Case.TimeLoopRungeKutta.ButcherC); if(numStepRK != List_Nbr(Operation_P->Case.TimeLoopRungeKutta.ButcherB) || numStepRK * numStepRK != List_Nbr(Operation_P->Case.TimeLoopRungeKutta.ButcherA)){ Message::Error("Incompatible sizes of Butcher Tableaux"); break; } Current.Time = Operation_P->Case.TimeLoopRungeKutta.Time0 ; gVector xn, rhs; LinAlg_CreateVector(&xn, &DofData_P->Solver, Current.DofData->NbrDof); LinAlg_CreateVector(&rhs, &DofData_P->Solver, Current.DofData->NbrDof); std::vector ki(numStepRK); for(int i = 0; i < numStepRK; i++) LinAlg_CreateVector(&ki[i], &DofData_P->Solver, Current.DofData->NbrDof); while (Current.Time < Operation_P->Case.TimeLoopRungeKutta.TimeMax * 0.9999999) { if(Message::GetOnelabAction() == "stop" || Message::GetErrorCount()) break; double tn = Current.Time; LinAlg_CopyVector(&DofData_P->CurrentSolution->x, &xn); Get_ValueOfExpressionByIndex(Operation_P->Case.TimeLoopRungeKutta.DTimeIndex, NULL, 0., 0., 0., &Value) ; Current.DTime = Value.Val[0]; Current.TimeStep += 1.; for(int i = 0; i < numStepRK; i++){ double ci; List_Read(Operation_P->Case.TimeLoopRungeKutta.ButcherC, i, &ci); Current.Time = tn + ci * Current.DTime; LinAlg_CopyVector(&xn, &DofData_P->CurrentSolution->x); // FIXME: warning, this assumes an explicit RK scheme! for(int j = 0; j < i; j++){ double aij; List_Read(Operation_P->Case.TimeLoopRungeKutta.ButcherA, i * numStepRK + j, &aij); LinAlg_AddVectorProdVectorDouble(&DofData_P->CurrentSolution->x, &ki[j], aij, &DofData_P->CurrentSolution->x); } Current.TypeAssembly = ASSEMBLY_SEPARATE ; Init_SystemData(DofData_P, Flag_Jac) ; Generate_System(DefineSystem_P, DofData_P, DofData_P0, Flag_Jac, 1); LinAlg_ProdMatrixVector(&DofData_P->M1, &DofData_P->CurrentSolution->x, &rhs); LinAlg_ProdVectorDouble(&rhs, -1., &rhs); LinAlg_AddVectorProdVectorDouble(&rhs, &DofData_P->b, 1., &rhs); LinAlg_ProdVectorDouble(&rhs, Current.DTime, &rhs); LinAlg_Solve(&DofData_P->M2, &rhs, &DofData_P->Solver, &ki[i]) ; } // restore previous time step LinAlg_CopyVector(&xn, &((struct Solution*) List_Pointer(DofData_P->Solutions, List_Nbr(DofData_P->Solutions)-2))->x) ; LinAlg_CopyVector(&xn, &DofData_P->CurrentSolution->x); for(int i = 0; i < numStepRK; i++){ double bi; List_Read(Operation_P->Case.TimeLoopRungeKutta.ButcherB, i, &bi); LinAlg_AddVectorProdVectorDouble(&DofData_P->CurrentSolution->x, &ki[i], bi, &DofData_P->CurrentSolution->x); } Current.Time = tn + Current.DTime; if(Flag_Break){ Flag_Break = 0; break; } } } break ; case OPERATION_BREAK : Flag_Break = 1; break ; /* --> P a r a l l e l C o m p u t i n g */ /* ------------------------------------------ */ case OPERATION_SETCOMMSELF : LinAlg_SetCommSelf(); break ; case OPERATION_SETCOMMWORLD : LinAlg_SetCommWorld(); break ; case OPERATION_BARRIER : #if defined(HAVE_PETSC) Message::Info("Barrier: waiting"); MPI_Barrier(PETSC_COMM_WORLD); Message::Info("Barrier: let's continue"); #endif break ; /* --> O t h e r */ /* ------------------------------------------ */ default : Message::Warning("Operation: ? ? ?") ; break ; } if(Flag_CPU) Message::Cpu(""); } Message::Barrier(); } getdp-2.4.2-source/Legacy/BF_Node_3.cpp000644 001750 001750 00000022167 12116424202 021170 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "ProData.h" #include "Message.h" /* ------------------------------------------------------------------------ */ /* B F _ N o d e _ 3 */ /* ------------------------------------------------------------------------ */ /* ------- */ /* Edges */ /* ------- */ #define WrongNumEntity Message::Error("Wrong Edge number in 'BF_Node_3E'") void BF_Node_3E(struct Element * Element, int NumEntity, double u, double v, double w, double *s) { switch (Element->Type) { case LINE : switch(NumEntity) { case 1 : *s = 0.25 * (1.-u) * (1.+u) * (-u) ; break ; default : WrongNumEntity ; } break ; case TRIANGLE : switch(NumEntity) { case 1 : *s = (1.-u-v) * u * (1.-2*u-v) ; break ; case 2 : *s = (1.-u-v) * v * (1.-u-2*v) ; break ; case 3 : *s = u * v * (u-v) ; break ; default : WrongNumEntity ; } break ; case QUADRANGLE : switch(NumEntity) { default : Message::Error("BF_Node_3E not ready for QUADRANGLE"); } break ; case TETRAHEDRON : switch(NumEntity) { case 1 : *s = (1.-u-v-w) * u * (1.-2*u-v-w) ; break ; case 2 : *s = (1.-u-v-w) * v * (1.-u-2*v-w) ; break ; case 3 : *s = (1.-u-v-w) * w * (1.-u-v-2*w) ; break ; case 4 : *s = u * v * (u-v) ; break ; case 5 : *s = u * w * (u-w) ; break ; case 6 : *s = v * w * (v-w) ; break ; default : WrongNumEntity ; } break ; case HEXAHEDRON : switch(NumEntity) { default : Message::Error("BF_Node_3E not ready for HEXAHEDRON"); } break ; case PRISM : switch(NumEntity) { default : Message::Error("BF_Node_3E not ready for PRISM"); } break ; case PYRAMID : switch(NumEntity) { default : Message::Error("BF_Node_3E not ready for PYRAMID"); } break ; default : Message::Error("Unknown type of Element in BF_Node_3E"); break ; } if (Element->GeoElement->NumEdges[NumEntity-1] < 0) *s = -*s ; } #undef WrongNumEntity /* -------- */ /* Facets */ /* -------- */ #define WrongNumEntity Message::Error("Wrong Face number in 'BF_Node_3F'") void BF_Node_3F(struct Element * Element, int NumEntity, double u, double v, double w, double *s) { switch (Element->Type) { case LINE : Message::Error("BF_Node_3F cannot be associated with this type of element"); break; case TRIANGLE : switch(NumEntity) { case 1 : *s = (1.-u-v) * u * v ; break ; default : WrongNumEntity ; } break ; case QUADRANGLE : switch(NumEntity) { default : Message::Error("BF_Node_3F not ready for QUADRANGLE"); } break ; case TETRAHEDRON : switch(NumEntity) { case 1 : *s = (1.-u-v-w) * u * w ; break ; case 2 : *s = (1.-u-v-w) * v * u ; break ; case 3 : *s = (1.-u-v-w) * w * v ; break ; case 4 : *s = u * v * w ; break ; default : WrongNumEntity ; } break ; case HEXAHEDRON : switch(NumEntity) { default : Message::Error("BF_Node_3F not ready for HEXAHEDRON"); } break ; case PRISM : switch(NumEntity) { default : Message::Error("BF_Node_3F not ready for PRISM"); } break ; default : Message::Error("Unknown Element Type in BF_Node_3F"); break ; } } #undef WrongNumEntity /* -------- */ /* Volume */ /* -------- */ void BF_Node_3V(struct Element * Element, int NumEntity, double u, double v, double w, double *s) { switch (Element->Type) { case LINE : case TRIANGLE : case QUADRANGLE : case TETRAHEDRON : Message::Error("BF_Node_3V cannot be associated with this type of element"); break; case HEXAHEDRON : switch(NumEntity) { default : Message::Error("BF_Node_3V not ready for HEXAHEDRON"); } break ; case PRISM : switch(NumEntity) { default : Message::Error("BF_Node_3V not ready for PRISM"); } break ; default : Message::Error("Unknown type of Element in BF_Node_3V"); break ; } } /* ------------------------------------------------------------------------ */ /* B F _ G r a d N o d e _ 3 */ /* ------------------------------------------------------------------------ */ /* ------- */ /* Edges */ /* ------- */ #define WrongNumEntity Message::Error("Wrong Edge number in 'BF_GradNode_3E'") void BF_GradNode_3E(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { switch (Element->Type) { case LINE : switch(NumEntity) { case 1 : s[0] = -0.25 + 0.75 * u * u ; s[1] = 0. ; s[2] = 0. ; break ; default : WrongNumEntity ; } break ; case TRIANGLE : switch(NumEntity) { case 1 : s[0] = 1.0-6.0*u-2.0*v+6.0*u*u+6.0*u*v+v*v ; s[1] = -2.0*u+3.0*u*u+2.0*u*v ; s[2] = 0. ; break ; case 2 : s[0] = -2.0*v+2.0*u*v+3.0*v*v ; s[1] = 1.0-2.0*u-6.0*v+u*u+6.0*u*v+6.0*v*v ; s[2] = 0. ; break ; case 3 : s[0] = 2.0*u*v-v*v ; s[1] = u*u-2.0*u*v ; s[2] = 0. ; break ; default : WrongNumEntity ; } break ; case QUADRANGLE : switch(NumEntity) { default : Message::Error("BF_GradNode_3E not ready for QUADRANGLE"); } break ; case TETRAHEDRON : switch(NumEntity) { case 1 : s[0] = 1.0-6.0*u-2.0*v-2.0*w+6.0*u*u+6.0*u*v+6.0*u*w+v*v+2.0*v*w+w*w ; s[1] = -2.0*u+3.0*u*u+2.0*u*v+2.0*u*w ; s[2] = -2.0*u+3.0*u*u+2.0*u*v+2.0*u*w ; break ; case 2 : s[0] = -2.0*v+2.0*u*v+3.0*v*v+2.0*v*w ; s[1] = 1.0-2.0*u-6.0*v-2.0*w+u*u+6.0*u*v+2.0*u*w+6.0*v*v+6.0*v*w+w*w ; s[2] = -2.0*v+2.0*u*v+3.0*v*v+2.0*v*w ; break ; case 3 : s[0] = -2.0*w+2.0*u*w+2.0*v*w+3.0*w*w ; s[1] = -2.0*w+2.0*u*w+2.0*v*w+3.0*w*w ; s[2] = 1.0-2.0*u-2.0*v-6.0*w+u*u+2.0*u*v+6.0*u*w+v*v+6.0*v*w+6.0*w*w ; break ; case 4 : s[0] = 2.0*u*v-v*v ; s[1] = u*u-2.0*u*v ; s[2] = 0.0 ; break ; case 5 : s[0] = 2.0*u*w-w*w ; s[1] = 0.0 ; s[2] = u*u-2.0*u*w ; break ; case 6 : s[0] = 0.0 ; s[1] = 2.0*v*w-w*w ; s[2] = v*v-2.0*v*w ; break ; default : WrongNumEntity ; } break ; case HEXAHEDRON : switch(NumEntity) { default : Message::Error("BF_GradNode_3E not ready for HEXAHEDRON"); } break ; case PRISM : switch(NumEntity) { default : Message::Error("BF_GradNode_3E not ready for PRISM"); } break ; default : Message::Error("Unkown type of Element in BF_GradNode_3E"); break ; } if (Element->GeoElement->NumEdges[NumEntity-1] < 0) { s[0] = - s[0] ; s[1] = - s[1] ; s[2] = - s[2] ; } } #undef WrongNumEntity /* -------- */ /* Facets */ /* -------- */ #define WrongNumEntity Message::Error("Wrong Face number in 'BF_GradNode_3F'") void BF_GradNode_3F(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { switch (Element->Type) { case LINE : Message::Error("BF_GradNode_3F cannot be associated with this type of element"); break ; case TRIANGLE : switch(NumEntity) { case 1 : s[0] = v-2.0*u*v-v*v ; s[1] = u-u*u-2.0*u*v ; s[2] = 0. ; break ; default : WrongNumEntity ; } break ; case QUADRANGLE : switch(NumEntity) { default : Message::Error("BF_GradNode_3F not ready for QUADRANGLE"); } break ; case TETRAHEDRON : switch(NumEntity) { case 1 : s[0] = w-2.0*u*w-v*w-w*w ; s[1] = -u*w ; s[2] = u-u*u-u*v-2.0*u*w ; break ; case 2 : s[0] = v-2.0*u*v-v*v-v*w ; s[1] = u-u*u-2.0*u*v-u*w ; s[2] = -u*v ; break ; case 3 : s[0] = -v*w ; s[1] = w-u*w-2.0*v*w-w*w ; s[2] = v-u*v-v*v-2.0*v*w ; break ; case 4 : s[0] = v*w ; s[1] = u*w ; s[2] = u*v ; break ; default : WrongNumEntity ; } break ; case HEXAHEDRON : switch(NumEntity) { default : Message::Error("BF_GradNode_3F not ready for HEXAHEDRON"); } break ; case PRISM : switch(NumEntity) { default : Message::Error("BF_GradNode_3F not ready for PRISM"); } break ; default : Message::Error("Unkown type of Element in BF_GradNode_3F"); break ; } } #undef WrongNumEntity /* -------- */ /* Volume */ /* -------- */ void BF_GradNode_3V(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { switch (Element->Type) { case LINE : case TRIANGLE : case QUADRANGLE : case TETRAHEDRON : Message::Error("BF_GradNode_3V cannot be associated with this type of element"); break; case HEXAHEDRON : switch(NumEntity) { default : Message::Error("BF_GradNode_3V not ready for HEXAHEDRON"); } break ; case PRISM : switch(NumEntity) { default : Message::Error("BF_GradNode_3V not ready for PRISM"); } break ; default : Message::Error("Unkown type of Element in BF_GradNode_3V"); break ; } } getdp-2.4.2-source/Legacy/GF_HelmholtzxForm.cpp000644 001750 001750 00000013171 12116424202 023043 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Ruth Sabariego // #include #include "ProData.h" #include "ProDefine.h" #include "BF.h" #include "GF.h" #include "Gauss.h" #include "GeoData.h" #include "Message.h" #define SQU(a) ((a)*(a)) #define CUB(a) ((a)*(a)*(a)) #define ONE_OVER_TWO_PI 1.5915494309189534E-01 #define MAX_NODES 6 #define EPSILON 1.e-10 /* ------------------------------------------------------------------------ */ /* G F _ H e l m h o l t z x F o r m */ /* ------------------------------------------------------------------------ */ void GF_HelmholtzxForm(GF_ARGX) { double xs[MAX_NODES], ys[MAX_NODES], zs[MAX_NODES], u[3], v[3], n[3], l2[2]; double xl, yl, zl ; int i, j = 1 ; int i_IntPoint, NGT_Points = 7; double a, b, c, d, us, vs, ws, usi, vsi, wsi, Ri, wghti; double s0m, s0p, s1m, s1p, s2m, s2p, t00, t10, t20, t0m, t0p, t1p; double r00, r10, r20, r0p, r0m, r1p, f0, f1, f2, B0, B1, B2 ; double IS, valr, vali ; switch ((int)Fct->Para[0]) { case _3D : switch (Element->ElementSource->Type) { case TRIANGLE : case QUADRANGLE : xs[0] = Element->ElementSource->x[0] ; ys[0] = Element->ElementSource->y[0] ; zs[0] = Element->ElementSource->z[0] ; xs[1] = Element->ElementSource->x[1] ; ys[1] = Element->ElementSource->y[1] ; zs[1] = Element->ElementSource->z[1] ; xs[2] = Element->ElementSource->x[2] ; ys[2] = Element->ElementSource->y[2] ; zs[2] = Element->ElementSource->z[2] ; valr = 0. ; vali = 0. ; IS = 0. ; if (Element->ElementSource->Type == QUADRANGLE) { xs[3] = Element->ElementSource->x[3] ; ys[3] = Element->ElementSource->y[3] ; zs[3] = Element->ElementSource->z[3] ; j = 0 ; }; for(i = j; i < 2; i++){ /* triangle side lengths */ a = sqrt(SQU(xs[1]-xs[0]) + SQU(ys[1]-ys[0]) + SQU(zs[1]-zs[0])); b = sqrt(SQU(xs[2]-xs[1]) + SQU(ys[2]-ys[1]) + SQU(zs[2]-zs[1])); c = sqrt(SQU(xs[2]-xs[0]) + SQU(ys[2]-ys[0]) + SQU(zs[2]-zs[0])); /* local system (u,v,w) centered at (xs[0],ys[0],zs[0]) */ u[0] = (xs[1]-xs[0])/a; u[1] = (ys[1]-ys[0])/a; u[2] = (zs[1]-zs[0])/a; /* triangle normal */ Geo_CreateNormal(Element->ElementSource->Type,xs,ys,zs,n); v[0] = n[1]*u[2]-n[2]*u[1]; v[1] = n[2]*u[0]-n[0]*u[2]; v[2] = n[0]*u[1]-n[1]*u[0]; l2[0] = (xs[2]-xs[0])*u[0] + (ys[2]-ys[0])*u[1] + (zs[2]-zs[0])*u[2]; /*u2 coordinate*/ l2[1] = (xs[2]-xs[0])*v[0] + (ys[2]-ys[0])*v[1] + (zs[2]-zs[0])*v[2]; /*triangle height, v2 coordinate*/ /* local coordinates of the observation point (xl, yl, zl)*/ xl = u[0] * (x-xs[0]) + u[1] * (y-ys[0]) + u[2] * (z-zs[0]); yl = v[0] * (x-xs[0]) + v[1] * (y-ys[0]) + v[2] * (z-zs[0]); zl = n[0] * (x-xs[0]) + n[1] * (y-ys[0]) + n[2] * (z-zs[0]); s0m = -( (a-xl) * (a-l2[0]) + yl*l2[1] ) / b; s0p = s0m + b; s1p = ( xl * l2[0] + yl * l2[1] ) / c; s1m = s1p - c; s2m = - xl; s2p = a - xl; /*distance observation point projection on triangle plane to triangle local vertices*/ t00 = (yl * (l2[0]-a) + l2[1] * (a-xl)) / b; t10 = (xl * l2[1] - yl * l2[0]) / c; t20 = yl; t0m = sqrt((a-xl)*(a-xl) + yl*yl); t0p = sqrt((l2[0]-xl)*(l2[0]-xl) + (l2[1]-yl)*(l2[1]-yl)); t1p = sqrt(xl*xl + yl*yl); /* minimum distances from the observation point to each triangle side*/ r00 = sqrt(SQU(t00) + SQU(zl)); r10 = sqrt(SQU(t10) + SQU(zl)); r20 = sqrt(SQU(t20) + SQU(zl)); /* distances from observation point to the vertices*/ r0p = sqrt(SQU(t0p) + SQU(zl)); r0m = sqrt(SQU(t0m) + SQU(zl)); r1p = sqrt(SQU(t1p) + SQU(zl)); /* intermediate functions */ f0 = r00 <= EPSILON ? 0 : log((r0p + s0p) / (r0m + s0m)); f1 = r10 <= EPSILON ? 0 : log((r1p + s1p) / (r0p + s1m)); f2 = r20 <= EPSILON ? 0 : log((r0m + s2p) / (r1p + s2m)); B0 = fabs(t00) <= EPSILON ? 0 : atan(t00*s0p/(SQU(r00)+fabs(zl)*r0p))-atan(t00*s0m/(SQU(r00)+fabs(zl)*r0m)); B1 = fabs(t10) <= EPSILON ? 0 : atan(t10*s1p/(SQU(r10)+fabs(zl)*r1p))-atan(t10*s1m/(SQU(r10)+fabs(zl)*r0p)); B2 = fabs(t20) <= EPSILON ? 0 : atan(t20*s2p/(SQU(r20)+fabs(zl)*r0m))-atan(t20*s2m/(SQU(r20)+fabs(zl)*r1p)); d = a * l2[1]; /* Double aire a cause de normalization */ IS += ONE_OVER_TWO_PI * (-fabs(zl)*(B0+B1+B2) + t00*f0+t10*f1+t20*f2)/d; /* 1/r integral solution*/ /* Gauss Numerical Integration of (exp(Fct->Para[1]*R)-1)/R */ for (i_IntPoint = 1; i_IntPoint <= NGT_Points; i_IntPoint++){ Gauss_Triangle(NGT_Points,i_IntPoint,&us,&vs,&ws,&wghti); usi = u[0]*us + u[1]*vs + u[2]*ws ; vsi = v[0]*us + v[1]*vs + v[2]*ws ; wsi = n[0]*us + n[1]*vs + n[2]*ws ; Ri = sqrt( SQU(xl-usi) + SQU(yl-vsi) + SQU(zl-wsi) ) ; valr += Ri > EPSILON ? (wghti*(cos(Fct->Para[1]*Ri)-1)/Ri): 0 ; vali += Ri > EPSILON ? (-wghti*sin(Fct->Para[1]*Ri)/Ri): (-wghti * Fct->Para[1]); } valr = d * valr/2; vali = d * vali/2; Val->Val[0] = IS + valr ; Val->Val[MAX_DIM] = vali ; /* Imaginary part. Numerical integral */ if (j == 0){ xs[1] = xs[2]; ys[1] = ys[2]; zs[1] = zs[2]; xs[2] = xs[3]; ys[2] = ys[3]; zs[2] = zs[3]; } } if (j == 0){ Val->Val[0] = (Val->Val[0])/2; } Val->Type = SCALAR; break ; default : Message::Error("Unknown Element Type (%s) for 'GF_HelmholtzxForm'", Get_StringForDefine(Element_Type, Element->ElementSource->Type)); } break ; default : Message::Error("Unknown Dimension (%d) for 'GF_HelmholtzxForm'", (int)Fct->Para[0]); } } getdp-2.4.2-source/Legacy/SolvingAnalyse.cpp000644 001750 001750 00000060576 12221300353 022453 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Johan Gyselinck // Ruth Sabariego // #include "ProData.h" #include "GeoData.h" #include "DofData.h" #include "Treatment_Formulation.h" #include "Cal_Quantity.h" #include "Get_DofOfElement.h" #include "Pos_Formulation.h" #include "SolvingOperations.h" #include "MallocUtils.h" #include "Message.h" #define TWO_PI 6.2831853071795865 extern struct Problem Problem_S ; extern struct CurrentData Current ; extern int Flag_PRE, Flag_CAL, Flag_POS ; extern int Flag_RESTART ; extern char *Name_Generic ; extern char *Name_Resolution ; extern char *Name_PostOperation[NBR_MAX_POS] ; extern char *Name_MshFile, *Name_ResFile[NBR_MAX_RES], *Name_AdaptFile ; int TreatmentStatus = 0 ; List_T *GeoData_L = 0, *PreResolutionIndex_L = 0; /* ------------------------------------------------------------------------ */ /* I n i t _ D o f D a t a I n F u n c t i o n S p a c e */ /* ------------------------------------------------------------------------ */ /*! Links between FunctionSpace's and DofData's (one-to-one mapping) */ void Init_DofDataInFunctionSpace(int Nbr_DefineSystem, struct DofData *DofData_P0) { struct DofData * DofData_P ; struct FunctionSpace * FunctionSpace_P ; int i, j ; for (i = 0 ; i < Nbr_DefineSystem ; i++) { DofData_P = DofData_P0 + i ; for (j = 0 ; j < List_Nbr(DofData_P->FunctionSpaceIndex) ; j++){ FunctionSpace_P = (struct FunctionSpace *) List_Pointer(Problem_S.FunctionSpace, *((int *)List_Pointer(DofData_P->FunctionSpaceIndex, j))) ; FunctionSpace_P->DofData = FunctionSpace_P->MainDofData = DofData_P ; } } } /* ------------------------------------------------------------------------ */ /* I n i t _ D o f D a t a I n D e f i n e Q u a n t i t y */ /* ------------------------------------------------------------------------ */ /*! For setting the DofData of a DefineQuantity if explicitly specified */ void Init_DofDataInDefineQuantity(struct DefineSystem *DefineSystem_P, struct DofData *DofData_P0, struct Formulation *Formulation_P) { struct DefineQuantity *DefineQuantity_P; int i, j ; for(i = 0 ; i < List_Nbr(Formulation_P->DefineQuantity) ; i++){ DefineQuantity_P = (struct DefineQuantity *) List_Pointer(Formulation_P->DefineQuantity, i); if(DefineQuantity_P->DofDataIndex >= 0){ if(DefineQuantity_P->DofDataIndex >= List_Nbr(DefineSystem_P->OriginSystemIndex)){ Message::Error("Invalid System index (%d) in discrete Quantity (%s)", DefineQuantity_P->DofDataIndex, DefineQuantity_P->Name); break; } List_Read(DefineSystem_P->OriginSystemIndex, DefineQuantity_P->DofDataIndex, &j) ; DefineQuantity_P->DofData = DofData_P0 + j ; } else DefineQuantity_P->DofData = NULL ; } } /* ------------------------------------------------------------------------ */ /* T r e a t m e n t _ P r e p r o c e s s i n g */ /* ------------------------------------------------------------------------ */ /*! For each DefineSystem: For each Formulation: Definition of Dof's in associated DofData */ void Treatment_Preprocessing(int Nbr_DefineSystem, struct DofData * DofData_P0, struct DefineSystem * DefineSystem_P0, struct GeoData * GeoData_P0) { struct DefineSystem * DefineSystem_P ; struct DofData * DofData_P ; struct Formulation * Formulation_P ; int i, k, Nbr_Formulation, Index_Formulation; for (i = 0 ; i < Nbr_DefineSystem ; i++) { DefineSystem_P = DefineSystem_P0 + i ; DofData_P = DofData_P0 + i ; Dof_SetCurrentDofData(Current.DofData = DofData_P) ; Geo_SetCurrentGeoData(Current.GeoData = GeoData_P0 + DofData_P->GeoDataIndex) ; Current.NbrHar = Current.DofData->NbrHar ; Nbr_Formulation = List_Nbr(DefineSystem_P->FormulationIndex) ; for (k = 0 ; k < Nbr_Formulation ; k++) { List_Read(DefineSystem_P->FormulationIndex, k, &Index_Formulation) ; Formulation_P = (struct Formulation*) List_Pointer(Problem_S.Formulation, Index_Formulation) ; Message::Info("Treatment Formulation '%s'", Formulation_P->Name) ; Init_DofDataInDefineQuantity(DefineSystem_P, DofData_P0, Formulation_P) ; Treatment_Formulation(Formulation_P) ; } Dof_NumberUnknownDof() ; } } /* ------------------------------------------------------------------------ */ /* T r e a t m e n t _ P o s t O p e r a t i o n */ /* ------------------------------------------------------------------------ */ /*! Prepare the treatment of a PostOperation. Then does it outside */ void Treatment_PostOperation(struct Resolution * Resolution_P, struct DofData * DofData_P0, struct DefineSystem * DefineSystem_P0, struct GeoData * GeoData_P0, struct PostProcessing * PostProcessing_P, struct PostOperation * PostOperation_P) { struct PostSubOperation * PostSubOperation_P ; struct Formulation * Formulation_P ; struct DefineSystem * DefineSystem_P ; List_T * SaveSolutions_L=NULL; struct Solution * SaveCurrentSolution_P=NULL; int Nbr_PostSubOperation, i_POP, i ; if (!List_Nbr(PostProcessing_P->PostQuantity)){ Message::Error("No Quantity available for PostProcessing '%s'", PostProcessing_P->Name) ; return; } Formulation_P = (struct Formulation *) List_Pointer(Problem_S.Formulation, PostProcessing_P->FormulationIndex) ; if (!List_Nbr(Formulation_P->DefineQuantity)){ Message::Error("No discrete Quantity in Formulation '%s'", Formulation_P->Name); return; } /* Choice of Current DofData */ Current.DofData = 0; if(PostProcessing_P->NameOfSystem){ if ((i = List_ISearchSeq(Resolution_P->DefineSystem, PostProcessing_P->NameOfSystem, fcmp_DefineSystem_Name)) < 0){ Message::Error("Unknown System name (%s) in PostProcessing (%s)", PostProcessing_P->NameOfSystem, PostProcessing_P->Name) ; return; } Current.DofData = DofData_P0 + i; /* (Re)creation des liens entre FunctionSpace et DofData: seuls les FS n'intervenant pas dans le DD courant peuvent pointer vers un autre DD */ Init_DofDataInFunctionSpace(1, Current.DofData) ; } else{ for(i = 0 ; i < List_Nbr(Formulation_P->DefineQuantity) ; i++){ Current.DofData = ((struct FunctionSpace *) List_Pointer(Problem_S.FunctionSpace, ((struct DefineQuantity *) List_Pointer(Formulation_P->DefineQuantity, i)) ->FunctionSpaceIndex)) ->DofData ; if(Current.DofData) break; } if(Current.DofData) Message::Info("NameOfSystem not set in PostProcessing: selected '%s'", (DefineSystem_P0 + Current.DofData->Num)->Name) ; } if(!Current.DofData){ Message::Error("PostProcessing not compatible with Resolution"); return; } DefineSystem_P = DefineSystem_P0 + Current.DofData->Num ; Current.NbrHar = Current.DofData->NbrHar ; Geo_SetCurrentGeoData(Current.GeoData = GeoData_P0 + Current.DofData->GeoDataIndex) ; Message::Info("Selected PostProcessing '%s'", PostProcessing_P->Name); Message::Info("Selected Mesh '%s'", Current.GeoData->Name); Init_DofDataInDefineQuantity(DefineSystem_P,DofData_P0,Formulation_P); if (PostOperation_P->ResampleTime) { SaveSolutions_L = Current.DofData->Solutions; SaveCurrentSolution_P = Current.DofData->CurrentSolution; Pos_ResampleTime(PostOperation_P); } Nbr_PostSubOperation = List_Nbr(PostOperation_P->PostSubOperation) ; for (i_POP = 0 ; i_POP < Nbr_PostSubOperation ; i_POP++) { Message::Info("PostOperation %d/%d ", i_POP+1, Nbr_PostSubOperation) ; PostSubOperation_P = (struct PostSubOperation*) List_Pointer(PostOperation_P->PostSubOperation, i_POP) ; Pos_Formulation(Formulation_P, PostProcessing_P, PostSubOperation_P) ; } if (PostOperation_P->ResampleTime) { for(int i = 0; i < List_Nbr(Current.DofData->Solutions); i++) { Solution *Solution_P = (struct Solution*)List_Pointer(Current.DofData->Solutions, i); LinAlg_DestroyVector(&Solution_P->x); Free(Solution_P->TimeFunctionValues); } List_Delete(Current.DofData->Solutions); Current.DofData->Solutions = SaveSolutions_L; Current.DofData->CurrentSolution = SaveCurrentSolution_P; } } /* ------------------------------------------------------------------------ */ /* I n i t _ H a r I n D o f D a t a */ /* ------------------------------------------------------------------------ */ /*! For a DefineSystem: Fill harmonic data in the associated DofData */ void Init_HarInDofData(struct DefineSystem * DefineSystem_P, struct DofData * DofData_P) { int j ; if (DefineSystem_P->Type == VAL_COMPLEX){ if(!DefineSystem_P->FrequencyValue) Dof_AddPulsation(DofData_P,0.0) ; else for (j = 0 ; j < List_Nbr(DefineSystem_P->FrequencyValue) ; j++) Dof_AddPulsation (DofData_P, *((double *)List_Pointer(DefineSystem_P->FrequencyValue, j)) * TWO_PI) ; } if (!List_Nbr(DofData_P->Pulsation)){ DofData_P->NbrHar = 1 ; } else { DofData_P->NbrHar = 2 * List_Nbr(DofData_P->Pulsation) ; DofData_P->Val_Pulsation = (double*)List_Pointer(DofData_P->Pulsation, 0) ; } if (DofData_P->NbrHar > NBR_MAX_HARMONIC){ Message::Error("Too many harmonics to generate system (%d > %d)", DofData_P->NbrHar/2, NBR_MAX_HARMONIC/2) ; return; } if (DofData_P->NbrHar > 1) { for (j = 0 ; j < DofData_P->NbrHar/2 ; j++) Message::Info("System '%s' : Complex, Frequency = %.8g Hz", DefineSystem_P->Name, DofData_P->Val_Pulsation[j]/TWO_PI) ; } else{ Message::Info("System '%s' : Real", DefineSystem_P->Name) ; } } /* ------------------------------------------------------------------------ */ /* T r e a t m e n t _ R e s o l u t i o n */ /* ------------------------------------------------------------------------ */ /*! For each DefineSystem: Init the associated DofData */ void Treatment_Resolution(int ResolutionIndex, int * Nbr_DefineSystem, int * Nbr_OtherSystem, struct Resolution ** Resolution_P, struct DefineSystem ** DefineSystem_P0, struct DofData ** DofData_P0, List_T ** DofData_L, List_T * GeoData_L, struct GeoData ** GeoData_P0) { struct DefineSystem * DefineSystem_P ; struct DofData DofData_S ; int i ; *Resolution_P = (struct Resolution*)List_Pointer(Problem_S.Resolution, ResolutionIndex) ; Message::Info("Selected Resolution '%s'", (*Resolution_P)->Name) ; *Nbr_DefineSystem = List_Nbr((*Resolution_P)->DefineSystem) ; if (!*Nbr_DefineSystem){ Message::Error("No System exists for Resolution '%s'", (*Resolution_P)->Name) ; return; } if (*Nbr_OtherSystem) *Nbr_OtherSystem -= *Nbr_DefineSystem ; *DofData_L = List_Create(*Nbr_DefineSystem + *Nbr_OtherSystem, 6, sizeof(struct DofData)) ; *DefineSystem_P0 = (struct DefineSystem*) List_Pointer((*Resolution_P)->DefineSystem, 0) ; for (i = 0 ; i < *Nbr_DefineSystem ; i++) { DefineSystem_P = *DefineSystem_P0 + i ; Dof_InitDofData(&DofData_S, i, ResolutionIndex, i, DefineSystem_P->SolverDataFileName) ; DofData_S.GeoDataIndex = Geo_AddGeoData(GeoData_L, DefineSystem_P->MeshName, Name_MshFile, DefineSystem_P->AdaptName, Name_AdaptFile) ; Init_HarInDofData(DefineSystem_P, &DofData_S) ; List_Add(*DofData_L, &DofData_S) ; } for (i = 0 ; i < *Nbr_OtherSystem ; i++) { Dof_InitDofData(&DofData_S, i + *Nbr_DefineSystem, -1, -1, NULL) ; List_Add(*DofData_L, &DofData_S) ; } *DofData_P0 = (struct DofData*)List_Pointer(*DofData_L, 0) ; *GeoData_P0 = (struct GeoData*)List_Pointer(GeoData_L, 0) ; } /* ------------------------------------------------------------------------ */ /* G e t _ T i m e F u n c t i o n V a l u e s */ /* ------------------------------------------------------------------------ */ /*! For a DofData: Fill the vector of the considered time function values */ double * Get_TimeFunctionValues(struct DofData * DofData_P) { int Nbr_Expression, Nbr_TimeFunction, i, Index ; double * Values ; struct Value Val_Expression ; Nbr_Expression = List_Nbr(Problem_S.Expression) ; Values = (double *)Malloc((Nbr_Expression + 1) * sizeof(double)) ; Nbr_TimeFunction = List_Nbr(DofData_P->TimeFunctionIndex) ; for (i = 0 ; i < Nbr_TimeFunction ; i++) { List_Read(DofData_P->TimeFunctionIndex, i, &Index) ; if ((DofData_P->NbrHar == 1) && (Index > 0)) { Get_ValueOfExpressionByIndex(Index - 1, NULL, 0., 0., 0., &Val_Expression) ; Values[Index] = Val_Expression.Val[0] ; } else Values[Index] = 1. ; } return(Values) ; } /* ------------------------------------------------------------------------ */ /* S o l v i n g A n a l y s e */ /* ------------------------------------------------------------------------ */ /*! Global analyse of a problem */ void SolvingAnalyse() { struct Resolution * Resolution_P , * Resolution2_P ; struct DefineSystem * DefineSystem_P0 , * DefineSystem2_P0, * DefineSystem_P ; struct Solution * Solution_P , Solution_S ; struct GeoData * GeoData_P0 ; struct DofData * DofData_P0 , * DofData2_P0 ; List_T * DofData_L , * DofData2_L ; int Num_Resolution = 0, Num_Resolution2 ; int Nbr_DefineSystem , Nbr_DefineSystem2 ; int Nbr_Solution ; struct DofData * DofData_P ; struct Dof * Dof_P ; struct PostOperation * PostOperation_P[NBR_MAX_POS] ; struct PostProcessing * PostProcessing_P[NBR_MAX_POS] ; struct PreResolutionInfo PreResolutionInfo_S ; double d; int i, j ; int Num, Nbr_GeoData = 0; int Nbr_PreResolution, Nbr_OtherSystem ; DofData_L = 0; // in case of errors before it is created GeoData_L = List_Create( 1, 5, sizeof(struct GeoData)) ; /* -------------------- */ /* Treatment Resolution */ /* -------------------- */ if (Flag_PRE) { Nbr_OtherSystem = 0 ; if (Name_Resolution) Num_Resolution = List_ISearchSeq(Problem_S.Resolution, Name_Resolution, fcmp_Resolution_Name) ; else{ Message::Error("Missing Resolution"); goto end; } } else if (Flag_CAL || Flag_POS) { Dof_OpenFile(DOF_PRE, Name_Generic, "r") ; Dof_ReadFilePRE0(&Num_Resolution, &Nbr_DefineSystem) ; Nbr_OtherSystem = Nbr_DefineSystem ; } if (Num_Resolution < 0 || Num_Resolution + 1 > List_Nbr(Problem_S.Resolution)){ Message::Error("Unknown Resolution (%s)", Name_Resolution); goto end; } Treatment_Resolution(Num_Resolution, &Nbr_DefineSystem, &Nbr_OtherSystem, &Resolution_P, &DefineSystem_P0, &DofData_P0, &DofData_L, GeoData_L, &GeoData_P0) ; if(Message::GetOnelabAction() == "stop" || Message::GetErrorCount()) goto end; /* -------------- */ /* Pre-processing */ /* -------------- */ TreatmentStatus = _PRE ; Message::Direct("P r e - P r o c e s s i n g . . .") ; Message::ProgressMeter(0, 0, "Pre-processing"); if (Flag_PRE) { PreResolutionIndex_L = List_Create(10, 10, sizeof(struct PreResolutionInfo)) ; Treatment_Preprocessing(Nbr_DefineSystem, DofData_P0, DefineSystem_P0, GeoData_P0) ; Nbr_PreResolution = List_Nbr(PreResolutionIndex_L) ; for (i = 0 ; i < Nbr_PreResolution ; i++) { Message::Direct("P r e - R e s o l u t i o n (%d/%d) . . .", i+1, Nbr_PreResolution) ; List_Read(PreResolutionIndex_L, i, &PreResolutionInfo_S) ; Num_Resolution2 = PreResolutionInfo_S.Index ; Nbr_OtherSystem = 0 ; Treatment_Resolution(Num_Resolution2, &Nbr_DefineSystem2, &Nbr_OtherSystem, &Resolution2_P, &DefineSystem2_P0, &DofData2_P0, &DofData2_L, GeoData_L, &GeoData_P0) ; TreatmentStatus = _PRE ; Treatment_Preprocessing(Nbr_DefineSystem2, DofData2_P0, DefineSystem2_P0, GeoData_P0) ; for (j = 0 ; j < Nbr_DefineSystem2 ; j++) Dof_TransferDofTreeToList(DofData2_P0 + j) ; Init_DofDataInFunctionSpace(Nbr_DefineSystem2, DofData2_P0) ; Current.TypeTime = TIME_STATIC ; Current.Time = 0. ; Current.TimeImag = 0. ; Current.TimeStep = 0. ; Current.Iteration = 0 ; Current.RelativeDifference = 0. ; Current.RelaxationFactor = 1. ; Current.Breakpoint = -1; TreatmentStatus = _CAL ; Current.NbrSystem = Nbr_DefineSystem2 ; /* Attention: init for Dt[] */ Current.DofData_P0 = DofData2_P0 ; Treatment_Operation(Resolution2_P, Resolution2_P->Operation, DofData2_P0, GeoData_P0, Resolution_P, DofData_P0) ; if (PreResolutionInfo_S.Type == PR_GLOBALBASISFUNCTION) { for (j = 0 ; j < Nbr_DefineSystem2 ; j++) { DofData_P = DofData2_P0 + j ; Dof_TransferSolutionToConstraint(DofData_P) ; DofData_P->Num += Nbr_DefineSystem ; List_Add(DofData_L, DofData_P) ; } Nbr_DefineSystem = List_Nbr(DofData_L) ; /* New Value ... */ DofData_P0 = (struct DofData*)List_Pointer(DofData_L, 0) ; /* New Value ... */ } Message::Direct("E n d P r e - R e s o l u t i o n (%d/%d)", i+1, Nbr_PreResolution) ; } Dof_OpenFile(DOF_PRE, Name_Generic, "w+") ; Dof_WriteFilePRE0(Num_Resolution, Resolution_P->Name, Nbr_DefineSystem) ; for (i = 0 ; i < Nbr_DefineSystem ; i++){ Dof_WriteFilePRE(DofData_P0 + i) ; } Nbr_GeoData = List_Nbr(GeoData_L) ; for (i = 0 ; i < Nbr_GeoData ; i++) Geo_WriteFilePRE(GeoData_P0 + i, Problem_S.Group) ; Dof_CloseFile(DOF_PRE) ; if (Flag_CAL || Flag_POS) for (i = 0 ; i < Nbr_DefineSystem ; i++) Dof_TransferDofTreeToList(DofData_P0 + i) ; } else if (Flag_CAL || Flag_POS) { Message::Info("Loading Pre-Processing data '%s.pre'", Name_Generic) ; for(i = 0 ; i < Nbr_DefineSystem ; i++) Dof_ReadFilePRE(DofData_P0 + i) ; for(i = 0 ; i < Nbr_OtherSystem ; i++) { DofData_P = DofData_P0 + Nbr_DefineSystem + i ; Dof_ReadFilePRE(DofData_P) ; DefineSystem_P = (struct DefineSystem*) List_Pointer((((struct Resolution*)List_Pointer(Problem_S.Resolution, DofData_P->ResolutionIndex)) ->DefineSystem), DofData_P->SystemIndex) ; DofData_P->GeoDataIndex = Geo_AddGeoData(GeoData_L, DefineSystem_P->MeshName, Name_MshFile, DefineSystem_P->AdaptName, Name_AdaptFile) ; Init_HarInDofData(DefineSystem_P, DofData_P) ; } Nbr_DefineSystem = List_Nbr(DofData_L) ; /* New Value ... */ Nbr_GeoData = List_Nbr(GeoData_L) ; Geo_ReadFilePRE(GeoData_P0, Nbr_GeoData, Problem_S.Group) ; Dof_CloseFile(DOF_PRE) ; } Message::Cpu(""); Message::Direct("E n d P r e - P r o c e s s i n g"); if(Message::GetOnelabAction() == "stop" || Message::GetErrorCount()) goto end; /* ---------- */ /* Processing */ /* ---------- */ if (Flag_CAL) { TreatmentStatus = _CAL ; Message::Direct("P r o c e s s i n g . . .") ; Message::ProgressMeter(0, 0, "Processing"); Init_DofDataInFunctionSpace(Nbr_DefineSystem, DofData_P0) ; if(Flag_RESTART) { i = 0 ; while(Name_ResFile[i]){ Message::Info("Loading Processing data '%s'", Name_ResFile[i]) ; Dof_OpenFile(DOF_RES, Name_ResFile[i], "rb"); Dof_ReadFileRES(DofData_L, NULL, -1, &Current.Time, &Current.TimeImag, &Current.TimeStep) ; Dof_CloseFile(DOF_RES); i++ ; } Message::Info("Restarting computation (time = %g) s (TimeStep %g)", Current.Time, Current.TimeStep) ; } else{ Current.Time = Current.TimeImag = Current.TimeStep = 0. ; } Current.NbrHar = 1 ; /* Bug : peut ne pas etre initialise si -cal sans -pre et evaluation d'expression sans init de systeme avant */ Current.TypeTime = TIME_STATIC ; Current.RelativeDifference = 0. ; Current.RelaxationFactor = 1. ; Current.NbrSystem = Nbr_DefineSystem ; /* Attention: init for Dt[] */ Current.DofData_P0 = DofData_P0 ; Current.Breakpoint = -1; Treatment_Operation(Resolution_P, Resolution_P->Operation, DofData_P0, GeoData_P0, NULL, NULL) ; Message::Cpu(""); Message::Direct("E n d P r o c e s s i n g"); } if(Message::GetOnelabAction() == "stop" || Message::GetErrorCount()) goto end; /* --------------- */ /* Post-processing */ /* --------------- */ if (Flag_POS) { TreatmentStatus = _POS ; Message::Direct("P o s t - P r o c e s s i n g . . .") ; Message::ProgressMeter(0, 0, "Post-processing"); i = 0 ; while(Name_PostOperation[i]){ if((Num = List_ISearchSeq(Problem_S.PostOperation, Name_PostOperation[i], fcmp_PostOperation_Name)) < 0){ Message::Error("Unknown PostOperation (%s)", Name_PostOperation[i]) ; goto end; } PostOperation_P[i] = (struct PostOperation*) List_Pointer(Problem_S.PostOperation, Num) ; PostProcessing_P[i] = (struct PostProcessing *) List_Pointer(Problem_S.PostProcessing, PostOperation_P[i]->PostProcessingIndex) ; i++ ; } PostProcessing_P[i] = NULL ; if (!Flag_CAL) { i = 0 ; while(Name_ResFile[i]){ Message::Info("Loading Processing data '%s'", Name_ResFile[i]) ; Dof_OpenFile(DOF_RES, Name_ResFile[i], "rb"); Dof_ReadFileRES(DofData_L, NULL, -1, &d, &d, &d) ; Dof_CloseFile(DOF_RES) ; i++ ; } } for (i = 0 ; i < Nbr_DefineSystem ; i++) { Current.DofData = DofData_P = DofData_P0 + i ; for(j=0 ; jNbrAnyDof ; j++){ Dof_P = (struct Dof *)List_Pointer(DofData_P->DofList, j) ; if(Dof_P->Type == DOF_UNKNOWN_INIT){ Dof_P->Type = DOF_UNKNOWN ; LinAlg_ZeroScalar(&Dof_P->Val) ; } } Current.NbrHar = Current.DofData->NbrHar ; Nbr_Solution = List_Nbr(DofData_P->Solutions) ; if (Nbr_Solution == 0) { /* en cas de pos sans cal, apres calcul de function de base globale... a reorganiser */ if (DofData_P->Solutions == NULL) DofData_P->Solutions = List_Create( 1, 1, sizeof(struct Solution)) ; Solution_S.Time = 0. ; Solution_S.SolutionExist = 0 ; Solution_S.TimeFunctionValues = NULL ; List_Add(DofData_P->Solutions, &Solution_S) ; Nbr_Solution = 1 ; } if (!Flag_CAL) { /* Pas necessaire si Flag_CAL */ for (j = 0 ; j < Nbr_Solution ; j++) { Solution_P = (struct Solution*)List_Pointer(DofData_P->Solutions, j) ; Current.Time = Solution_P->Time ; Current.TimeImag = Solution_P->TimeImag ; Current.TimeStep = 0.; Current.Breakpoint = -1; Free(Solution_P->TimeFunctionValues); Solution_P->TimeFunctionValues = Get_TimeFunctionValues(DofData_P) ; } } DofData_P->CurrentSolution = (Nbr_Solution)? (struct Solution*)List_Pointer(DofData_P->Solutions, 0) : NULL ; /* La solution courante est la 1ere. A mieux gerer ? */ } Init_DofDataInFunctionSpace(Nbr_DefineSystem, DofData_P0) ; Current.NbrSystem = Nbr_DefineSystem ; /* Attention: init for Dt[] */ Current.DofData_P0 = DofData_P0 ; i = 0 ; while(PostProcessing_P[i]){ Treatment_PostOperation(Resolution_P, DofData_P0, DefineSystem_P0, GeoData_P0, PostProcessing_P[i], PostOperation_P[i]) ; i++ ; } Message::Cpu(""); Message::Direct("E n d P o s t - P r o c e s s i n g"); } end: for(int i = 0; i < List_Nbr(DofData_L); i++) Dof_FreeDofData((DofData*)List_Pointer(DofData_L, i)); List_Delete(DofData_L) ; for(int i = 0; i < List_Nbr(GeoData_L); i++) Geo_FreeGeoData((GeoData*)List_Pointer(GeoData_L, i)); List_Delete(GeoData_L); } getdp-2.4.2-source/Legacy/Gauss_Tetrahedron.h000644 001750 001750 00000012010 12116424202 022562 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . /* 1 integration point */ static double xtet1[1] = {0.25}; static double ytet1[1] = {0.25}; static double ztet1[1] = {0.25}; static double ptet1[1] = {0.166666666667}; /* 4 integration points */ static double xtet4[4] = {0.138196601125,0.138196601125,0.138196601125,0.585410196625}; static double ytet4[4] = {0.138196601125,0.138196601125,0.585410196625,0.138196601125}; static double ztet4[4] = {0.138196601125,0.585410196625,0.138196601125,0.138196601125}; static double ptet4[4] = {0.0416666666667,0.0416666666667,0.0416666666667,0.0416666666667}; /* 5 integration points */ static double xtet5[5] = {0.25,0.166666666667,0.166666666667,0.166666666667,0.5}; static double ytet5[5] = {0.25,0.166666666667,0.166666666667,0.5,0.166666666667}; static double ztet5[5] = {0.25,0.166666666667,0.5,0.166666666667,0.166666666667}; static double ptet5[5] = {-0.133333333333,0.075,0.075,0.075,0.075}; /* 15 integration points */ static double xtet15[15] = {0.25, 0.0919710780526,0.0919710780526,0.0919710780526,0.724086765841, 0.319793627829,0.319793627829,0.319793627829,0.0406191165118, 0.0563508326895,0.0563508326895,0.44364916731,0.0563508326895, 0.44364916731,0.44364916731}; static double ytet15[15] = {0.25, 0.0919710780526,0.0919710780526,0.724086765841,0.0919710780526, 0.319793627829,0.319793627829,0.0406191165118,0.319793627829, 0.0563508326895,0.44364916731,0.0563508326895,0.44364916731, 0.0563508326895,0.44364916731}; static double ztet15[15] = {0.25, 0.0919710780526,0.724086765841,0.0919710780526,0.0919710780526, 0.319793627829,0.0406191165118,0.319793627829,0.319793627829, 0.44364916731,0.0563508326895,0.0563508326895,0.44364916731, 0.44364916731,0.0563508326895}; static double ptet15[15] = {0.0197530864198, 0.0119895139632,0.0119895139632,0.0119895139632,0.0119895139632, 0.011511367871,0.011511367871,0.011511367871,0.011511367871, 0.00881834215168,0.00881834215168,0.00881834215168,0.00881834215168, 0.00881834215168,0.00881834215168}; /* 16 integration points */ #define a16 0.0503737941001228 / 6.0 #define b16 0.0665420686332923 / 6.0 #define c16 0.7716429020672371 #define d16 0.0761190326442543 #define e16 0.1197005277978019 #define f16 0.0718316452676693 #define g16 0.4042339134672644 static double xtet16[16] = {c16,d16,d16,d16,e16,f16,e16,f16, g16,g16,g16,g16,e16,f16,g16,g16}; static double ytet16[16] = {d16,c16,d16,d16,f16,e16,g16,g16, g16,g16,e16,f16,g16,g16,e16,f16}; static double ztet16[16] = {d16,d16,c16,d16,g16,g16,g16,g16, e16,f16,f16,e16,f16,e16,g16,g16}; static double ptet16[16] = {a16,a16,a16,a16,b16,b16,b16,b16, b16,b16,b16,b16,b16,b16,b16,b16}; #undef a16 #undef b16 #undef c16 #undef d16 #undef e16 #undef f16 #undef g16 /* 17 integration points */ #define a17 0.1884185567365411 / 6.0 #define b17 0.0670385837260428 / 6.0 #define c17 0.0452855923632739 / 6.0 #define p17 0.7316369079576180 #define q17 0.0894543640141273 #define e17 0.1325810999384657 #define f17 0.0245400397290300 #define g17 0.4214394310662522 static double xtet17[17] = {0.25,p17,q17,q17,q17,e17,f17,e17,f17,g17, g17,g17,g17,e17,f17,g17,g17}; static double ytet17[17] = {0.25,q17,p17,q17,q17,f17,e17,g17,g17,g17, g17,e17,f17,g17,g17,e17,f17}; static double ztet17[17] = {0.25,q17,q17,p17,q17,g17,g17,g17,g17,e17, f17,f17,e17,f17,e17,g17,g17}; static double ptet17[17] = {a17,b17,b17,b17,b17,c17,c17,c17,c17,c17, c17,c17,c17,c17,c17,c17,c17}; #undef a17 #undef b17 #undef c17 #undef p17 #undef q17 #undef e17 #undef f17 #undef g17 /* 29 integration points */ #define a29 0.0904012904601475 / 6.0 #define b29 0.0191198342789912 / 6.0 #define c29 0.0436149384066657 / 6.0 #define d29 0.0258116759619916 / 6.0 #define p29 0.8277192480479295 #define q29 0.0574269173173568 #define e29 0.0513518841255634 #define f29 0.4860510285706072 #define g29 0.2312985436519147 #define h29 0.2967538129690260 #define i29 0.6081079894015281 #define j29 0.0475690988147229 static double xtet29[29] = {0.25,p29,q29,q29,q29,e29,f29,e29,f29,g29, g29,g29,g29,e29,f29,g29,g29,h29,i29,h29, i29,j29,j29,j29,j29,h29,i29,j29,j29}; static double ytet29[29] = {0.25,q29,p29,q29,q29,f29,e29,g29,g29,g29, g29,e29,f29,g29,g29,e29,f29,i29,h29,j29, j29,j29,j29,h29,i29,j29,j29,h29,i29}; static double ztet29[29] = {0.25,q29,q29,p29,q29,g29,g29,g29,g29,e29, f29,f29,e29,f29,e29,g29,g29,j29,j29,j29, j29,h29,i29,i29,h29,i29,h29,j29,j29}; static double ptet29[29] = {a29,b29,b29,b29,b29,c29,c29,c29,c29,c29, c29,c29,c29,c29,c29,c29,c29,d29,d29,d29, d29,d29,d29,d29,d29,d29,d29,d29,d29}; #undef a29 #undef b29 #undef c29 #undef d29 #undef p29 #undef q29 #undef e29 #undef f29 #undef g29 #undef h29 #undef i29 #undef j29 getdp-2.4.2-source/Legacy/LinAlg.h000644 001750 001750 00000016104 12116424202 020317 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _LINALG_H_ #define _LINALG_H_ #include #include #include "GetDPConfig.h" // GetDP only uses a predefined set of acces routines to scalars // (double precision floating point real or complex values), vectors // of scalars and matrices of scalars. Thse routines are redefined for // each solver interface, currently Sparskit (LinAlg_SPARSKIT.cpp) and // PETSc (LinAlg_PETSC.cpp) #if defined(HAVE_SPARSKIT) #include "Sparskit.h" #define gSCALAR_SIZE 1 #define gCOMPLEX_INCREMENT 2 typedef struct { double s ; } gScalar ; typedef struct { Matrix M ; } gMatrix ; typedef struct { int N ; double *V ; } gVector ; typedef struct { Solver_Params Params ; } gSolver ; #elif defined(HAVE_PETSC) #include "petsc.h" #if (PETSC_VERSION_MAJOR < 2) || ((PETSC_VERSION_MAJOR == 2) && (PETSC_VERSION_MINOR < 3)) #error "GetDP requires PETSc version 2.3 or higher" #else #include "petscksp.h" #include "petscsnes.h" #endif #if defined(PETSC_USE_COMPLEX) #define gSCALAR_SIZE 2 #define gCOMPLEX_INCREMENT 1 #else #define gSCALAR_SIZE 1 #define gCOMPLEX_INCREMENT 2 #endif typedef struct { PetscScalar s ; } gScalar ; typedef struct { Mat M ; } gMatrix ; typedef struct { Vec V, Vseq ; } gVector ; typedef struct { KSP ksp[10] ; SNES snes[10] ; } gSolver ; #else #define gSCALAR_SIZE 1 #define gCOMPLEX_INCREMENT 2 typedef struct { double s; } gScalar ; typedef struct { double **m; } gMatrix ; typedef struct { double *m; } gVector ; typedef struct { int dummy; } gSolver ; #endif void LinAlg_InitializeSolver(int* argc, char*** argv); void LinAlg_FinalizeSolver(void); void LinAlg_SetCommSelf(); void LinAlg_SetCommWorld(); void LinAlg_CreateSolver(gSolver *Solver, const char * SolverDataFileName); void LinAlg_CreateVector(gVector *V, gSolver *Solver, int n); void LinAlg_CreateMatrix(gMatrix *M, gSolver *Solver, int n, int m); void LinAlg_DestroySolver(gSolver *Solver); void LinAlg_DestroyVector(gVector *V); void LinAlg_DestroyMatrix(gMatrix *M); void LinAlg_CopyScalar(gScalar *S1, gScalar *S2); void LinAlg_CopyVector(gVector *V1, gVector *V2); void LinAlg_CopyMatrix(gMatrix *M1, gMatrix *M2); void LinAlg_ZeroScalar(gScalar *S); void LinAlg_ZeroVector(gVector *V); void LinAlg_ZeroMatrix(gMatrix *M); void LinAlg_ScanScalar(FILE *file, gScalar *S); void LinAlg_ScanVector(FILE *file, gVector *V); void LinAlg_ScanMatrix(FILE *file, gMatrix *M); void LinAlg_ReadScalar(FILE *file, gScalar *S); void LinAlg_ReadVector(FILE *file, gVector *V); void LinAlg_ReadMatrix(FILE *file, gMatrix *M); void LinAlg_PrintScalar(FILE *file, gScalar *S); void LinAlg_PrintVector(FILE *file, gVector *V, bool matlab=false, const char* fileName="vector.m", const char* varName="Vec_0"); void LinAlg_PrintMatrix(FILE *file, gMatrix *M, bool matlab=false, const char* fileName="matrix.m", const char* varName="Mat_0"); void LinAlg_WriteScalar(FILE *file, gScalar *S); void LinAlg_WriteVector(FILE *file, gVector *V); void LinAlg_WriteMatrix(FILE *file, gMatrix *M); void LinAlg_GetVectorSize(gVector *V, int *i); void LinAlg_GetLocalVectorRange(gVector *V, int *low, int *high); void LinAlg_GetMatrixSize(gMatrix *M, int *i, int *j); void LinAlg_GetLocalMatrixRange(gMatrix *M, int *low, int *high); void LinAlg_GetDoubleInScalar(double *d, gScalar *S); void LinAlg_GetComplexInScalar(double *d1, double *d2, gScalar *S); void LinAlg_GetScalarInVector(gScalar *S, gVector *V, int i); void LinAlg_GetDoubleInVector(double *d, gVector *V, int i); void LinAlg_GetAbsDoubleInVector(double *d, gVector *V, int i); void LinAlg_GetComplexInVector(double *d1, double *d2, gVector *V, int i, int j); void LinAlg_GetScalarInMatrix(gScalar *S, gMatrix *M, int i, int j); void LinAlg_GetDoubleInMatrix(double *d, gMatrix *M, int i, int j); void LinAlg_GetComplexInMatrix(double *d1, double *d2, gMatrix *M, int i, int j, int k, int l); void LinAlg_GetColumnInMatrix(gMatrix *M, int col, gVector *V1); void LinAlg_SetScalar(gScalar *S, double *d); void LinAlg_SetVector(gVector *V, double *v); void LinAlg_SetScalarInVector(gScalar *S, gVector *V, int i); void LinAlg_SetDoubleInVector(double d, gVector *V, int i); void LinAlg_SetComplexInVector(double d1, double d2, gVector *V, int i, int j); void LinAlg_SetScalarInMatrix(gScalar *S, gMatrix *M, int i, int j); void LinAlg_SetDoubleInMatrix(double d, gMatrix *M, int i, int j); void LinAlg_SetComplexInMatrix(double d1, double d2, gMatrix *M, int i, int j, int k, int l); void LinAlg_AddScalarScalar(gScalar *S1, gScalar *S2, gScalar *S3); void LinAlg_AddScalarInVector(gScalar *S, gVector *V, int i); void LinAlg_AddDoubleInVector(double d, gVector *V, int i); void LinAlg_AddComplexInVector(double d1, double d2, gVector *V, int i, int j); void LinAlg_AddScalarInMatrix(gScalar *S, gMatrix *M, int i, int j); void LinAlg_AddDoubleInMatrix(double d, gMatrix *M, int i, int j); void LinAlg_AddComplexInMatrix(double d1, double d2, gMatrix *M, int i, int j, int k, int l); void LinAlg_AddVectorVector(gVector *V1, gVector *V2, gVector *V3); void LinAlg_AddVectorProdVectorDouble(gVector *V1, gVector *V2, double d, gVector *V3); void LinAlg_AddMatrixMatrix(gMatrix *M1, gMatrix *M2, gMatrix *M3); void LinAlg_AddMatrixProdMatrixDouble(gMatrix *M1, gMatrix *M2, double d, gMatrix *M3); void LinAlg_SubScalarScalar(gScalar *S1, gScalar *S2, gScalar *S3); void LinAlg_SubVectorVector(gVector *V1, gVector *V2, gVector *V3); void LinAlg_SubMatrixMatrix(gMatrix *M1, gMatrix *M2, gMatrix *M3); void LinAlg_ProdScalarScalar(gScalar *S1, gScalar *S2, gScalar *S3); void LinAlg_ProdScalarDouble(gScalar *S1, double d, gScalar *S2); void LinAlg_ProdScalarComplex(gScalar *S, double d1, double d2, double *d3, double *d4); void LinAlg_ProdVectorScalar(gVector *V1, gScalar *S, gVector *V2); void LinAlg_ProdVectorDouble(gVector *V1, double d, gVector *V2); void LinAlg_ProdVectorComplex(gVector *V1, double d1, double d2, gVector *V2); void LinAlg_ProdVectorVector(gVector *V1, gVector *V2, double *d); void LinAlg_ProdMatrixVector(gMatrix *M, gVector *V1, gVector *V2); void LinAlg_ProdMatrixScalar(gMatrix *M1, gScalar *S, gMatrix *M2); void LinAlg_ProdMatrixDouble(gMatrix *M1, double d, gMatrix *M2); void LinAlg_ProdMatrixComplex(gMatrix *M1, double d1, double d2, gMatrix *M2); void LinAlg_DummyVector(gVector *V); void LinAlg_DivScalarScalar(gScalar *S1, gScalar *S2, gScalar *S3); void LinAlg_DivScalarDouble(gScalar *S1, double d, gScalar *S2); void LinAlg_VectorNorm2(gVector *V1, double *norm); void LinAlg_VectorNormInf(gVector *V1, double *norm); void LinAlg_AssembleMatrix(gMatrix *M); void LinAlg_AssembleVector(gVector *V); void LinAlg_Solve(gMatrix *A, gVector *B, gSolver *Solver, gVector *X, int solverIndex=0); void LinAlg_SolveAgain(gMatrix *A, gVector *B, gSolver *Solver, gVector *X, int solverIndex=0); void LinAlg_SolveNL(gMatrix *A, gVector *B, gMatrix *Jac, gVector *R, gSolver *Solver, gVector *X, int solverIndex=0); #endif getdp-2.4.2-source/Legacy/F_Misc.cpp000644 001750 001750 00000007101 12116424202 020641 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include "GetDPConfig.h" #include "ProData.h" #include "ProDefine.h" #include "F.h" #include "Message.h" #include "Cal_Value.h" extern struct CurrentData Current ; void F_Printf(F_ARG) { Print_Value(A) ; printf("\n") ; } void F_Rand(F_ARG) { int k; if(A->Type != SCALAR) Message::Error("Non scalar argument for function 'Rand"); V->Val[0] = A->Val[0] * (double)rand() / (double)RAND_MAX; if (Current.NbrHar != 1){ V->Val[MAX_DIM] = 0. ; for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) V->Val[MAX_DIM*k] = V->Val[MAX_DIM*(k+1)] = 0. ; } V->Type = SCALAR ; } void F_CompElementNum (F_ARG) { if(!Current.Element || !Current.ElementSource) Message::Error("Uninitialized Element in 'F_CompElementNum'"); V->Type = SCALAR ; V->Val[0] = (Current.Element->Num == Current.ElementSource->Num) ; } void F_VirtualWork (F_ARG) { MATRIX3x3 Jac ; double DetJac ; double DetJac_dx[3], squF[6] ; double s[3] = {0.,0.,0.}; if(!Current.Element) Message::Error("Uninitialized Element in 'F_VirtualWork'"); Current.flagAssDiag = 1; /*+++prov*/ int numNode = Current.NumEntity; int i = 0 ; while (i < Current.Element->GeoElement->NbrNodes && Current.Element->GeoElement->NumNodes[i] != numNode) i++; if (i < Current.Element->GeoElement->NbrNodes ) { for(int j = 0; j < 3; j++) { squF[j] = A->Val[j] * A->Val[j] ; squF[j+3] = A->Val[j] * A->Val[(j<2)?j+1:0] ; } //Get_BFGeoElement(Current.Element, Current.u, Current.v, Current.w); DetJac = Current.Element->DetJac ; Jac = Current.Element->Jac ; DetJac_dx[0] = Current.Element->dndu[i][0] * ( Jac.c22 * Jac.c33 - Jac.c23 * Jac.c32 ) - Current.Element->dndu[i][1] * ( Jac.c12 * Jac.c33 - Jac.c13 * Jac.c32 ) + Current.Element->dndu[i][2] * ( Jac.c12 * Jac.c23 - Jac.c22 * Jac.c13 ); DetJac_dx[1] = - Current.Element->dndu[i][0] * ( Jac.c21 * Jac.c33 - Jac.c23 * Jac.c31 ) + Current.Element->dndu[i][1] * ( Jac.c11 * Jac.c33 - Jac.c13 * Jac.c31 ) - Current.Element->dndu[i][2] * ( Jac.c11 * Jac.c23 - Jac.c13 * Jac.c21 ); DetJac_dx[2] = Current.Element->dndu[i][0] * ( Jac.c21 * Jac.c32 - Jac.c22 * Jac.c31 ) - Current.Element->dndu[i][1] * ( Jac.c11 * Jac.c32 - Jac.c12 * Jac.c31 ) + Current.Element->dndu[i][2] * ( Jac.c11 * Jac.c22 - Jac.c12 * Jac.c21 ); if(DetJac != 0){ s[0] = ( DetJac_dx[0] * ( - squF[0] + squF[1] + squF[2] ) - 2 * DetJac_dx[1] * squF[3] - 2 * DetJac_dx[2] * squF[5])/DetJac ; s[1] = ( DetJac_dx[1] * ( squF[0] - squF[1] + squF[2] ) - 2 * DetJac_dx[0] * squF[3] - 2 * DetJac_dx[2] * squF[4])/DetJac ; s[2] = ( DetJac_dx[2] * ( squF[0] + squF[1] - squF[2] ) - 2 * DetJac_dx[0] * squF[5] - 2 * DetJac_dx[1] * squF[4])/DetJac ; } else { Message::Warning("Zero determinant in 'F_VirtualWork'") ; } } V->Type = VECTOR ; V->Val[0] = s[0] ; V->Val[1] = s[1] ; V->Val[2] = s[2] ; } void F_AssDiag(F_ARG) { int k ; Current.flagAssDiag = 2; /*+++prov*/ V->Val[0] = 1.; if (Current.NbrHar != 1){ V->Val[MAX_DIM] = 0. ; for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k += 2) V->Val[MAX_DIM*k] = V->Val[MAX_DIM*(k+1)] = 0. ; } V->Type = SCALAR ; } getdp-2.4.2-source/Legacy/Generate_Network.h000644 001750 001750 00000000567 12166744450 022441 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _GENERATE_NETWORK_H_ #define _GENERATE_NETWORK_H_ #include "ProData.h" struct ConstraintActive * Generate_Network(char *Name, List_T * ConstraintPerRegion_L); #endif getdp-2.4.2-source/Legacy/BF_Edge_3.cpp000644 001750 001750 00000021332 12116424202 021140 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "ProData.h" #include "GeoData.h" #include "Message.h" /* The non-symmetric facet functions are selected according to the NumIndex^th smallest global node number */ int fcmp_Int2(const void * a, const void * b) { return ((struct TwoInt *)a)->Int2 - ((struct TwoInt *)b)->Int2 ; } int Get_FacetFunctionIndex(struct Element * Element, int NumEntity, int NumIndex) { int i, j, *NumNodes ; if(Element->NumLastElementForSortedNodesByFacet != Element->Num){ for(i = 0 ; i < Element->GeoElement->NbrFacets ; i++){ NumNodes = Geo_GetNodesOfFacetInElement(Element->GeoElement, i); j = 0 ; while(NumNodes[j]){ Element->SortedNodesByFacet[i][j].Int1 = NumNodes[j] ; Element->SortedNodesByFacet[i][j].Int2 = Element->GeoElement->NumNodes[NumNodes[j]-1] ; j++ ; } qsort(Element->SortedNodesByFacet[i], j, sizeof(struct TwoInt), fcmp_Int2); } Element->NumLastElementForSortedNodesByFacet = Element->Num ; } return Element->SortedNodesByFacet[NumEntity-1][NumIndex-1].Int1; } /* ------------------------------------------------------------------------ */ /* B F _ E d g e _ 3 */ /* ------------------------------------------------------------------------ */ /* ------- */ /* Edges */ /* ------- */ #define WrongNumEntity Message::Error("Wrong Edge number in 'BF_Edge_3E'") void BF_Edge_3E(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { Message::Error("You should never end up here!") ; } #undef WrongNumEntity /* -------- */ /* Facets */ /* -------- */ #define WrongNumEntity Message::Error("Wrong Face number in 'BF_Edge_3F'") void BF_Edge_3F(struct Element * Element, int NumEntity, int Index, double u, double v, double w, double s[]) { switch (Element->Type) { case LINE : Message::Error("You should never end up here!") ; break; case TRIANGLE : switch(NumEntity) { case 1 : switch(Get_FacetFunctionIndex(Element, NumEntity, Index)){ case 3 : s[0] = 0. ; s[1] = (1-u-v)*u ; s[2] = 0. ; break ; case 1 : s[0] = -u*v ; s[1] = -u*v ; s[2] = 0. ; break ; case 2 : s[0] = (1-u-v)*v ; s[1] = 0. ; s[2] = 0. ; break ; } break ; default : WrongNumEntity ; } break ; case QUADRANGLE : switch(NumEntity) { default : Message::Error("BF_Edge_3F not ready for QUADRANGLE"); } break ; case TETRAHEDRON : switch(NumEntity) { case 1 : switch(Get_FacetFunctionIndex(Element, NumEntity, Index)){ case 4: s[0] = 0. ; s[1] = 0. ; s[2] = u*(1.-u-v-w) ; break ; case 1: s[0] = -u*w ; s[1] = -u*w ; s[2] = -u*w ; break ; case 2: s[0] = (1.-u-v-w)*w ; s[1] = 0. ; s[2] = 0. ; break ; } break ; case 2 : switch(Get_FacetFunctionIndex(Element, NumEntity, Index)){ case 2: s[0] = v*(1-u-v-w) ; s[1] = 0. ; s[2] = 0. ; break ; case 1: s[0] = -u*v ; s[1] = -u*v ; s[2] = -u*v ; break ; case 3: s[0] = 0. ; s[1] = u*(1.-u-v-w) ; s[2] = 0. ; break ; } break ; case 3 : switch(Get_FacetFunctionIndex(Element, NumEntity, Index)){ case 3: s[0] = 0. ; s[1] = (1.-u-v-w)*w ; s[2] = 0. ; break ; case 1: s[0] = -v*w ; s[1] = -v*w ; s[2] = -v*w ; break ; case 4: s[0] = 0. ; s[1] = 0. ; s[2] = v*(1.-u-v-w) ; break ; } break ; case 4 : switch(Get_FacetFunctionIndex(Element, NumEntity, Index)){ case 4: s[0] = 0. ; s[1] = 0. ; s[2] = u*v ; break ; case 2: s[0] = v*w ; s[1] = 0. ; s[2] = 0. ; break ; case 3: s[0] = 0. ; s[1] = u*w ; s[2] = 0. ; break ; } break ; default : WrongNumEntity ; } break ; case HEXAHEDRON : switch(NumEntity) { default : Message::Error("BF_Edge_3F not ready for HEXAHEDRON"); } break ; case PRISM : switch(NumEntity) { default : Message::Error("BF_Edge_3F not ready for PRISM"); } break ; case PYRAMID : switch(NumEntity) { default : Message::Error("BF_Edge_3F not ready for PYRAMID"); } break ; default : Message::Error("Unkown type of Element in BF_Edge_3F"); break ; } } #undef WrongNumEntity void BF_Edge_3F_a(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { BF_Edge_3F(Element, NumEntity, 1, u, v, w, s) ; } void BF_Edge_3F_b(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { BF_Edge_3F(Element, NumEntity, 2, u, v, w, s) ; } void BF_Edge_3F_c(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { BF_Edge_3F(Element, NumEntity, 3, u, v, w, s) ; } /* -------- */ /* Volume */ /* -------- */ void BF_Edge_3V(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { Message::Error("You should never end up here!") ; } /* ------------------------------------------------------------------------ */ /* B F _ C u r l E d g e _ 3 */ /* ------------------------------------------------------------------------ */ /* ------- */ /* Edges */ /* ------- */ #define WrongNumEntity Message::Error("Wrong Edge number in 'BF_CurlEdge_3E'") void BF_CurlEdge_3E(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { Message::Error("You should never end up here!") ; } #undef WrongNumEntity /* -------- */ /* Facets */ /* -------- */ #define WrongNumEntity Message::Error("Wrong Face number in 'BF_CurlEdge_3F'") void BF_CurlEdge_3F(struct Element * Element, int NumEntity, int Index, double u, double v, double w, double s[]) { switch (Element->Type) { case LINE : Message::Error("You should never end up here!") ; break; case TRIANGLE : switch(NumEntity) { case 1 : switch(Get_FacetFunctionIndex(Element, NumEntity, Index)){ case 3 : s[0] = 0. ; s[1] = 0. ; s[2] = -2.0*u+1.0-v ; break ; case 1 : s[0] = 0. ; s[1] = 0. ; s[2] = -v+u; break ; case 2 : s[0] = 0. ; s[1] = 0. ; s[2] = 2.0*v-1.0+u ; break ; } break ; default : WrongNumEntity ; } break ; case QUADRANGLE : switch(NumEntity) { default : Message::Error("BF_CurlEdge_3F not ready for QUADRANGLE"); } break ; case TETRAHEDRON : switch(NumEntity) { case 1 : switch(Get_FacetFunctionIndex(Element, NumEntity, Index)){ case 4: s[0] = -u ; s[1] = -1.+2.*u+v+w ; s[2] = 0. ; break ; case 1: s[0] = u ; s[1] = -u+w ; s[2] = -w ; break ; case 2: s[0] = 0. ; s[1] = 1.-u-v-2.*w ; s[2] = w ; break ; } break ; case 2 : switch(Get_FacetFunctionIndex(Element, NumEntity, Index)){ case 2: s[0] = 0. ; s[1] = -v ; s[2] = -1.+u+2.*v+w ; break ; case 1: s[0] = -u ; s[1] = v ; s[2] = u-v ; break ; case 3: s[0] = u ; s[1] = 0. ; s[2] = 1.-2.*u-v-w ; break ; } break ; case 3 : switch(Get_FacetFunctionIndex(Element, NumEntity, Index)){ case 3: s[0] = -1.+u+v+2.*w ; s[1] = 0. ; s[2] = -w ; break ; case 1: s[0] = v-w ; s[1] = -v ; s[2] = w ; break ; case 4: s[0] = 1.-u-2.*v-w ; s[1] = v ; s[2] = 0. ; break ; } break ; case 4 : switch(Get_FacetFunctionIndex(Element, NumEntity, Index)){ case 4: s[0] = u ; s[1] = -v ; s[2] = 0. ; break ; case 2: s[0] = 0. ; s[1] = v ; s[2] = -w ; break ; case 3: s[0] = -u ; s[1] = 0. ; s[2] = w ; break ; } break ; default : WrongNumEntity ; } break ; case HEXAHEDRON : switch(NumEntity) { default : Message::Error("BF_CurlEdge_3F not ready for HAXAHEDRON"); } break ; case PRISM : switch(NumEntity) { default : Message::Error("BF_CurlEdge_3F not ready for PRISM"); } break ; default : Message::Error("Unkown type of Element in BF_CurlEdge_3F"); break ; } } #undef WrongNumEntity void BF_CurlEdge_3F_a(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { BF_CurlEdge_3F(Element, NumEntity, 1, u, v, w, s) ; } void BF_CurlEdge_3F_b(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { BF_CurlEdge_3F(Element, NumEntity, 2, u, v, w, s) ; } void BF_CurlEdge_3F_c(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { BF_CurlEdge_3F(Element, NumEntity, 3, u, v, w, s) ; } /* -------- */ /* Volume */ /* -------- */ void BF_CurlEdge_3V(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { Message::Error("You should never end up here!") ; } getdp-2.4.2-source/Legacy/F_ExtMath.cpp000644 001750 001750 00000113152 12116424202 021324 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Johan Gyselinck // Ruth Sabariego #include #include "F.h" #include "GeoData.h" #include "DofData.h" #include "Cal_Value.h" #include "Message.h" extern struct CurrentData Current ; #define SQU(a) ((a)*(a)) #define TWO_PI 6.2831853071795865 /* ------------------------------------------------------------------------ */ /* Simple Extended Math */ /* ------------------------------------------------------------------------ */ void F_Hypot(F_ARG) { int k; double tmp; if(A->Type != SCALAR || (A+1)->Type != SCALAR) Message::Error("Non scalar argument(s) for function 'Hypot'"); if (Current.NbrHar == 1){ V->Val[0] = sqrt(A->Val[0]*A->Val[0]+(A+1)->Val[0]*(A+1)->Val[0]) ; } else { tmp = sqrt(A->Val[0]*A->Val[0]+(A+1)->Val[0]*(A+1)->Val[0]) ; for (k = 0 ; k < Current.NbrHar ; k += 2) { V->Val[MAX_DIM* k ] = tmp ; V->Val[MAX_DIM*(k+1)] = 0. ; } } V->Type = SCALAR; } void F_TanhC2(F_ARG) { double denom = SQU(cosh(A->Val[0])*cos(A->Val[MAX_DIM])) + SQU(sinh(A->Val[0])*sin(A->Val[MAX_DIM])); V->Val[0] = sinh(A->Val[0])*cosh(A->Val[0]) / denom ; V->Val[MAX_DIM] = sin(A->Val[MAX_DIM])*cos(A->Val[MAX_DIM]) / denom ; V->Type = SCALAR ; } /* ------------------------------------------------------------------------ */ /* General Tensor Functions */ /* ------------------------------------------------------------------------ */ void F_Transpose(F_ARG) { if(A->Type != TENSOR_DIAG && A->Type != TENSOR_SYM && A->Type != TENSOR) Message::Error("Wrong type of argument for function 'Transpose'"); Cal_TransposeValue(A,V); } void F_Inv(F_ARG) { if(A->Type != TENSOR_DIAG && A->Type != TENSOR_SYM && A->Type != TENSOR) Message::Error("Wrong type of argument for function 'Inverse'"); Cal_InvertValue(A,V); } void F_Det(F_ARG) { if(A->Type != TENSOR_DIAG && A->Type != TENSOR_SYM && A->Type != TENSOR) Message::Error("Wrong type of argument for function 'Det'"); Cal_DetValue(A,V); } void F_Trace(F_ARG) { if(A->Type != TENSOR_DIAG && A->Type != TENSOR_SYM && A->Type != TENSOR) Message::Error("Wrong type of argument for function 'Trace'"); Cal_TraceValue(A,V); } void F_RotateXYZ(F_ARG) { double ca, sa, cb, sb, cc, sc ; struct Value Rot ; if((A->Type != TENSOR_DIAG && A->Type != TENSOR_SYM && A->Type != TENSOR && A->Type != VECTOR) || (A+1)->Type != SCALAR || (A+2)->Type != SCALAR || (A+3)->Type != SCALAR) Message::Error("Wrong type of argument(s) for function 'Rotate'"); ca = cos((A+1)->Val[0]) ; sa = sin((A+1)->Val[0]) ; cb = cos((A+2)->Val[0]) ; sb = sin((A+2)->Val[0]) ; cc = cos((A+3)->Val[0]) ; sc = sin((A+3)->Val[0]) ; Rot.Type = TENSOR ; Cal_ZeroValue(&Rot); Rot.Val[0] = cb*cc; Rot.Val[1] = -cb*sc; Rot.Val[2] = sb; Rot.Val[3] = sa*sb*cc+ca*sc; Rot.Val[4] = -sa*sb*sc+ca*cc; Rot.Val[5] = -sa*cb; Rot.Val[6] = -ca*sb*cc+sa*sc; Rot.Val[7] = ca*sb*sc+sa*cc; Rot.Val[8] = ca*cb; Cal_RotateValue(&Rot,A,V); } /* ------------------------------------------------------------------------ */ /* Norm */ /* ------------------------------------------------------------------------ */ void F_Norm(F_ARG) { int k ; switch(A->Type) { case SCALAR : if (Current.NbrHar == 1) { V->Val[0] = fabs(A->Val[0]) ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2 ) { V->Val[MAX_DIM*k] = sqrt(SQU(A->Val[MAX_DIM*k]) + SQU(A->Val[MAX_DIM*(k+1)])); V->Val[MAX_DIM*(k+1)] = 0. ; } } break ; case VECTOR : if (Current.NbrHar == 1) { V->Val[0] = sqrt(SQU(A->Val[0]) + SQU(A->Val[1]) + SQU(A->Val[2])) ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2 ) { V->Val[MAX_DIM*k] = sqrt(SQU(A->Val[MAX_DIM* k ]) + SQU(A->Val[MAX_DIM* k +1]) + SQU(A->Val[MAX_DIM* k +2]) + SQU(A->Val[MAX_DIM*(k+1) ]) + SQU(A->Val[MAX_DIM*(k+1)+1]) + SQU(A->Val[MAX_DIM*(k+1)+2])) ; V->Val[MAX_DIM*(k+1)] = 0. ; } } break ; default : Message::Error("Wrong type of argument for function 'Norm'"); break; } V->Type = SCALAR ; } /* ------------------------------------------------------------------------ */ /* Square Norm */ /* ------------------------------------------------------------------------ */ void F_SquNorm(F_ARG) { int k ; switch(A->Type) { case SCALAR : if (Current.NbrHar == 1) { V->Val[0] = SQU(A->Val[0]) ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2 ) { V->Val[MAX_DIM*k] = SQU(A->Val[MAX_DIM*k]) + SQU(A->Val[MAX_DIM*(k+1)]); V->Val[MAX_DIM*(k+1)] = 0. ; } } break ; case VECTOR : if (Current.NbrHar == 1) { V->Val[0] = SQU(A->Val[0]) + SQU(A->Val[1]) + SQU(A->Val[2]) ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2 ) { V->Val[MAX_DIM*k] = SQU(A->Val[MAX_DIM* k ]) + SQU(A->Val[MAX_DIM* k +1]) + SQU(A->Val[MAX_DIM* k +2]) + SQU(A->Val[MAX_DIM*(k+1) ]) + SQU(A->Val[MAX_DIM*(k+1)+1]) + SQU(A->Val[MAX_DIM*(k+1)+2]) ; V->Val[MAX_DIM*(k+1)] = 0. ; } } break ; default : Message::Error("Wrong type of argument for function 'SquNorm'"); break; } V->Type = SCALAR ; } /* ------------------------------------------------------------------------ */ /* Unit */ /* ------------------------------------------------------------------------ */ void F_Unit(F_ARG) { int k ; double Norm ; switch(A->Type) { case SCALAR : if (Current.NbrHar == 1) { V->Val[0] = 1. ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2 ) { V->Val[MAX_DIM* k ] = 1. ; V->Val[MAX_DIM*(k+1)] = 0. ; } } V->Type = SCALAR ; break ; case VECTOR : if (Current.NbrHar == 1) { Norm = sqrt(SQU(A->Val[0]) + SQU(A->Val[1]) + SQU(A->Val[2])) ; if (Norm > 1.e-30) { /* Attention: tolerance */ V->Val[0] = A->Val[0]/Norm ; V->Val[1] = A->Val[1]/Norm ; V->Val[2] = A->Val[2]/Norm ; } else { V->Val[0] = 0. ; V->Val[1] = 0. ; V->Val[2] = 0. ; } } else { for (k = 0 ; k < Current.NbrHar ; k += 2 ) { Norm = sqrt(SQU(A->Val[MAX_DIM* k ]) + SQU(A->Val[MAX_DIM* k +1]) + SQU(A->Val[MAX_DIM* k +2]) + SQU(A->Val[MAX_DIM*(k+1) ]) + SQU(A->Val[MAX_DIM*(k+1)+1]) + SQU(A->Val[MAX_DIM*(k+1)+2])) ; if (Norm > 1.e-30) { /* Attention: tolerance */ V->Val[MAX_DIM* k ] = A->Val[MAX_DIM* k ]/Norm ; V->Val[MAX_DIM* k +1] = A->Val[MAX_DIM* k +1]/Norm ; V->Val[MAX_DIM* k +2] = A->Val[MAX_DIM* k +2]/Norm ; V->Val[MAX_DIM*(k+1) ] = A->Val[MAX_DIM*(k+1) ]/Norm ; V->Val[MAX_DIM*(k+1)+1] = A->Val[MAX_DIM*(k+1)+1]/Norm ; V->Val[MAX_DIM*(k+1)+2] = A->Val[MAX_DIM*(k+1)+2]/Norm ; } else { V->Val[MAX_DIM* k ] = 0 ; V->Val[MAX_DIM* k +1] = 0 ; V->Val[MAX_DIM* k +2] = 0 ; V->Val[MAX_DIM*(k+1) ] = 0 ; V->Val[MAX_DIM*(k+1)+1] = 0 ; V->Val[MAX_DIM*(k+1)+2] = 0 ; } } } V->Type = VECTOR ; break ; default : Message::Error("Wrong type of argument for function 'Unit'"); break; } } /* ------------------------------------------------------------------------ */ /* ScalarUnit */ /* ------------------------------------------------------------------------ */ void F_ScalarUnit(F_ARG) { int k ; if (Current.NbrHar == 1) { V->Val[0] = 1. ; } else { for (k = 0 ; k < Current.NbrHar ; k += 2 ) { V->Val[MAX_DIM* k ] = 1. ; V->Val[MAX_DIM*(k+1)] = 0. ; } } V->Type = SCALAR ; } /* ------------------------------------------------------------------------ */ /* Time Functions */ /* ------------------------------------------------------------------------ */ /* Interesting only because it allows the same formal expression in both Time and Frequency domains ! */ /* cos ( w * $Time + phi ) */ void F_Cos_wt_p (F_ARG) { if (Current.NbrHar == 1) V->Val[0] = cos(Fct->Para[0] * Current.Time + Fct->Para[1]) ; else if (Current.NbrHar == 2) { V->Val[0] = cos(Fct->Para[1]) ; V->Val[MAX_DIM] = sin(Fct->Para[1]) ; } else { Message::Error("Too many harmonics for function 'Cos_wt_p'") ; } V->Type = SCALAR ; } /* sin ( w * $Time + phi ) */ void F_Sin_wt_p (F_ARG) { if (Current.NbrHar == 1) V->Val[0] = sin(Fct->Para[0] * Current.Time + Fct->Para[1]) ; else if (Current.NbrHar == 2){ V->Val[0] = sin(Fct->Para[1]) ; V->Val[MAX_DIM] = -cos(Fct->Para[1]) ; } else { Message::Error("Too many harmonics for function 'Sin_wt_p'") ; } V->Type = SCALAR ; } void F_Complex_MH(F_ARG) { int NbrFreq, NbrComp, i, j, k, l ; struct Value R; double * Val_Pulsation ; NbrFreq = Fct->NbrParameters ; NbrComp = Fct->NbrArguments ; if (NbrComp != 2*NbrFreq) Message::Error("Number of components does not equal twice the number " "of frequencies in Complex_MH") ; R.Type = A->Type ; Cal_ZeroValue(&R); if (Current.NbrHar != 1) { Val_Pulsation = Current.DofData->Val_Pulsation ; for (i=0 ; iPara[i]) <= 1e-10 * Val_Pulsation[j]) { for (k=2*j,l=2*i ; k<2*j+2 ; k++,l++) { switch(A->Type){ case SCALAR : R.Val[MAX_DIM*k ] += (A+l)->Val[0] ; break; case VECTOR : case TENSOR_DIAG : R.Val[MAX_DIM*k ] += (A+l)->Val[0] ; R.Val[MAX_DIM*k+1] += (A+l)->Val[1] ; R.Val[MAX_DIM*k+2] += (A+l)->Val[2] ; break; case TENSOR_SYM : R.Val[MAX_DIM*k ] += (A+l)->Val[0] ; R.Val[MAX_DIM*k+1] += (A+l)->Val[1] ; R.Val[MAX_DIM*k+2] += (A+l)->Val[2] ; R.Val[MAX_DIM*k+3] += (A+l)->Val[3] ; R.Val[MAX_DIM*k+4] += (A+l)->Val[4] ; R.Val[MAX_DIM*k+5] += (A+l)->Val[5] ; break; case TENSOR : R.Val[MAX_DIM*k ] += (A+l)->Val[0] ; R.Val[MAX_DIM*k+1] += (A+l)->Val[1] ; R.Val[MAX_DIM*k+2] += (A+l)->Val[2] ; R.Val[MAX_DIM*k+3] += (A+l)->Val[3] ; R.Val[MAX_DIM*k+4] += (A+l)->Val[4] ; R.Val[MAX_DIM*k+5] += (A+l)->Val[5] ; R.Val[MAX_DIM*k+6] += (A+l)->Val[6] ; R.Val[MAX_DIM*k+7] += (A+l)->Val[7] ; R.Val[MAX_DIM*k+8] += (A+l)->Val[8] ; break; default : Message::Error("Unknown type of arguments in function 'Complex_MH'"); break; } } } } } else { /* time domain */ for (i=0 ; iPara[i]*Current.Time), &R) ; Cal_AddMultValue (&R, A+2*i+1, -sin(TWO_PI*Fct->Para[i]*Current.Time), &R) ; } } Cal_CopyValue(&R,V); } /* ------------------------------------------------------------------------ */ /* Period */ /* ------------------------------------------------------------------------ */ void F_Period (F_ARG) { if (Current.NbrHar == 1) V->Val[0] = fmod(A->Val[0], Fct->Para[0]) + ((A->Val[0] < 0.)? Fct->Para[0] : 0.) ; else Message::Error("Function 'F_Period' not valid for Complex"); V->Type = SCALAR ; } /* ------------------------------------------------------------------------ */ /* Interval */ /* ------------------------------------------------------------------------ */ void F_Interval (F_ARG) { int k; double tmp; if (Current.NbrHar == 1) { V->Val[0] = A->Val[0] > (A+1)->Val[0] + Fct->Para[0] * Fct->Para[2] && A->Val[0] < (A+2)->Val[0] + Fct->Para[1] * Fct->Para[2] ; } else { tmp = A->Val[0] > (A+1)->Val[0] + Fct->Para[0] * Fct->Para[2] && A->Val[0] < (A+2)->Val[0] + Fct->Para[1] * Fct->Para[2] ; for (k = 0 ; k < Current.NbrHar ; k += 2) { V->Val[MAX_DIM* k ] = tmp ; V->Val[MAX_DIM*(k+1)] = 0. ; } } V->Type = SCALAR ; } /* ------------------------------------------------------------------------ */ /* Create a Complex Value from k Real Values (of same type!) */ /* ------------------------------------------------------------------------ */ void F_Complex(F_ARG) { /* Warning: this function takes a variable number of arguments (depending on Current.NbrHar). There is no test to check if this number is correct (it just has to be a multiple of 2). */ int k ; switch(A->Type){ case SCALAR : for (k = 0 ; k < Current.NbrHar ; k++) { if((A+k)->Type != A->Type) Message::Error("Mixed type of arguments in function 'Complex'"); V->Val[MAX_DIM*k] = (A+k)->Val[0] ; } break; case VECTOR : case TENSOR_DIAG : for (k = 0 ; k < Current.NbrHar ; k++) { if((A+k)->Type != A->Type) Message::Error("Mixed type of arguments in function 'Complex'"); V->Val[MAX_DIM*k ] = (A+k)->Val[0] ; V->Val[MAX_DIM*k+1] = (A+k)->Val[1] ; V->Val[MAX_DIM*k+2] = (A+k)->Val[2] ; } break; case TENSOR_SYM : for (k = 0 ; k < Current.NbrHar ; k++) { if((A+k)->Type != A->Type) Message::Error("Mixed type of arguments in function 'Complex'"); V->Val[MAX_DIM*k ] = (A+k)->Val[0] ; V->Val[MAX_DIM*k+1] = (A+k)->Val[1] ; V->Val[MAX_DIM*k+2] = (A+k)->Val[2] ; V->Val[MAX_DIM*k+3] = (A+k)->Val[3] ; V->Val[MAX_DIM*k+4] = (A+k)->Val[4] ; V->Val[MAX_DIM*k+5] = (A+k)->Val[5] ; } break; case TENSOR : for (k = 0 ; k < Current.NbrHar ; k++) { if((A+k)->Type != A->Type) Message::Error("Mixed type of arguments in function 'Complex'"); V->Val[MAX_DIM*k ] = (A+k)->Val[0] ; V->Val[MAX_DIM*k+1] = (A+k)->Val[1] ; V->Val[MAX_DIM*k+2] = (A+k)->Val[2] ; V->Val[MAX_DIM*k+3] = (A+k)->Val[3] ; V->Val[MAX_DIM*k+4] = (A+k)->Val[4] ; V->Val[MAX_DIM*k+5] = (A+k)->Val[5] ; V->Val[MAX_DIM*k+6] = (A+k)->Val[6] ; V->Val[MAX_DIM*k+7] = (A+k)->Val[7] ; V->Val[MAX_DIM*k+8] = (A+k)->Val[8] ; } break; default : Message::Error("Unknown type of arguments in function 'Complex'"); break; } V->Type = A->Type ; } /* ----------------------------------------------------------------------- */ /* Get the Real Part of a Value */ /* ------------------------------------------------------------------------ */ void F_Re(F_ARG) { int k ; switch (A->Type) { case SCALAR : for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM*k] = A->Val[MAX_DIM*k] ; V->Val[MAX_DIM*(k+1)] = 0. ; } break; case VECTOR : case TENSOR_DIAG : for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM*k ] = A->Val[MAX_DIM*k ] ; V->Val[MAX_DIM*k+1] = A->Val[MAX_DIM*k+1] ; V->Val[MAX_DIM*k+2] = A->Val[MAX_DIM*k+2] ; V->Val[MAX_DIM*(k+1) ] = 0. ; V->Val[MAX_DIM*(k+1)+1] = 0. ; V->Val[MAX_DIM*(k+1)+2] = 0. ; } break; case TENSOR_SYM : for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM*k ] = A->Val[MAX_DIM*k ] ; V->Val[MAX_DIM*k+1] = A->Val[MAX_DIM*k+1] ; V->Val[MAX_DIM*k+2] = A->Val[MAX_DIM*k+2] ; V->Val[MAX_DIM*k+3] = A->Val[MAX_DIM*k+3] ; V->Val[MAX_DIM*k+4] = A->Val[MAX_DIM*k+4] ; V->Val[MAX_DIM*k+5] = A->Val[MAX_DIM*k+5] ; V->Val[MAX_DIM*(k+1) ] = 0. ; V->Val[MAX_DIM*(k+1)+1] = 0. ; V->Val[MAX_DIM*(k+1)+2] = 0. ; V->Val[MAX_DIM*(k+1)+3] = 0. ; V->Val[MAX_DIM*(k+1)+4] = 0. ; V->Val[MAX_DIM*(k+1)+5] = 0. ; } break; case TENSOR : for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM*k ] = A->Val[MAX_DIM*k ] ; V->Val[MAX_DIM*k+1] = A->Val[MAX_DIM*k+1] ; V->Val[MAX_DIM*k+2] = A->Val[MAX_DIM*k+2] ; V->Val[MAX_DIM*k+3] = A->Val[MAX_DIM*k+3] ; V->Val[MAX_DIM*k+4] = A->Val[MAX_DIM*k+4] ; V->Val[MAX_DIM*k+5] = A->Val[MAX_DIM*k+5] ; V->Val[MAX_DIM*k+6] = A->Val[MAX_DIM*k+6] ; V->Val[MAX_DIM*k+7] = A->Val[MAX_DIM*k+7] ; V->Val[MAX_DIM*k+8] = A->Val[MAX_DIM*k+8] ; V->Val[MAX_DIM*(k+1) ] = 0. ; V->Val[MAX_DIM*(k+1)+1] = 0. ; V->Val[MAX_DIM*(k+1)+2] = 0. ; V->Val[MAX_DIM*(k+1)+3] = 0. ; V->Val[MAX_DIM*(k+1)+4] = 0. ; V->Val[MAX_DIM*(k+1)+5] = 0. ; V->Val[MAX_DIM*(k+1)+6] = 0. ; V->Val[MAX_DIM*(k+1)+7] = 0. ; V->Val[MAX_DIM*(k+1)+8] = 0. ; } break; default : Message::Error("Unknown type of arguments in function 'Re'"); break; } V->Type = A->Type ; } /* ------------------------------------------------------------------------ */ /* Get the Imaginary Part of a Value */ /* ------------------------------------------------------------------------ */ void F_Im(F_ARG) { int k ; switch (A->Type) { case SCALAR : for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM*k] = A->Val[MAX_DIM*(k+1)] ; V->Val[MAX_DIM*(k+1)] = 0. ; } break; case VECTOR : case TENSOR_DIAG : for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM*k ] = A->Val[MAX_DIM*(k+1) ] ; V->Val[MAX_DIM*k+1] = A->Val[MAX_DIM*(k+1)+1] ; V->Val[MAX_DIM*k+2] = A->Val[MAX_DIM*(k+1)+2] ; V->Val[MAX_DIM*(k+1) ] = 0. ; V->Val[MAX_DIM*(k+1)+1] = 0. ; V->Val[MAX_DIM*(k+1)+2] = 0. ; } break; case TENSOR_SYM : for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM*k ] = A->Val[MAX_DIM*(k+1) ] ; V->Val[MAX_DIM*k+1] = A->Val[MAX_DIM*(k+1)+1] ; V->Val[MAX_DIM*k+2] = A->Val[MAX_DIM*(k+1)+2] ; V->Val[MAX_DIM*k+3] = A->Val[MAX_DIM*(k+1)+3] ; V->Val[MAX_DIM*k+4] = A->Val[MAX_DIM*(k+1)+4] ; V->Val[MAX_DIM*k+5] = A->Val[MAX_DIM*(k+1)+5] ; V->Val[MAX_DIM*(k+1) ] = 0. ; V->Val[MAX_DIM*(k+1)+1] = 0. ; V->Val[MAX_DIM*(k+1)+2] = 0. ; V->Val[MAX_DIM*(k+1)+3] = 0. ; V->Val[MAX_DIM*(k+1)+4] = 0. ; V->Val[MAX_DIM*(k+1)+5] = 0. ; } break; case TENSOR : for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM*k ] = A->Val[MAX_DIM*(k+1) ] ; V->Val[MAX_DIM*k+1] = A->Val[MAX_DIM*(k+1)+1] ; V->Val[MAX_DIM*k+2] = A->Val[MAX_DIM*(k+1)+2] ; V->Val[MAX_DIM*k+3] = A->Val[MAX_DIM*(k+1)+3] ; V->Val[MAX_DIM*k+4] = A->Val[MAX_DIM*(k+1)+4] ; V->Val[MAX_DIM*k+5] = A->Val[MAX_DIM*(k+1)+5] ; V->Val[MAX_DIM*k+6] = A->Val[MAX_DIM*(k+1)+6] ; V->Val[MAX_DIM*k+7] = A->Val[MAX_DIM*(k+1)+7] ; V->Val[MAX_DIM*k+8] = A->Val[MAX_DIM*(k+1)+8] ; V->Val[MAX_DIM*(k+1) ] = 0. ; V->Val[MAX_DIM*(k+1)+1] = 0. ; V->Val[MAX_DIM*(k+1)+2] = 0. ; V->Val[MAX_DIM*(k+1)+3] = 0. ; V->Val[MAX_DIM*(k+1)+4] = 0. ; V->Val[MAX_DIM*(k+1)+5] = 0. ; V->Val[MAX_DIM*(k+1)+6] = 0. ; V->Val[MAX_DIM*(k+1)+7] = 0. ; V->Val[MAX_DIM*(k+1)+8] = 0. ; } break; default : Message::Error("Unknown type of arguments in function 'Re'"); break; } V->Type = A->Type ; } /* ------------------------------------------------------------------------ */ /* Conjugate */ /* ------------------------------------------------------------------------ */ void F_Conj(F_ARG) { int k ; switch (A->Type) { case SCALAR : for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM*k] = A->Val[MAX_DIM*k] ; V->Val[MAX_DIM*(k+1)] = -A->Val[MAX_DIM*(k+1)] ; } break; case VECTOR : case TENSOR_DIAG : for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM*k ] = A->Val[MAX_DIM*k ] ; V->Val[MAX_DIM*k+1] = A->Val[MAX_DIM*k+1] ; V->Val[MAX_DIM*k+2] = A->Val[MAX_DIM*k+2] ; V->Val[MAX_DIM*(k+1) ] = -A->Val[MAX_DIM*(k+1) ] ; V->Val[MAX_DIM*(k+1)+1] = -A->Val[MAX_DIM*(k+1)+1] ; V->Val[MAX_DIM*(k+1)+2] = -A->Val[MAX_DIM*(k+1)+2] ; } break; case TENSOR_SYM : for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM*k ] = A->Val[MAX_DIM*k ] ; V->Val[MAX_DIM*k+1] = A->Val[MAX_DIM*k+1] ; V->Val[MAX_DIM*k+2] = A->Val[MAX_DIM*k+2] ; V->Val[MAX_DIM*k+3] = A->Val[MAX_DIM*k+3] ; V->Val[MAX_DIM*k+4] = A->Val[MAX_DIM*k+4] ; V->Val[MAX_DIM*k+5] = A->Val[MAX_DIM*k+5] ; V->Val[MAX_DIM*(k+1) ] = -A->Val[MAX_DIM*(k+1) ] ; V->Val[MAX_DIM*(k+1)+1] = -A->Val[MAX_DIM*(k+1)+1] ; V->Val[MAX_DIM*(k+1)+2] = -A->Val[MAX_DIM*(k+1)+2] ; V->Val[MAX_DIM*(k+1)+3] = -A->Val[MAX_DIM*(k+1)+3] ; V->Val[MAX_DIM*(k+1)+4] = -A->Val[MAX_DIM*(k+1)+4] ; V->Val[MAX_DIM*(k+1)+5] = -A->Val[MAX_DIM*(k+1)+5] ; } break; case TENSOR : for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM*k ] = A->Val[MAX_DIM*k ] ; V->Val[MAX_DIM*k+1] = A->Val[MAX_DIM*k+1] ; V->Val[MAX_DIM*k+2] = A->Val[MAX_DIM*k+2] ; V->Val[MAX_DIM*k+3] = A->Val[MAX_DIM*k+3] ; V->Val[MAX_DIM*k+4] = A->Val[MAX_DIM*k+4] ; V->Val[MAX_DIM*k+5] = A->Val[MAX_DIM*k+5] ; V->Val[MAX_DIM*k+6] = A->Val[MAX_DIM*k+6] ; V->Val[MAX_DIM*k+7] = A->Val[MAX_DIM*k+7] ; V->Val[MAX_DIM*k+8] = A->Val[MAX_DIM*k+8] ; V->Val[MAX_DIM*(k+1) ] = -A->Val[MAX_DIM*(k+1) ] ; V->Val[MAX_DIM*(k+1)+1] = -A->Val[MAX_DIM*(k+1)+1] ; V->Val[MAX_DIM*(k+1)+2] = -A->Val[MAX_DIM*(k+1)+2] ; V->Val[MAX_DIM*(k+1)+3] = -A->Val[MAX_DIM*(k+1)+3] ; V->Val[MAX_DIM*(k+1)+4] = -A->Val[MAX_DIM*(k+1)+4] ; V->Val[MAX_DIM*(k+1)+5] = -A->Val[MAX_DIM*(k+1)+5] ; V->Val[MAX_DIM*(k+1)+6] = -A->Val[MAX_DIM*(k+1)+6] ; V->Val[MAX_DIM*(k+1)+7] = -A->Val[MAX_DIM*(k+1)+7] ; V->Val[MAX_DIM*(k+1)+8] = -A->Val[MAX_DIM*(k+1)+8] ; } break; default : Message::Error("Unknown type of arguments in function 'Conj'"); break; } V->Type = A->Type ; } /* -------------------------------------------------------------------------------- */ /* Cartesian coordinates (Re,Im) to polar coordinates (Amplitude,phase[Radians]) */ /* -------------------------------------------------------------------------------- */ void F_Cart2Pol(F_ARG) { int k ; double Re, Im; switch (A->Type) { case SCALAR : for (k = 0 ; k < Current.NbrHar ; k+=2) { Re = A->Val[MAX_DIM*k] ; Im = A->Val[MAX_DIM*(k+1)] ; V->Val[MAX_DIM*k] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1)] = atan2(Im,Re); } break; case VECTOR : case TENSOR_DIAG : for (k = 0 ; k < Current.NbrHar ; k+=2) { Re = A->Val[MAX_DIM*k ] ; Im = A->Val[MAX_DIM*(k+1) ] ; V->Val[MAX_DIM*k ] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1) ] = atan2(Im,Re); Re = A->Val[MAX_DIM*k+1] ; Im = A->Val[MAX_DIM*(k+1)+1] ; V->Val[MAX_DIM*k+1] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1)+1] = atan2(Im,Re); Re = A->Val[MAX_DIM*k+2] ; Im = A->Val[MAX_DIM*(k+1)+2] ; V->Val[MAX_DIM*k+2] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1)+2] = atan2(Im,Re); } break; case TENSOR_SYM : for (k = 0 ; k < Current.NbrHar ; k+=2) { Re = A->Val[MAX_DIM*k ] ; Im = A->Val[MAX_DIM*(k+1) ] ; V->Val[MAX_DIM*k ] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1) ] = atan2(Im,Re); Re = A->Val[MAX_DIM*k+1] ; Im = A->Val[MAX_DIM*(k+1)+1] ; V->Val[MAX_DIM*k+1] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1)+1] = atan2(Im,Re); Re = A->Val[MAX_DIM*k+2] ; Im = A->Val[MAX_DIM*(k+1)+2] ; V->Val[MAX_DIM*k+2] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1)+2] = atan2(Im,Re); Re = A->Val[MAX_DIM*k+3] ; Im = A->Val[MAX_DIM*(k+1)+3] ; V->Val[MAX_DIM*k+3] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1)+3] = atan2(Im,Re); Re = A->Val[MAX_DIM*k+4] ; Im = A->Val[MAX_DIM*(k+1)+4] ; V->Val[MAX_DIM*k+4] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1)+4] = atan2(Im,Re); Re = A->Val[MAX_DIM*k+5] ; Im = A->Val[MAX_DIM*(k+1)+5] ; V->Val[MAX_DIM*k+5] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1)+5] = atan2(Im,Re); } break; case TENSOR : for (k = 0 ; k < Current.NbrHar ; k+=2) { Re = A->Val[MAX_DIM*k ] ; Im = A->Val[MAX_DIM*(k+1) ] ; V->Val[MAX_DIM*k ] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1) ] = atan2(Im,Re); Re = A->Val[MAX_DIM*k+1] ; Im = A->Val[MAX_DIM*(k+1)+1] ; V->Val[MAX_DIM*k+1] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1)+1] = atan2(Im,Re); Re = A->Val[MAX_DIM*k+2] ; Im = A->Val[MAX_DIM*(k+1)+2] ; V->Val[MAX_DIM*k+2] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1)+2] = atan2(Im,Re); Re = A->Val[MAX_DIM*k+3] ; Im = A->Val[MAX_DIM*(k+1)+3] ; V->Val[MAX_DIM*k+3] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1)+3] = atan2(Im,Re); Re = A->Val[MAX_DIM*k+4] ; Im = A->Val[MAX_DIM*(k+1)+4] ; V->Val[MAX_DIM*k+4] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1)+4] = atan2(Im,Re); Re = A->Val[MAX_DIM*k+5] ; Im = A->Val[MAX_DIM*(k+1)+5] ; V->Val[MAX_DIM*k+5] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1)+5] = atan2(Im,Re); Re = A->Val[MAX_DIM*k+6] ; Im = A->Val[MAX_DIM*(k+1)+6] ; V->Val[MAX_DIM*k+6] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1)+6] = atan2(Im,Re); Re = A->Val[MAX_DIM*k+7] ; Im = A->Val[MAX_DIM*(k+1)+7] ; V->Val[MAX_DIM*k+7] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1)+7] = atan2(Im,Re); Re = A->Val[MAX_DIM*k+8] ; Im = A->Val[MAX_DIM*(k+1)+8] ; V->Val[MAX_DIM*k+8] = sqrt(SQU(Re)+SQU(Im)) ; V->Val[MAX_DIM*(k+1)+8] = atan2(Im,Re); } break; default : Message::Error("Unknown type of arguments in function 'Cart2Pol'"); break; } V->Type = A->Type ; } /* ------------------------------------------------------------------------ */ /* Create 1 Vector from 3 Scalar */ /* ------------------------------------------------------------------------ */ void F_Vector(F_ARG) { int k ; if(A->Type != SCALAR || (A+1)->Type != SCALAR || (A+2)->Type != SCALAR) Message::Error("Non scalar argument(s) for function 'Vector'"); for (k = 0 ; k < Current.NbrHar ; k++) { V->Val[MAX_DIM*k ] = (A )->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+1] = (A+1)->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+2] = (A+2)->Val[MAX_DIM*k] ; } V->Type = VECTOR ; } /* ------------------------------------------------------------------------ */ /* Create 1 Tensor from 9 Scalar */ /* ------------------------------------------------------------------------ */ void F_Tensor(F_ARG) { int k ; if( (A)->Type != SCALAR || (A+1)->Type != SCALAR || (A+2)->Type != SCALAR || (A+3)->Type != SCALAR || (A+4)->Type != SCALAR || (A+5)->Type != SCALAR || (A+6)->Type != SCALAR || (A+7)->Type != SCALAR || (A+8)->Type != SCALAR ) Message::Error("Non scalar argument(s) for function 'Tensor'"); for (k = 0 ; k < Current.NbrHar ; k++) { V->Val[MAX_DIM*k ] = (A )->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+1] = (A+1)->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+2] = (A+2)->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+3] = (A+3)->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+4] = (A+4)->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+5] = (A+5)->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+6] = (A+6)->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+7] = (A+7)->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+8] = (A+8)->Val[MAX_DIM*k] ; } V->Type = TENSOR ; } /* ------------------------------------------------------------------------ */ /* Create 1 Symmetric Tensor from 6 Scalar */ /* ------------------------------------------------------------------------ */ void F_TensorSym(F_ARG) { int k ; if( (A)->Type != SCALAR || (A+1)->Type != SCALAR || (A+2)->Type != SCALAR || (A+3)->Type != SCALAR || (A+4)->Type != SCALAR || (A+5)->Type != SCALAR ) Message::Error("Non scalar argument(s) for function 'TensorSym'"); for (k = 0 ; k < Current.NbrHar ; k++) { V->Val[MAX_DIM*k ] = (A )->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+1] = (A+1)->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+2] = (A+2)->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+3] = (A+3)->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+4] = (A+4)->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+5] = (A+5)->Val[MAX_DIM*k] ; } V->Type = TENSOR_SYM ; } /* ------------------------------------------------------------------------ */ /* Create 1 Diagonal Tensor from 3 Scalar */ /* ------------------------------------------------------------------------ */ void F_TensorDiag(F_ARG) { int k ; if(A->Type != SCALAR || (A+1)->Type != SCALAR || (A+2)->Type != SCALAR) Message::Error("Non scalar argument(s) for function 'TensorDiag'"); for (k = 0 ; k < Current.NbrHar ; k++) { V->Val[MAX_DIM*k ] = A->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+1] = (A+1)->Val[MAX_DIM*k] ; V->Val[MAX_DIM*k+2] = (A+2)->Val[MAX_DIM*k] ; } V->Type = TENSOR_DIAG ; } /* ------------------------------------------------------------------------ */ /* Create 1 Tensor from 3 Vector */ /* ------------------------------------------------------------------------ */ void F_TensorV(F_ARG) { int k ; if((A)->Type != VECTOR || (A+1)->Type != VECTOR || (A+2)->Type != VECTOR) Message::Error("Non scalar argument(s) for function 'TensorV'"); for (k = 0 ; k < Current.NbrHar ; k++) { V->Val[MAX_DIM*k ] = (A )->Val[MAX_DIM*k ] ; V->Val[MAX_DIM*k+1] = (A )->Val[MAX_DIM*k+1] ; V->Val[MAX_DIM*k+2] = (A )->Val[MAX_DIM*k+2] ; V->Val[MAX_DIM*k+3] = (A+1)->Val[MAX_DIM*k ] ; V->Val[MAX_DIM*k+4] = (A+1)->Val[MAX_DIM*k+1] ; V->Val[MAX_DIM*k+5] = (A+1)->Val[MAX_DIM*k+2] ; V->Val[MAX_DIM*k+6] = (A+2)->Val[MAX_DIM*k ] ; V->Val[MAX_DIM*k+7] = (A+2)->Val[MAX_DIM*k+1] ; V->Val[MAX_DIM*k+8] = (A+2)->Val[MAX_DIM*k+2] ; } V->Type = TENSOR ; } /* ------------------------------------------------------------------------ */ /* Dyadic product */ /* ------------------------------------------------------------------------ */ void F_SquDyadicProduct(F_ARG) { int k ; double t11, t12, t13, t22, t23, t33 ; if (A->Type != VECTOR) Message::Error("Non vector argument for function 'TensorDyadic'"); t11 = SQU(A->Val[0]) ; t22 = SQU(A->Val[1]) ; t33 = SQU(A->Val[2]) ; t12 = A->Val[0] * A->Val[1] ; t13 = A->Val[0] * A->Val[2] ; t23 = A->Val[1] * A->Val[2] ; V->Val[0] = t11 ; V->Val[1] = t12 ; V->Val[2] = t13 ; V->Val[3] = t22 ; V->Val[4] = t23 ; V->Val[5] = t33 ; /* Attention : a revoir */ if (Current.NbrHar > 1) { V->Val[MAX_DIM ] = V->Val[MAX_DIM+1] = V->Val[MAX_DIM+2] = V->Val[MAX_DIM+3] = V->Val[MAX_DIM+4] = V->Val[MAX_DIM+5] = 0. ; for (k = 2 ; k < std::min(NBR_MAX_HARMONIC, Current.NbrHar) ; k++) { V->Val[MAX_DIM*k ] = V->Val[MAX_DIM*k+1] = V->Val[MAX_DIM*k+2] = V->Val[MAX_DIM*k+3] = V->Val[MAX_DIM*k+4] = V->Val[MAX_DIM*k+5] = 0. ; } } V->Type = TENSOR_SYM ; } /* ------------------------------------------------------------------------ */ /* Get Vector Components */ /* ------------------------------------------------------------------------ */ #define get_comp_vector(index, string) \ int k ; \ \ if(A->Type != VECTOR) \ Message::Error("Non vector argument for function '" string "'"); \ \ for (k = 0 ; k < Current.NbrHar ; k++) { \ V->Val[MAX_DIM*k ] = A->Val[MAX_DIM*k+index] ; \ } \ V->Type = SCALAR ; void F_CompX(F_ARG){ get_comp_vector(0, "CompX") } void F_CompY(F_ARG){ get_comp_vector(1, "CompY") } void F_CompZ(F_ARG){ get_comp_vector(2, "CompZ") } #undef get_comp_vector /* ------------------------------------------------------------------------ */ /* Get Tensor Components */ /* ------------------------------------------------------------------------ */ #define get_comp_tensor(i, is, id, string) \ int k ; \ \ switch(A->Type) { \ case TENSOR : \ for (k=0; kVal[MAX_DIM*k] = A->Val[MAX_DIM*k+(i)] ; \ break ; \ case TENSOR_SYM : \ for (k=0; kVal[MAX_DIM*k] = A->Val[MAX_DIM*k+(is)] ; \ break ; \ case TENSOR_DIAG : \ if(id >= 0) \ for (k=0; kVal[MAX_DIM*k] = A->Val[MAX_DIM*k+(id)] ; \ else \ for (k=0; kVal[MAX_DIM*k] = 0.; \ break ; \ default : \ Message::Error("Non tensor argument for function '" string "'"); \ break; \ } \ V->Type = SCALAR ; void F_CompXX(F_ARG){ get_comp_tensor(0,0, 0,"CompXX") } void F_CompXY(F_ARG){ get_comp_tensor(1,1,-1,"CompXY") } void F_CompXZ(F_ARG){ get_comp_tensor(2,2,-1,"CompXZ") } void F_CompYX(F_ARG){ get_comp_tensor(3,1,-1,"CompYX") } void F_CompYY(F_ARG){ get_comp_tensor(4,3, 1,"CompYY") } void F_CompYZ(F_ARG){ get_comp_tensor(5,4,-1,"CompYZ") } void F_CompZX(F_ARG){ get_comp_tensor(6,2,-1,"CompZX") } void F_CompZY(F_ARG){ get_comp_tensor(7,4,-1,"CompZY") } void F_CompZZ(F_ARG){ get_comp_tensor(8,5, 2,"CompZZ") } #undef get_comp_tensor /* ------------------------------------------------------------------------ */ /* Get Tensor for transformation of vector */ /* from cartesian to spherical coordinate system */ /* ------------------------------------------------------------------------ */ void F_Cart2Sph(F_ARG) { int k ; double theta, phi ; if((A)->Type != VECTOR) Message::Error("Vector argument required for Function 'Cart2Sph'"); /* Warning! This is the physic's convention. For the math convention, switch theta and phi. */ theta = atan2( sqrt(SQU(A->Val[0])+ SQU(A->Val[1])) , A->Val[2] ) ; phi = atan2( A->Val[1] , A->Val[0] ) ; /* r basis vector */ V->Val[0] = sin(theta) * cos(phi) ; V->Val[1] = sin(theta) * sin(phi) ; V->Val[2] = cos(theta) ; /* theta basis vector */ V->Val[3] = cos(theta) * cos(phi) ; V->Val[4] = cos(theta) * sin(phi) ; V->Val[5] = - sin(theta) ; /* phi basis vector */ V->Val[6] = - sin(phi) ; V->Val[7] = cos(phi) ; V->Val[8] = 0. ; for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM*k ] = V->Val[0] ; V->Val[MAX_DIM*k+1] = V->Val[1] ; V->Val[MAX_DIM*k+2] = V->Val[2] ; V->Val[MAX_DIM*k+3] = V->Val[3] ; V->Val[MAX_DIM*k+4] = V->Val[4] ; V->Val[MAX_DIM*k+5] = V->Val[5] ; V->Val[MAX_DIM*k+6] = V->Val[6] ; V->Val[MAX_DIM*k+7] = V->Val[7] ; V->Val[MAX_DIM*k+8] = V->Val[8] ; V->Val[MAX_DIM*(k+1) ] = 0. ; V->Val[MAX_DIM*(k+1)+1] = 0. ; V->Val[MAX_DIM*(k+1)+2] = 0. ; V->Val[MAX_DIM*(k+1)+3] = 0. ; V->Val[MAX_DIM*(k+1)+4] = 0. ; V->Val[MAX_DIM*(k+1)+5] = 0. ; V->Val[MAX_DIM*(k+1)+6] = 0. ; V->Val[MAX_DIM*(k+1)+7] = 0. ; V->Val[MAX_DIM*(k+1)+8] = 0. ; } V->Type = TENSOR ; } /* ------------------------------------------------------------------------ */ /* Get Tensor for transformation of vector */ /* from cartesian to cylindric coordinate system */ /* vector -> Cart2Cyl[XYZ[]] * vector */ /* (x,y,z)-components -> (radial, tangential, axial)-components */ /* ------------------------------------------------------------------------ */ void F_Cart2Cyl(F_ARG) { int k ; double theta ; if((A)->Type != VECTOR) Message::Error("Vector argument required for Function 'Cart2Cyl'"); theta = atan2(A->Val[1] , A->Val[0]) ; V->Val[0] = cos(theta) ; V->Val[1] = sin(theta) ; V->Val[2] = 0 ; V->Val[3] = -sin(theta) ; V->Val[4] = cos(theta) ; V->Val[5] = 0 ; V->Val[6] = 0 ; V->Val[7] = 0 ; V->Val[8] = 1. ; for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM*k ] = V->Val[0] ; V->Val[MAX_DIM*k+1] = V->Val[1] ; V->Val[MAX_DIM*k+2] = V->Val[2] ; V->Val[MAX_DIM*k+3] = V->Val[3] ; V->Val[MAX_DIM*k+4] = V->Val[4] ; V->Val[MAX_DIM*k+5] = V->Val[5] ; V->Val[MAX_DIM*k+6] = V->Val[6] ; V->Val[MAX_DIM*k+7] = V->Val[7] ; V->Val[MAX_DIM*k+8] = V->Val[8] ; V->Val[MAX_DIM*(k+1) ] = 0. ; V->Val[MAX_DIM*(k+1)+1] = 0. ; V->Val[MAX_DIM*(k+1)+2] = 0. ; V->Val[MAX_DIM*(k+1)+3] = 0. ; V->Val[MAX_DIM*(k+1)+4] = 0. ; V->Val[MAX_DIM*(k+1)+5] = 0. ; V->Val[MAX_DIM*(k+1)+6] = 0. ; V->Val[MAX_DIM*(k+1)+7] = 0. ; V->Val[MAX_DIM*(k+1)+8] = 0. ; } V->Type = TENSOR ; } /* ------------------------------------------------------------------------ */ /* U n i t V e c t o r X, Y, Z */ /* ------------------------------------------------------------------------ */ void F_UnitVectorX(F_ARG) { int k ; for (k = 0 ; k < Current.NbrHar ; k++) { V->Val[MAX_DIM*k ] = (k)? 0.:1. ; V->Val[MAX_DIM*k+1] = 0. ; V->Val[MAX_DIM*k+2] = 0. ; } V->Type = VECTOR ; } void F_UnitVectorY(F_ARG) { int k ; for (k = 0 ; k < Current.NbrHar ; k++) { V->Val[MAX_DIM*k ] = 0. ; V->Val[MAX_DIM*k+1] = (k)? 0.:1. ; V->Val[MAX_DIM*k+2] = 0. ; } V->Type = VECTOR ; } void F_UnitVectorZ(F_ARG) { int k ; for (k = 0 ; k < Current.NbrHar ; k++) { V->Val[MAX_DIM*k ] = 0. ; V->Val[MAX_DIM*k+1] = 0. ; V->Val[MAX_DIM*k+2] = (k)? 0.:1. ; } V->Type = VECTOR ; } getdp-2.4.2-source/Legacy/BF_Node.cpp000644 001750 001750 00000032504 12116424202 020742 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Christophe Trophime // #include "ProData.h" #include "Message.h" #define SQU(a) ((a)*(a)) /* ------------------------------------------------------------------------ */ /* B F _ N o d e */ /* ------------------------------------------------------------------------ */ #define WrongNumNode Message::Error("Wrong Node number in 'BF_Node'") void BF_Node(struct Element * Element, int NumNode, double u, double v, double w, double *s ) { double r; switch (Element->Type) { case POINT : switch(NumNode) { case 1 : *s = 1. ; break ; default : WrongNumNode ; } break ; case LINE : switch(NumNode) { case 1 : *s = 0.5 * (1.-u) ; break ; case 2 : *s = 0.5 * (1.+u) ; break ; default : WrongNumNode ; } break ; case TRIANGLE : switch(NumNode) { case 1 : *s = 1.-u-v ; break ; case 2 : *s = u ; break ; case 3 : *s = v ; break ; default : WrongNumNode ; } break ; case QUADRANGLE : switch(NumNode) { case 1 : *s = 0.25 * (1.-u) * (1.-v) ; break ; case 2 : *s = 0.25 * (1.+u) * (1.-v) ; break ; case 3 : *s = 0.25 * (1.+u) * (1.+v) ; break ; case 4 : *s = 0.25 * (1.-u) * (1.+v) ; break ; default : WrongNumNode ; } break ; case TETRAHEDRON : switch(NumNode) { case 1 : *s = 1.-u-v-w ; break ; case 2 : *s = u ; break ; case 3 : *s = v ; break ; case 4 : *s = w ; break ; default : WrongNumNode ; } break ; case HEXAHEDRON : switch(NumNode) { case 1 : *s = (1.-u) * (1.-v) * (1.-w) * 0.125 ; break ; case 2 : *s = (1.+u) * (1.-v) * (1.-w) * 0.125 ; break ; case 3 : *s = (1.+u) * (1.+v) * (1.-w) * 0.125 ; break ; case 4 : *s = (1.-u) * (1.+v) * (1.-w) * 0.125 ; break ; case 5 : *s = (1.-u) * (1.-v) * (1.+w) * 0.125 ; break ; case 6 : *s = (1.+u) * (1.-v) * (1.+w) * 0.125 ; break ; case 7 : *s = (1.+u) * (1.+v) * (1.+w) * 0.125 ; break ; case 8 : *s = (1.-u) * (1.+v) * (1.+w) * 0.125 ; break ; default : WrongNumNode ; } break ; case PRISM : switch(NumNode) { case 1 : *s = (1.-u-v) * (1.-w) * 0.5 ; break ; case 2 : *s = u * (1.-w) * 0.5 ; break ; case 3 : *s = v * (1.-w) * 0.5 ; break ; case 4 : *s = (1.-u-v) * (1.+w) * 0.5 ; break ; case 5 : *s = u * (1.+w) * 0.5 ; break ; case 6 : *s = v * (1.+w) * 0.5 ; break ; default : WrongNumNode ; } break ; case PYRAMID : if(w != 1. && NumNode != 5) r = u*v*w / (1.-w) ; else r = 0. ; switch(NumNode) { case 1 : *s = 0.25 * ((1.-u) * (1.-v) - w + r); break ; case 2 : *s = 0.25 * ((1.+u) * (1.-v) - w - r); break ; case 3 : *s = 0.25 * ((1.+u) * (1.+v) - w + r); break ; case 4 : *s = 0.25 * ((1.-u) * (1.+v) - w - r); break ; case 5 : *s = w ; break ; default : WrongNumNode ; } break ; case LINE_2 : switch(NumNode) { case 1 : *s = 0.5*u*(u-1.) ; break ; case 2 : *s = 0.5*u*(1.+u) ; break ; case 3 : *s = 1.-u*u ; break ; default : WrongNumNode ; } break ; case TRIANGLE_2 : r = 1.-u-v ; switch(NumNode) { case 1 : *s = r*(2.*r-1.) ; break ; case 2 : *s = u*(2.*u-1.) ; break ; case 3 : *s = v*(2.*v-1.) ; break ; case 4 : *s = 4.*r*u ; break ; case 5 : *s = 4.*u*v ; break ; case 6 : *s = 4.*v*r ; break ; default : WrongNumNode ; } break ; case QUADRANGLE_2 : switch(NumNode) { case 1 : *s = 0.25 * (1.-u) * (1.-v) * u * v ; break ; case 2 : *s = -0.25 * (1.+u) * (1.-v) * u * v ; break ; case 3 : *s = 0.25 * (1.+u) * (1.+v) * u * v ; break ; case 4 : *s = -0.25 * (1.-u) * (1.+v) * u * v ; break ; case 5 : *s = -0.5 * (1.-u*u)* (1.-v) * v ; break ; case 6 : *s = 0.5 * (1.+u) * (1.-v*v)* u ; break ; case 7 : *s = 0.5 * (1.-u*u)* (1.+v) * v ; break ; case 8 : *s = -0.5 * (1.-u) * (1.-v*v)* u ; break ; case 9 : *s = (1.-u*u)* (1.-v*v) ; break ; default : WrongNumNode ; } break ; case QUADRANGLE_2_8N : switch(NumNode) { case 1 : *s = -0.25 * (1.-u) * (1.-v) * (1.+u+v) ; break ; case 2 : *s = -0.25 * (1.+u) * (1.-v) * (1.-u+v) ; break ; case 3 : *s = -0.25 * (1.+u) * (1.+v) * (1.-u-v) ; break ; case 4 : *s = -0.25 * (1.-u) * (1.+v) * (1.+u-v) ; break ; case 5 : *s = 0.5 * (1.-u*u)* (1.-v) ; break ; case 6 : *s = 0.5 * (1.+u) * (1.-v*v) ; break ; case 7 : *s = 0.5 * (1.-u*u)* (1.+v) ; break ; case 8 : *s = 0.5 * (1.-u) * (1.-v*v) ; break ; default : WrongNumNode ; } break ; default : Message::Error("Unknown type of Element in BF_Node"); break; } } #undef WrongNumNode /* ------------------------------------------------------------------------ */ /* B F _ G r a d N o d e */ /* ------------------------------------------------------------------------ */ #define WrongNumNode Message::Error("Wrong Node number in 'BF_GradNode'") void BF_GradNode(struct Element * Element, int NumNode, double u, double v, double w, double s[]) { double r; switch (Element->Type) { case POINT : switch(NumNode) { case 1 : s[0] = 0. ; s[1] = 0. ; s[2] = 0. ; break ; default : WrongNumNode ; } break ; case LINE : switch(NumNode) { case 1 : s[0] = -0.5 ; s[1] = 0. ; s[2] = 0. ; break ; case 2 : s[0] = 0.5 ; s[1] = 0. ; s[2] = 0. ; break ; default : WrongNumNode ; } break ; case TRIANGLE : switch(NumNode) { case 1 : s[0] = -1. ; s[1] = -1. ; s[2] = 0. ; break ; case 2 : s[0] = 1. ; s[1] = 0. ; s[2] = 0. ; break ; case 3 : s[0] = 0. ; s[1] = 1. ; s[2] = 0. ; break ; default : WrongNumNode ; } break ; case QUADRANGLE : switch(NumNode) { case 1 : s[0] = -0.25 * (1.-v) ; s[1] = -0.25 * (1.-u) ; s[2] = 0. ; break ; case 2 : s[0] = 0.25 * (1.-v) ; s[1] = -0.25 * (1.+u) ; s[2] = 0. ; break ; case 3 : s[0] = 0.25 * (1.+v) ; s[1] = 0.25 * (1.+u) ; s[2] = 0. ; break ; case 4 : s[0] = -0.25 * (1.+v) ; s[1] = 0.25 * (1.-u) ; s[2] = 0. ; break ; default : WrongNumNode ; } break ; case TETRAHEDRON : switch(NumNode) { case 1 : s[0] = -1. ; s[1] = -1. ; s[2] = -1. ; break ; case 2 : s[0] = 1. ; s[1] = 0. ; s[2] = 0. ; break ; case 3 : s[0] = 0. ; s[1] = 1. ; s[2] = 0. ; break ; case 4 : s[0] = 0. ; s[1] = 0. ; s[2] = 1. ; break ; default : WrongNumNode ; } break ; case HEXAHEDRON : switch(NumNode) { case 1 : s[0] = -0.125 * (1.-v) * (1.-w) ; s[1] = -0.125 * (1.-u) * (1.-w) ; s[2] = -0.125 * (1.-u) * (1.-v) ; break ; case 2 : s[0] = 0.125 * (1.-v) * (1.-w) ; s[1] = -0.125 * (1.+u) * (1.-w) ; s[2] = -0.125 * (1.+u) * (1.-v) ; break ; case 3 : s[0] = 0.125 * (1.+v) * (1.-w) ; s[1] = 0.125 * (1.+u) * (1.-w) ; s[2] = -0.125 * (1.+u) * (1.+v) ; break ; case 4 : s[0] = -0.125 * (1.+v) * (1.-w) ; s[1] = 0.125 * (1.-u) * (1.-w) ; s[2] = -0.125 * (1.-u) * (1.+v) ; break ; case 5 : s[0] = -0.125 * (1.-v) * (1.+w) ; s[1] = -0.125 * (1.-u) * (1.+w) ; s[2] = 0.125 * (1.-u) * (1.-v) ; break ; case 6 : s[0] = 0.125 * (1.-v) * (1.+w) ; s[1] = -0.125 * (1.+u) * (1.+w) ; s[2] = 0.125 * (1.+u) * (1.-v) ; break ; case 7 : s[0] = 0.125 * (1.+v) * (1.+w) ; s[1] = 0.125 * (1.+u) * (1.+w) ; s[2] = 0.125 * (1.+u) * (1.+v) ; break ; case 8 : s[0] = -0.125 * (1.+v) * (1.+w) ; s[1] = 0.125 * (1.-u) * (1.+w) ; s[2] = 0.125 * (1.-u) * (1.+v) ; break ; default : WrongNumNode ; } break ; case PRISM : switch(NumNode) { case 1 : s[0] = -0.5 * (1.-w) ; s[1] = -0.5 * (1.-w) ; s[2] = -0.5 * (1.-u-v) ; break ; case 2 : s[0] = 0.5 * (1.-w) ; s[1] = 0. ; s[2] = -0.5 * u ; break ; case 3 : s[0] = 0. ; s[1] = 0.5 * (1.-w) ; s[2] = -0.5 * v ; break ; case 4 : s[0] = -0.5 * (1.+w) ; s[1] = -0.5 * (1.+w) ; s[2] = 0.5 * (1.-u-v) ; break ; case 5 : s[0] = 0.5 * (1.+w) ; s[1] = 0. ; s[2] = 0.5 * u ; break ; case 6 : s[0] = 0. ; s[1] = 0.5 * (1.+w) ; s[2] = 0.5 * v ; break ; default : WrongNumNode ; } break ; case PYRAMID : if(w == 1. && NumNode != 5) { //When w = 1 => u=v=0 switch(NumNode) { case 1 : s[0] = -0.25 ; s[1] = -0.25 ; s[2] = -0.25 ; break ; case 2 : s[0] = 0.25 ; s[1] = -0.25 ; s[2] = -0.25 ; break ; case 3 : s[0] = 0.25 ; s[1] = 0.25 ; s[2] = -0.25 ; break ; case 4 : s[0] = -0.25 ; s[1] = 0.25 ; s[2] = -0.25 ; break ; case 5 : s[0] = 0. ; s[1] = 0. ; s[2] = 1. ; break ; default : WrongNumNode ; } } else{ switch(NumNode) { case 1 : s[0] = 0.25 * ( v/(1 - w) - 1) ; s[1] = 0.25 * ( u/(1 - w) - 1) ; s[2] = 0.25 * ( u*v/SQU(1 - w) - 1) ; break ; case 2 : s[0] = 0.25 * (-v/(1 - w) + 1) ; s[1] = 0.25 * (-u/(1 - w) - 1) ; s[2] = 0.25 * (-u*v/SQU(1 - w) - 1) ; break ; case 3 : s[0] = 0.25 * ( v/(1 - w) + 1) ; s[1] = 0.25 * ( u/(1 - w) + 1) ; s[2] = 0.25 * ( u*v/SQU(1 - w) - 1) ; break ; case 4 : s[0] = 0.25 * (-v/(1 - w) - 1) ; s[1] = 0.25 * (-u/(1 - w) + 1) ; s[2] = 0.25 * (-u*v/SQU(1 - w) - 1) ; break ; case 5 : s[0] = 0. ; s[1] = 0. ; s[2] = 1. ; break ; default : WrongNumNode ; } } break ; case LINE_2 : switch(NumNode) { case 1 : s[0] = -0.5+u ; s[1] = 0. ; s[2] = 0. ; break ; case 2 : s[0] = 0.5+u ; s[1] = 0. ; s[2] = 0. ; break ; case 3 : s[0] = -2.*u ; s[1] = 0. ; s[2] = 0. ; break ; default : WrongNumNode ; } break ; case TRIANGLE_2 : r = 1.-u-v ; switch(NumNode) { case 1 : s[0] = 1.-4.*r ; s[1] = 1.-4.*r ; s[2] = 0. ; break ; case 2 : s[0] =-1.+4.*u ; s[1] = 0. ; s[2] = 0. ; break ; case 3 : s[0] = 0. ; s[1] =-1.+4.*v ; s[2] = 0. ; break ; case 4 : s[0] = 4.*(r-u); s[1] = -4.*u ; s[2] = 0. ; break ; case 5 : s[0] = 4.*v ; s[1] = 4.*u ; s[2] = 0. ; break ; case 6 : s[0] =-4.*v ; s[1] = 4.*(r-v); s[2] = 0. ; break ; default : WrongNumNode ; } break ; case QUADRANGLE_2 : switch(NumNode) { case 1 : s[0] = 0.25 * (1.-2.*u) * (1.-v) * v ; s[1] = 0.25 * (1.-u) * (1.-2.*v) * u ; s[2] = 0. ; break ; case 2 : s[0] = -0.25 * (1.+2.*u) * (1.-v) * v ; s[1] = -0.25 * (1.+u) * (1.-2.*v) * u ; s[2] = 0. ; break ; case 3 : s[0] = 0.25 * (1.+2.*u) * (1.+v) * v ; s[1] = 0.25 * (1.+u) * (1.+2.*v) * u ; s[2] = 0. ; break ; case 4 : s[0] = -0.25 * (1.-2.*u) * (1.+v) * v ; s[1] = -0.25 * (1.-u) * (1.+2.*v) * u ; s[2] = 0. ; break ; case 5 : s[0] = (1.-v) * u * v ; s[1] = -0.5 * (1.-u*u) * (1.-2.*v) ; s[2] = 0. ; break ; case 6 : s[0] = 0.5 * (1.+2.*u) * (1.-v*v) ; s[1] = -(1.+u) * u * v ; s[2] = 0. ; break ; case 7 : s[0] = -(1.+v) * u * v ; s[1] = 0.5 * (1.-u*u) * (1.+2.*v) ; s[2] = 0. ; break ; case 8 : s[0] = -0.5 * (1.-2.*u) * (1.-v*v) ; s[1] = (1.-u) * u * v ; s[2] = 0. ; break ; case 9 : s[0] = -2. * (1.-v*v) * u ; s[1] = -2. * (1.-u*u) * v ; s[2] = 0. ; break ; default : WrongNumNode ; } break ; case QUADRANGLE_2_8N : switch(NumNode) { case 1 : s[0] = 0.25 * (1.-v) * (2.*u+v) ; s[1] = 0.25 * (1.-u) * (u+2.*v) ; s[2] = 0. ; break ; case 2 : s[0] = 0.25 * (1.-v) * (2.*u-v) ; s[1] = -0.25 * (1.+u) * (u-2.*v) ; s[2] = 0. ; break ; case 3 : s[0] = 0.25 * (1.+v) * (2.*u+v) ; s[1] = 0.25 * (1.+u) * (u+2.*v) ; s[2] = 0. ; break ; case 4 : s[0] = 0.25 * (1.+v) * (2.*u-v) ; s[1] = -0.25 * (1.-u) * (u-2.*v) ; s[2] = 0. ; break ; case 5 : s[0] = -(1.-v) * u ; s[1] = -0.5 * (1.-u*u) ; s[2] = 0. ; break ; case 6 : s[0] = 0.5 * (1.-v*v) ; s[1] = -(1.+u) * v ; s[2] = 0. ; break ; case 7 : s[0] = -(1.+v) * u ; s[1] = 0.5 * (1.-u*u) ; s[2] = 0. ; break ; case 8 : s[0] = -0.5 * (1.-v*v) ; s[1] = -(1.-u) * v ; s[2] = 0. ; break ; default : WrongNumNode ; } break ; default : Message::Error("Unknown type of Element in BF_GradNode"); break; } } #undef WrongNumNode getdp-2.4.2-source/Legacy/Operation_IterativeLoopN.cpp000644 001750 001750 00000031023 12205340470 024430 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Michael Asam #include #include "ProData.h" #include "DofData.h" #include "SolvingOperations.h" #include "SolvingAnalyse.h" #include "Message.h" #include "Cal_Quantity.h" extern struct CurrentData Current; extern int Flag_IterativeLoopN; extern int Flag_IterativeLoopConverged; /* ------------------------------------------------------------------------ */ /* C a l M a x E r r o r R a t i o */ /* ------------------------------------------------------------------------ */ double CalcMaxErrorRatio(Resolution *Resolution_P, DofData *DofData_P0, List_T *ILsystems_L, List_T *LEPostOp_L, List_T *xPrevious_L, List_T *PostOpSolutionPrevious_L) { DofData *DofData_P=NULL; DefineSystem *DefineSystem_P; IterativeLoopSystem ILsystem; LoopErrorPostOperation ILPostOp; PostOpSolutions *PostOpSolutions_P; Solution *Solution_P; gVector *xPrevious_P, *xCurrent_P; // new and last solution vector gVector xError; // Local Truncation Error vector int NbrSolutions, PostOpSolLength; double ErrorRatio, MaxErrorRatio; MaxErrorRatio = 0.; // Loop through all given systems for(int i = 0; i < List_Nbr(ILsystems_L); i++){ List_Read(ILsystems_L, i, &ILsystem); DofData_P = DofData_P0 + ILsystem.SystemIndex; DefineSystem_P = (DefineSystem*)List_Pointer(Resolution_P->DefineSystem, ILsystem.SystemIndex); xPrevious_P = (gVector*)List_Pointer(xPrevious_L, i); xCurrent_P = &DofData_P->CurrentSolution->x; LinAlg_CreateVector(&xError, &DofData_P->Solver, DofData_P->NbrDof); switch (ILsystem.NormOf) { case SOLUTION: // Vector of errors: xError = xCurrent - xPrevious LinAlg_CopyVector(xCurrent_P, &xError); LinAlg_SubVectorVector(&xError, xPrevious_P, &xError); Cal_SolutionErrorRatio(&xError, xCurrent_P, ILsystem.SystemILreltol, ILsystem.SystemILabstol, ILsystem.NormType, &ErrorRatio); break; case RECALCRESIDUAL: // Calculating the actual residual: xError = b(xn)-A(xn)*xn // Works also for "Solve" but its computational expensive ReGenerate_System(DefineSystem_P, DofData_P, DofData_P0, 1); LinAlg_ProdMatrixVector(&DofData_P->A, &DofData_P->CurrentSolution->x, &xError); LinAlg_SubVectorVector(&DofData_P->b, &xError, &xError); Cal_SolutionErrorRatio(&xError, &DofData_P->b, ILsystem.SystemILreltol, ILsystem.SystemILabstol, ILsystem.NormType, &ErrorRatio); break; case RESIDUAL: // Or alternatively look at the old residual (from e.g. SolveJac) // -> More efficient but causes one extra iteration Cal_SolutionErrorRatio(&DofData_P->res, &DofData_P->b, ILsystem.SystemILreltol, ILsystem.SystemILabstol, ILsystem.NormType, &ErrorRatio); break; default: Message::Error("Unknown object for error norm"); break; } LinAlg_DestroyVector(&xError); if (ErrorRatio != ErrorRatio) { // If ErrorRatio = NaN MaxErrorRatio = ErrorRatio; break; } else if (ErrorRatio > MaxErrorRatio) MaxErrorRatio = ErrorRatio; if (Message::GetVerbosity() > 5) { Message::Info("IterativeLoopN: %s of %s error ratio from system %s: %.3g", ILsystem.NormTypeString, ILsystem.NormOfString, DefineSystem_P->Name, ErrorRatio); } } // Loop through all specified PostOperations for(int i = 0; i < List_Nbr(LEPostOp_L); i++){ List_Read(LEPostOp_L, i, &ILPostOp); PostOpSolutions_P = (struct PostOpSolutions*) List_Pointer(Current.PostOpData_L, i); NbrSolutions = List_Nbr(PostOpSolutions_P->Solutions_L); Solution_P = (struct Solution*)List_Pointer(PostOpSolutions_P->Solutions_L, NbrSolutions-1); xPrevious_P = (gVector*)List_Pointer(PostOpSolutionPrevious_L, i); xCurrent_P = &Solution_P->x; LinAlg_GetVectorSize(xCurrent_P, &PostOpSolLength); LinAlg_CreateVector(&xError, &DofData_P0->Solver, PostOpSolLength); // Vector of errors: xError = xCurrent - xPrevious LinAlg_CopyVector(xCurrent_P, &xError); LinAlg_SubVectorVector(&xError, xPrevious_P, &xError); Cal_SolutionErrorRatio(&xError, xCurrent_P, ILPostOp.PostOperationReltol, ILPostOp.PostOperationAbstol, ILPostOp.NormType, &ErrorRatio); LinAlg_DestroyVector(&xError); if (ErrorRatio != ErrorRatio) { // If ErrorRatio = NaN MaxErrorRatio = ErrorRatio; break; } else if (ErrorRatio > MaxErrorRatio) MaxErrorRatio = ErrorRatio; if (Message::GetVerbosity() > 5) { Message::Info("IterativeLoopN: %s error ratio from PostOperation %s: %.3g", ILPostOp.NormTypeString, ILPostOp.PostOperationName, ErrorRatio); } } return MaxErrorRatio; } /* ------------------------------------------------------------------------ */ /* O p e r a t i o n _ I t e r a t i v e L o o p N */ /* ------------------------------------------------------------------------ */ void Operation_IterativeLoopN(Resolution *Resolution_P, Operation *Operation_P, DofData *DofData_P0, GeoData *GeoData_P0, Resolution *Resolution2_P, DofData *DofData2_P0, int *Flag_Break) { int NbrMaxIteration, RelaxationFactorIndex; int Num_Iteration, NbrPostOps, SavePostOpDataIndex, NbrSolutions; double Save_Iteration, MaxErrorRatio; List_T *ILsystems_L, *LEPostOp_L, *xPrevious_L; List_T *LEPostOpNames_L, *PostOpSolutionPrevious_L; List_T *SavePostOpData_L; gVector *xPrevious_P, *PostOpResultPrevious_P; Value Value; DofData *DofData_P=NULL; IterativeLoopSystem ILsystem; PostOpSolutions *PostOpSolutions_P; Solution *Solution_P; NbrMaxIteration = Operation_P->Case.IterativeLoop.NbrMaxIteration; RelaxationFactorIndex = Operation_P->Case.IterativeLoop.RelaxationFactorIndex; ILsystems_L = Operation_P->Case.IterativeLoop.IterativeLoopSystems_L; LEPostOp_L = Operation_P->Case.IterativeLoop.IterativeLoopPOs_L; if (ILsystems_L == NULL) ILsystems_L = List_Create(1,1,sizeof(TimeLoopAdaptiveSystem)); if (LEPostOp_L == NULL) LEPostOp_L = List_Create(1,1,sizeof(LoopErrorPostOperation)); xPrevious_L = List_Create(4,4,sizeof(gVector)); PostOpSolutionPrevious_L = List_Create(4,4,sizeof(gVector)); // Just some checks and initialization // ----------------------------------- // Check if initial solutions for all specified systems are available for(int i = 0; i < List_Nbr(ILsystems_L); i++){ List_Read(ILsystems_L, i, &ILsystem); DefineSystem *sys = (DefineSystem*)List_Pointer(Resolution_P->DefineSystem, ILsystem.SystemIndex); DofData_P = DofData_P0 + ILsystem.SystemIndex; if(!List_Nbr(DofData_P->Solutions)) Message::Error("No initial solution for system %s", sys->Name); gVector xPrevious_S; LinAlg_CreateVector(&xPrevious_S, &DofData_P->Solver, DofData_P->NbrDof); List_Add(xPrevious_L, &xPrevious_S); } // Initializing stuff for PostOperations SavePostOpData_L = Current.PostOpData_L; Current.PostOpData_L = NULL; SavePostOpDataIndex = Current.PostOpDataIndex; Current.PostOpDataIndex = -1; NbrPostOps = List_Nbr(LEPostOp_L); LEPostOpNames_L = List_Create(NbrPostOps,1,sizeof(char *)); InitLEPostOperation(Resolution_P, DofData_P0, GeoData_P0, LEPostOp_L, LEPostOpNames_L, PostOpSolutionPrevious_L); // Iterative loop // ---------------- Save_Iteration = Current.Iteration ; for (Num_Iteration = 1; Num_Iteration <= NbrMaxIteration; Num_Iteration++) { Flag_IterativeLoopN = 1; if(Message::GetOnelabAction() == "stop" || Message::GetErrorCount()) break; Current.Iteration = (double)Num_Iteration; Get_ValueOfExpressionByIndex(RelaxationFactorIndex, NULL, 0., 0., 0., &Value); Current.RelaxationFactor = Value.Val[0]; // Store the current solutions in xPrevious_L for(int i = 0; i < List_Nbr(ILsystems_L); i++){ List_Read(ILsystems_L, i, &ILsystem); DofData_P = DofData_P0 + ILsystem.SystemIndex; xPrevious_P = (gVector*)List_Pointer(xPrevious_L, i); LinAlg_CopyVector(&DofData_P->CurrentSolution->x, xPrevious_P); } // Store the current PostOperation results in PostOpSolutionPrevious_L if (NbrPostOps != List_Nbr(Current.PostOpData_L)) Message::Error("Current.PostOpData_L list is not up to date"); for(int i = 0; i < NbrPostOps; i++){ PostOpSolutions_P = (struct PostOpSolutions*) List_Pointer(Current.PostOpData_L, i); NbrSolutions = List_Nbr(PostOpSolutions_P->Solutions_L); if (!NbrSolutions) Message::Error("No initial result for PostOperation %s", PostOpSolutions_P->PostOperation_P->Name); Solution_P = (struct Solution*)List_Pointer(PostOpSolutions_P->Solutions_L, NbrSolutions-1); PostOpResultPrevious_P = (gVector*)List_Pointer(PostOpSolutionPrevious_L, i); LinAlg_CopyVector(&Solution_P->x, PostOpResultPrevious_P); } Message::Info("IterativeLoopN: Non linear iteration %d (Relaxation = %g)", (int)Current.Iteration, Current.RelaxationFactor) ; Treatment_Operation(Resolution_P, Operation_P->Case.IterativeLoop.Operation, DofData_P0, GeoData_P0, Resolution2_P, DofData2_P0) ; if(*Flag_Break) { *Flag_Break = 0; Message::Info("Flag Break detected. Aborting IterativeLoop"); break; } else if (Message::GetLastPETScError()) { Message::Warning("No valid solution found (PETSc-Error: %d)! " "Aborting IterativeLoopN", Message::GetLastPETScError()); break; } else if (NbrPostOps) // Execute the PostOperations if necessary Operation_PostOperation(Resolution_P, DofData_P0, GeoData_P0, LEPostOpNames_L); // Check if converged MaxErrorRatio = CalcMaxErrorRatio(Resolution_P,DofData_P0, ILsystems_L, LEPostOp_L, xPrevious_L, PostOpSolutionPrevious_L); if (MaxErrorRatio != MaxErrorRatio) { // If ErrorRatio = NaN => There was no valid solution! Flag_IterativeLoopConverged = 0; break; } Message::Info("IterativeLoopN: Largest error ratio: %.3g (after %d iteration%s)", MaxErrorRatio, (int)Current.Iteration, ((int)Current.Iteration == 1) ? "" : "s"); if(Message::GetProgressMeterStep() > 0 && Message::GetProgressMeterStep() < 100) Message::AddOnelabNumberChoice(Message::GetOnelabClientName() + "/IterativeLoop/ILmaxErrorRatio", MaxErrorRatio); if (MaxErrorRatio < 1.) { Message::Info("IterativeLoopN: Converged after %d iteration%s", (int)Current.Iteration, ((int)Current.Iteration==1)?"":"s"); break; } } if (Num_Iteration > NbrMaxIteration) { Num_Iteration = NbrMaxIteration; Flag_IterativeLoopConverged = 0; Message::Info("IterativeLoopN: Max iteration count reached! No convergence!"); } Current.Iteration = Save_Iteration ; Flag_IterativeLoopN = 0; // Finally destroy vectors and delete Lists // ---------------------------------------- for(int i = 0; i < List_Nbr(ILsystems_L); i++) LinAlg_DestroyVector((gVector*)List_Pointer(xPrevious_L, i)); List_Delete(xPrevious_L); ClearLEPostOperation(Resolution_P, DofData_P0, GeoData_P0, LEPostOp_L, LEPostOpNames_L, PostOpSolutionPrevious_L, false); Current.PostOpData_L = SavePostOpData_L; Current.PostOpDataIndex = SavePostOpDataIndex; } getdp-2.4.2-source/Legacy/Cal_IntegralQuantity.cpp000644 001750 001750 00000030126 12116424202 023567 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "ProData.h" #include "ProDefine.h" #include "BF.h" #include "Cal_Quantity.h" #include "Cal_Value.h" #include "Get_Geometry.h" #include "Get_FunctionValue.h" #include "Message.h" extern struct Problem Problem_S ; extern struct CurrentData Current ; /* ----------------------------------------------------------------------------- */ /* C a l _ I n i t I n t e g r a l Q u a n t i t y */ /* ----------------------------------------------------------------------------- */ void Cal_InitIntegralQuantity(struct Element *Element, struct IntegralQuantityActive *IQA, struct QuantityStorage *QuantityStorage_P) { struct Quadrature *Quadrature_P ; struct Group *Group_P ; int ElementSourceType ; int i,j ; /* Get de Rham cells in the source element if necessary */ Group_P = (struct Group*)List_Pointer(Problem_S.Group, QuantityStorage_P->DefineQuantity-> IntegralQuantity.InIndex) ; ElementSourceType = Element->ElementSource->Type ; /* Get integration method */ IQA->IntegrationCase_P = Get_IntegrationCase(Element, IQA->IntegrationCase_L, IQA->CriterionIndex); switch(IQA->IntegrationCase_P->Type) { /* Numerical Integration */ case GAUSS : case GAUSSLEGENDRE : Quadrature_P = (struct Quadrature*) List_PQuery(IQA->IntegrationCase_P->Case, &ElementSourceType, fcmp_int) ; if(!Quadrature_P){ Message::Error("Unknown type of Element (%s) for Integration method (%s)", Get_StringForDefine(Element_Type, ElementSourceType), ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, QuantityStorage_P->DefineQuantity->IntegralQuantity. IntegrationMethodIndex))->Name); return; } IQA->Nbr_IntPoints = Quadrature_P->NumberOfPoints ; IQA->Get_IntPoint = Quadrature_P->Function ; IQA->xChangeOfCoordinates = (void (*)())Get_ChangeOfCoordinates(1, IQA->Type_FormDof) ; i = 0 ; while ((i < List_Nbr(IQA->JacobianCase_L)) && ((j = ((struct JacobianCase *)List_Pointer(IQA->JacobianCase_L, i)) ->RegionIndex) >= 0) && !List_Search (((struct Group *)List_Pointer(Problem_S.Group, j)) ->InitialList, &Element->ElementSource->Region, fcmp_int) ) i++ ; if (i == List_Nbr(IQA->JacobianCase_L)){ Message::Error("Undefined Jacobian in Region %d", Element->ElementSource->Region); return; } Element->ElementSource->JacobianCase = (struct JacobianCase*)List_Pointer(IQA->JacobianCase_L, i) ; IQA->Get_Jacobian = (double (*)())Get_JacobianFunction (Element->ElementSource->JacobianCase->TypeJacobian, ElementSourceType, &IQA->Type_Dimension) ; if(QuantityStorage_P->DefineQuantity->IntegralQuantity.Symmetry){ Message::Error("Symmetries of integral kernels not ready with numerical integration"); return; } break; /* Analytical Integration (the jacobian method is not defined, since we also express the basis functions analytically) */ case ANALYTIC : switch(QuantityStorage_P->DefineQuantity->IntegralQuantity.CanonicalWholeQuantity){ case CWQ_GF : case CWQ_GF_PSCA_DOF : case CWQ_GF_PSCA_EXP : case CWQ_GF_PVEC_EXP : case CWQ_EXP_TIME_GF_PSCA_DOF : break ; case CWQ_GF_PVEC_DOF : case CWQ_EXP_TIME_GF_PVEC_DOF : default : Message::Error("Unrecognized Integral Quantity to integrate analytically"); return; } break ; default : Message::Error("Unknown type of Integration method (%s) for Integral Quantity", ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, QuantityStorage_P->DefineQuantity->IntegralQuantity. IntegrationMethodIndex))->Name); return; } IQA->Type_ValueDof = Get_ValueFromForm(IQA->Type_FormDof); } /* ----------------------------------------------------------------------------- */ /* A p p l y _ C o n s t a n t F a c t o r */ /* ----------------------------------------------------------------------------- */ void Apply_ConstantFactor(struct QuantityStorage * QuantityStorage_P, struct Value * vBFxDof, struct Value * Val) { switch(QuantityStorage_P->DefineQuantity->IntegralQuantity.CanonicalWholeQuantity){ case CWQ_GF : case CWQ_GF_PSCA_DOF : case CWQ_GF_PVEC_DOF : case CWQ_DOF_PVEC_GF : break ; case CWQ_GF_PSCA_EXP : case CWQ_EXP_TIME_GF_PSCA_DOF : case CWQ_EXP_TIME_GF_PVEC_DOF : case CWQ_FCT_TIME_GF_PSCA_DOF : case CWQ_FCT_TIME_GF_PVEC_DOF : Cal_ProductValue(Val, vBFxDof, vBFxDof); break; case CWQ_GF_PVEC_EXP : Cal_CrossProductValue(vBFxDof, Val, vBFxDof); break; case CWQ_EXP_PVEC_GF : case CWQ_EXP_PVEC_GF_PSCA_DOF : case CWQ_EXP_PVEC_GF_PVEC_DOF : case CWQ_FCT_PVEC_GF_PSCA_DOF : case CWQ_FCT_PVEC_GF_PVEC_DOF : Cal_CrossProductValue(Val, vBFxDof, vBFxDof); break; default : Message::Error("Unknown type of canonical Integral Quantity"); return; } } /* ------------------------------------------------------------------------------- */ /* C a l _ N u m e r i c a l I n t e g r a l Q u a n t i t y */ /* ------------------------------------------------------------------------------- */ void Cal_NumericalIntegralQuantity(struct Element *Element, struct IntegralQuantityActive *IQA, struct QuantityStorage *QuantityStorage_P0, struct QuantityStorage *QuantityStorage_P, int Type_DefineQuantity, int Nbr_Dof, void (*xFunctionBF[])(), struct Value vBFxDof[]) { struct Value vBFx[NBR_MAX_BASISFUNCTIONS] ; int i, j, i_IntPoint ; double Factor, weight ; double vBFu[NBR_MAX_BASISFUNCTIONS] [MAX_DIM] ; struct Element *ES ; /* This routine is valid for all QUADRATURE cases: GAUSS, GAUSSLEGENDRE */ if (Element->Num != NO_ELEMENT) { Current.x = Current.y = Current.z = 0. ; for (i = 0 ; i < Element->GeoElement->NbrNodes ; i++) { Current.x += Element->x[i] * Element->n[i] ; Current.y += Element->y[i] * Element->n[i] ; Current.z += Element->z[i] * Element->n[i] ; } } Current.Element = Element ; Current.ElementSource = Element->ElementSource ; for (j = 0 ; j < Nbr_Dof ; j++) Cal_ZeroValue(&vBFxDof[j]); ES = Element->ElementSource ; for (i_IntPoint = 0 ; i_IntPoint < IQA->Nbr_IntPoints ; i_IntPoint++) { ((void (*)(int,int,double*,double*,double*,double*)) IQA->Get_IntPoint) (IQA->Nbr_IntPoints, i_IntPoint, &Current.us, &Current.vs, &Current.ws, &weight) ; Get_BFGeoElement (ES, Current.us, Current.vs, Current.ws) ; ES->DetJac = ((double (*)(struct Element*, MATRIX3x3*)) IQA->Get_Jacobian) (ES, &ES->Jac) ; if(IQA->Type_FormDof == FORM1) Get_InverseMatrix(IQA->Type_Dimension, ES->Type, ES->DetJac, &ES->Jac, &ES->InvJac) ; Current.xs = Current.ys = Current.zs = 0. ; for (i = 0 ; i < ES->GeoElement->NbrNodes ; i++) { Current.xs += ES->x[i] * ES->n[i] ; Current.ys += ES->y[i] * ES->n[i] ; Current.zs += ES->z[i] * ES->n[i] ; } if(Type_DefineQuantity != NODOF){ for (j = 0 ; j < Nbr_Dof ; j++) { ((void (*)(struct Element*, int, double, double, double, double*)) xFunctionBF[j]) (Element->ElementSource, QuantityStorage_P->BasisFunction[j].NumEntityInElement+1, Current.us, Current.vs, Current.ws, vBFu[j]) ; ((void (*)(struct Element*, double*, double*)) IQA->xChangeOfCoordinates) (Element->ElementSource, vBFu[j], vBFx[j].Val) ; vBFx[j].Type = IQA->Type_ValueDof ; Cal_SetHarmonicValue(&vBFx[j]); } } Factor = weight * fabs(ES->DetJac) ; Current.Region = Element->ElementSource->Region ; /* Il faudrait definir le cas canonique Function[] * Dof */ Cal_WholeQuantity (Element->ElementSource, QuantityStorage_P0, QuantityStorage_P->DefineQuantity->IntegralQuantity.WholeQuantity, Current.us, Current.vs, Current.ws, QuantityStorage_P->DefineQuantity->IntegralQuantity.DofIndexInWholeQuantity, Nbr_Dof, vBFx) ; Current.Region = Element->Region ; for (j = 0 ; j < Nbr_Dof ; j++) { vBFxDof[j].Type = vBFx[j].Type ; Cal_AddMultValue(&vBFxDof[j],&vBFx[j],Factor,&vBFxDof[j]); } } } /* ------------------------------------------------------------------------------- */ /* C a l _ A n a l y t i c I n t e g r a l Q u a n t i t y */ /* ------------------------------------------------------------------------------- */ void Cal_AnalyticIntegralQuantity(struct Element *Element, struct QuantityStorage *QuantityStorage_P, int Nbr_Dof, void (*xFunctionBF[])(), struct Value vBFxDof[]) { struct Value Val0 ; int i, j ; if (Element->Num != NO_ELEMENT) { Current.x = Current.y = Current.z = 0. ; for (i = 0 ; i < Element->GeoElement->NbrNodes ; i++) { Current.x += Element->x[i] * Element->n[i] ; Current.y += Element->y[i] * Element->n[i] ; Current.z += Element->z[i] * Element->n[i] ; } } Current.Element = Element ; Current.ElementSource = Element->ElementSource ; switch(QuantityStorage_P->DefineQuantity->IntegralQuantity.CanonicalWholeQuantity){ case CWQ_GF : case CWQ_GF_PSCA_DOF : break ; case CWQ_GF_PVEC_DOF : case CWQ_EXP_TIME_GF_PVEC_DOF : Message::Error("Vector product of GF_Function and Dof{} not done for analytic integration"); return ; case CWQ_GF_PSCA_EXP : case CWQ_GF_PVEC_EXP : case CWQ_EXP_TIME_GF_PSCA_DOF : Current.ElementSource = Element->ElementSource ; Current.Region = Element->ElementSource->Region ; Get_ValueOfExpression((struct Expression *) List_Pointer(Problem_S.Expression, QuantityStorage_P->DefineQuantity->IntegralQuantity. ExpressionIndexForCanonical), NULL, 0., 0., 0., &Val0) ; Current.Region = Element->Region ; break ; default : Message::Error("Unknown type of canonical Integral Quantity"); return; } for (j = 0 ; j < Nbr_Dof ; j++) { ((void (*)(struct Element*, struct Function *, void(*)(), int, double, double, double, struct Value *)) QuantityStorage_P->DefineQuantity->IntegralQuantity.FunctionForCanonical.Fct) (Element, &QuantityStorage_P->DefineQuantity->IntegralQuantity.FunctionForCanonical, xFunctionBF[j], QuantityStorage_P->BasisFunction[j].NumEntityInElement+1, Current.x, Current.y, Current.z, &vBFxDof[j]) ; Apply_ConstantFactor(QuantityStorage_P, &vBFxDof[j], &Val0) ; } switch(QuantityStorage_P->DefineQuantity->IntegralQuantity.Symmetry) { case 0 : /* No Symmetry */ break; case 1 : /* y -> -y */ for (i = 0 ; i < Element->ElementSource->GeoElement->NbrNodes ; i++) Element->ElementSource->y[i] *= -1. ; for (j = 0 ; j < Nbr_Dof ; j++) { ((void (*)(struct Element*, struct Function *, void(*)(), int, double, double, double, struct Value *)) QuantityStorage_P->DefineQuantity->IntegralQuantity.FunctionForCanonical.Fct) (Element, &QuantityStorage_P->DefineQuantity->IntegralQuantity.FunctionForCanonical, xFunctionBF[j], QuantityStorage_P->BasisFunction[j].NumEntityInElement+1, Current.x, Current.y, Current.z, &Val0) ; Apply_ConstantFactor(QuantityStorage_P, &vBFxDof[j], &Val0) ; if (vBFxDof[j].Type == SCALAR) { vBFxDof[j].Val[0] -= Val0.Val[0] ; } else { vBFxDof[j].Val[0] -= Val0.Val[0] ; vBFxDof[j].Val[1] -= Val0.Val[1] ; vBFxDof[j].Val[2] -= Val0.Val[2] ; } } for (i = 0 ; i < Element->ElementSource->GeoElement->NbrNodes ; i++) Element->ElementSource->y[i] *= -1. ; break; default: Message::Error("Unknown type of symmetry in Integral Quantity"); break; } } getdp-2.4.2-source/Legacy/Pre_TermOfFemEquation.h000644 001750 001750 00000002533 12116424202 023312 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _PRE_TERM_OF_FEM_EQUATION_H_ #define _PRE_TERM_OF_FEM_EQUATION_H_ #include "ProData.h" void Pre_InitTermOfFemEquation(struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0); void Pre_TermOfFemEquation(struct Element * Element, struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0); void Pre_InitGlobalTermOfFemEquation(struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0); void Pre_GlobalTermOfFemEquation(int Num_Region, struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0); void Pre_FemGlobalEquation(struct EquationTerm * EquationTerm_P, struct DefineQuantity * DefineQuantity_P0, struct QuantityStorage * QuantityStorage_P0); void Cst_TermOfFemEquation(struct Element * Element, struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0); void Cst_GlobalTermOfFemEquation(int Num_Region, struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0); #endif getdp-2.4.2-source/Legacy/GeoEntity.cpp000644 001750 001750 00000054251 12116424202 021420 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "GeoData.h" #include "ProData.h" #include "GeoEntity.h" #include "MallocUtils.h" #include "Message.h" extern FILE * File_PRE ; extern struct GeoData * CurrentGeoData ; extern int Flag_XDATA ; /* ------------------------------------------------------------------------ */ /* G e o _ G e t N o d e s _ u v w */ /* ------------------------------------------------------------------------ */ double * Geo_GetNodes_uvw(int Type, int *nbn) { switch(Type){ case POINT : *nbn = NbrNodes_Point ; return(*Nodes_Point) ; case LINE : *nbn = NbrNodes_Line ; return(*Nodes_Line) ; case TRIANGLE : *nbn = NbrNodes_Triangle ; return(*Nodes_Triangle) ; case QUADRANGLE : *nbn = NbrNodes_Quadrangle ; return(*Nodes_Quadrangle) ; case TETRAHEDRON : *nbn = NbrNodes_Tetrahedron ; return(*Nodes_Tetrahedron) ; case HEXAHEDRON : *nbn = NbrNodes_Hexahedron ; return(*Nodes_Hexahedron) ; case PRISM : *nbn = NbrNodes_Prism ; return(*Nodes_Prism) ; case PYRAMID : *nbn = NbrNodes_Pyramid ; return(*Nodes_Pyramid) ; case LINE_2 : *nbn = NbrNodes_Line_2 ; return(*Nodes_Line_2) ; case TRIANGLE_2 : *nbn = NbrNodes_Triangle_2 ; return(*Nodes_Triangle_2) ; case QUADRANGLE_2: *nbn = NbrNodes_Quadrangle_2 ;return(*Nodes_Quadrangle_2) ; case QUADRANGLE_2_8N: *nbn = NbrNodes_Quadrangle_2_8N ;return(*Nodes_Quadrangle_2_8N); default : Message::Error("Unknown type of Element in Geo_GetNodes_uvw") ; return(NULL) ; } } /* ------------------------------------------------------------------------ */ /* G e o _ C r e a t e E d g e s O f E l e m e n t */ /* ------------------------------------------------------------------------ */ void Geo_CreateEdgesOfElement(struct Geo_Element * Geo_Element) { int Nbr_Entities2, * D_Element ; D_Element = Geo_GetIM_Den(Geo_Element->Type, &Nbr_Entities2) ; Geo_CreateEntitiesOfElement(Nbr_Entities2, D_Element, Geo_Element->NbrNodes, Geo_Element->NumNodes, &Geo_Element->NbrEdges, &Geo_Element->NumEdges, &CurrentGeoData->NbrElementsWithEdges, &CurrentGeoData->NumCurrentEdge, CurrentGeoData->EdgesXNodes) ; } /* ------------------------------------------------------------------------ */ /* G e o _ G e t N o d e s O f E d g e I n E l e m e n t */ /* ------------------------------------------------------------------------ */ int *Geo_GetNodesOfEdgeInElement(struct Geo_Element * Geo_Element, int Num_Edge) { int Nbr_Entities2 ; return( Geo_GetIM_Den(Geo_Element->Type, &Nbr_Entities2) + Num_Edge * NBR_MAX_SUBENTITIES_IN_ELEMENT ) ; } /* ------------------------------------------------------------------------ */ /* G e o _ G e t N o d e s O f F a c e t I n E l e m e n t */ /* ------------------------------------------------------------------------ */ int *Geo_GetNodesOfFacetInElement(struct Geo_Element * Geo_Element, int Num_Facet) { int Nbr_Entities2 ; return( Geo_GetIM_Dfn(Geo_Element->Type, &Nbr_Entities2) + Num_Facet * NBR_MAX_SUBENTITIES_IN_ELEMENT ) ; } /* ------------------------------------------------------------------------ */ /* G e o _ C r e a t e F a c e t s O f E l e m e n t */ /* ------------------------------------------------------------------------ */ void Geo_CreateFacetsOfElement(struct Geo_Element * Geo_Element) { int Nbr_Entities2, * D_Element ; D_Element = Geo_GetIM_Dfe(Geo_Element->Type, &Nbr_Entities2) ; Geo_CreateEntitiesOfElement(Nbr_Entities2, D_Element, Geo_Element->NbrEdges, Geo_Element->NumEdges, &Geo_Element->NbrFacets, &Geo_Element->NumFacets, &CurrentGeoData->NbrElementsWithFacets, &CurrentGeoData->NumCurrentFacet, CurrentGeoData->FacetsXEdges) ; } /* ------------------------------------------------------------------------ */ /* G e o _ G e t I M _ D e n */ /* ------------------------------------------------------------------------ */ int *Geo_GetIM_Den(int Type_Element, int * Nbe) { switch (Type_Element) { case POINT : *Nbe = NbrEdges_Point ; return(NULL) ; case LINE : *Nbe = NbrEdges_Line ; return(*Den_Line) ; case TRIANGLE : *Nbe = NbrEdges_Triangle ; return(*Den_Triangle) ; case QUADRANGLE : *Nbe = NbrEdges_Quadrangle ; return(*Den_Quadrangle) ; case TETRAHEDRON : *Nbe = NbrEdges_Tetrahedron ; return(*Den_Tetrahedron) ; case HEXAHEDRON : *Nbe = NbrEdges_Hexahedron ; return(*Den_Hexahedron) ; case PRISM : *Nbe = NbrEdges_Prism ; return(*Den_Prism) ; case PYRAMID : *Nbe = NbrEdges_Pyramid ; return(*Den_Pyramid) ; case LINE_2 : *Nbe = NbrEdges_Line_2 ; return(*Den_Line_2) ; case TRIANGLE_2 : *Nbe = NbrEdges_Triangle_2 ; return(*Den_Triangle_2) ; case QUADRANGLE_2 :*Nbe = NbrEdges_Quadrangle_2; return(*Den_Quadrangle_2) ; case QUADRANGLE_2_8N :*Nbe = NbrEdges_Quadrangle_2_8N; return(*Den_Quadrangle_2_8N) ; default : Message::Error("Unknown incidence matrix for element type %d", Type_Element); return(NULL) ; } } /* ------------------------------------------------------------------------ */ /* G e o _ G e t I M _ D f e */ /* ------------------------------------------------------------------------ */ int *Geo_GetIM_Dfe(int Type_Element, int * Nbf) { switch (Type_Element) { case POINT : *Nbf = NbrFacets_Point ; return(NULL) ; case LINE : *Nbf = NbrFacets_Line ; return(NULL) ; case TRIANGLE : *Nbf = NbrFacets_Triangle ; return(*Dfe_Triangle) ; case QUADRANGLE : *Nbf = NbrFacets_Quadrangle ; return(*Dfe_Quadrangle) ; case TETRAHEDRON : *Nbf = NbrFacets_Tetrahedron ; return(*Dfe_Tetrahedron) ; case HEXAHEDRON : *Nbf = NbrFacets_Hexahedron ; return(*Dfe_Hexahedron) ; case PRISM : *Nbf = NbrFacets_Prism ; return(*Dfe_Prism) ; case PYRAMID : *Nbf = NbrFacets_Pyramid ; return(*Dfe_Pyramid) ; case LINE_2 : *Nbf = NbrFacets_Line_2 ; return(NULL) ; case TRIANGLE_2 : *Nbf = NbrFacets_Triangle_2 ; return(*Dfe_Triangle_2) ; case QUADRANGLE_2 :*Nbf = NbrFacets_Quadrangle_2; return(*Dfe_Quadrangle_2) ; case QUADRANGLE_2_8N :*Nbf = NbrFacets_Quadrangle_2_8N; return(*Dfe_Quadrangle_2_8N) ; default : Message::Error("Unknown incidence matrix for element type %d", Type_Element); return(NULL) ; } } /* ------------------------------------------------------------------------ */ /* G e o _ G e t I M _ D f n */ /* ------------------------------------------------------------------------ */ int *Geo_GetIM_Dfn(int Type_Element, int * Nbf) { switch (Type_Element) { case POINT : *Nbf = NbrFacets_Point ; return(NULL) ; case LINE : *Nbf = NbrFacets_Line ; return(NULL) ; case TRIANGLE : *Nbf = NbrFacets_Triangle ; return(*Dfn_Triangle) ; case QUADRANGLE : *Nbf = NbrFacets_Quadrangle ; return(*Dfn_Quadrangle) ; case TETRAHEDRON :*Nbf = NbrFacets_Tetrahedron ; return(*Dfn_Tetrahedron) ; case HEXAHEDRON : *Nbf = NbrFacets_Hexahedron ; return(*Dfn_Hexahedron) ; case PRISM : *Nbf = NbrFacets_Prism ; return(*Dfn_Prism) ; case PYRAMID : *Nbf = NbrFacets_Pyramid ; return(*Dfn_Pyramid) ; case LINE_2 : *Nbf = NbrFacets_Line_2 ; return(NULL) ; case TRIANGLE_2 : *Nbf = NbrFacets_Triangle_2 ; return(*Dfn_Triangle_2) ; case QUADRANGLE_2:*Nbf = NbrFacets_Quadrangle_2; return(*Dfn_Quadrangle_2) ; case QUADRANGLE_2_8N:*Nbf = NbrFacets_Quadrangle_2_8N; return(*Dfn_Quadrangle_2_8N) ; default : Message::Error("Unknown incidence matrix for element type %d", Type_Element); return(NULL) ; } } /* ------------------------------------------------------------------------ */ /* G e o _ G e t I M _ D e n _ X p */ /* ------------------------------------------------------------------------ */ int * Geo_GetIM_Den_Xp(int Type_Element, int * Nbe, int * Nbn) { switch (Type_Element) { case POINT : *Nbe = NbrEdges_Point ; *Nbn = NbrNodes_Point ; return(NULL) ; case LINE : *Nbe = NbrEdges_Line ; *Nbn = NbrNodes_Line ; return(Den_Line_Xp) ; case TRIANGLE : *Nbe = NbrEdges_Triangle ; *Nbn = NbrNodes_Triangle ; return(Den_Triangle_Xp) ; case QUADRANGLE : *Nbe = NbrEdges_Quadrangle ; *Nbn = NbrNodes_Quadrangle ; return(Den_Quadrangle_Xp) ; case TETRAHEDRON : *Nbe = NbrEdges_Tetrahedron ; *Nbn = NbrNodes_Tetrahedron ; return(Den_Tetrahedron_Xp) ; case HEXAHEDRON : *Nbe = NbrEdges_Hexahedron ; *Nbn = NbrNodes_Hexahedron ; return(Den_Hexahedron_Xp) ; case PRISM : *Nbe = NbrEdges_Prism ; *Nbn = NbrNodes_Prism ; return(Den_Prism_Xp) ; case PYRAMID : *Nbe = NbrEdges_Pyramid ; *Nbn = NbrNodes_Pyramid ; return(Den_Pyramid_Xp) ; case LINE_2 : *Nbe = NbrEdges_Line_2 ; *Nbn = NbrNodes_Line_2 ; return(Den_Line_2_Xp) ; case TRIANGLE_2 : *Nbe = NbrEdges_Triangle_2 ; *Nbn = NbrNodes_Triangle_2 ; return(Den_Triangle_2_Xp) ; case QUADRANGLE_2 : *Nbe = NbrEdges_Quadrangle_2 ; *Nbn = NbrNodes_Quadrangle_2 ; return(Den_Quadrangle_2_Xp) ; case QUADRANGLE_2_8N : *Nbe = NbrEdges_Quadrangle_2_8N ; *Nbn = NbrNodes_Quadrangle_2_8N ; return(Den_Quadrangle_2_8N_Xp) ; default : Message::Error("Unknown incidence matrix for element type %d", Type_Element); return(NULL) ; } } /* ------------------------------------------------------------------------ */ /* G e o _ G e t I M _ D f e _ X p */ /* ------------------------------------------------------------------------ */ int * Geo_GetIM_Dfe_Xp(int Type_Element, int * nbf, int * nbe) { switch (Type_Element) { case POINT : *nbf = NbrFacets_Point ; *nbe = NbrEdges_Point ; return(NULL) ; case LINE : *nbf = NbrFacets_Line ; *nbe = NbrEdges_Line ; return(NULL) ; case TRIANGLE : *nbf = NbrFacets_Triangle ; *nbe = NbrEdges_Triangle ; return(Dfe_Triangle_Xp) ; case QUADRANGLE : *nbf = NbrFacets_Quadrangle ; *nbe = NbrEdges_Quadrangle ; return(Dfe_Quadrangle_Xp) ; case TETRAHEDRON : *nbf = NbrFacets_Tetrahedron ; *nbe = NbrEdges_Tetrahedron ; return(Dfe_Tetrahedron_Xp) ; case HEXAHEDRON : *nbf = NbrFacets_Hexahedron ; *nbe = NbrEdges_Hexahedron ; return(Dfe_Hexahedron_Xp) ; case PRISM : *nbf = NbrFacets_Prism ; *nbe = NbrEdges_Prism ; return(Dfe_Prism_Xp) ; case PYRAMID : *nbf = NbrFacets_Pyramid ; *nbe = NbrEdges_Pyramid ; return(Dfe_Pyramid_Xp) ; case LINE_2 : *nbf = NbrFacets_Line_2 ; *nbe = NbrEdges_Line_2 ; return(NULL) ; case TRIANGLE_2 : *nbf = NbrFacets_Triangle_2 ; *nbe = NbrEdges_Triangle_2 ; return(Dfe_Triangle_2_Xp) ; case QUADRANGLE_2 : *nbf = NbrFacets_Quadrangle_2 ; *nbe = NbrEdges_Quadrangle_2 ; return(Dfe_Quadrangle_2_Xp) ; case QUADRANGLE_2_8N : *nbf = NbrFacets_Quadrangle_2_8N ; *nbe = NbrEdges_Quadrangle_2_8N ; return(Dfe_Quadrangle_2_8N_Xp) ; default : Message::Error("Unknown incidence matrix for element type %d", Type_Element); return(NULL) ; } } /* ------------------------------------------------------------------------ */ /* G e o _ C r e a t e E n t i t i e s O f E l e m e n t */ /* ------------------------------------------------------------------------ */ void Geo_CreateEntitiesOfElement (int Nbr_Entities2, int * D_Element, int Geo_Element_NbrEntities1, int * Geo_Element_NumEntities1, int * Geo_Element_NbrEntities2, int ** Geo_Element_NumEntities2, int * Geo_NbrElementsWithEntities2, int * Geo_NumCurrentEntity2, Tree_T * Geo_Entities2XEntities1) { int i, j, Nbr_Entities1, Num_Entities1[NBR_MAX_SUBENTITIES_IN_ELEMENT], Sign_Entity2 ; int * Entity_P, Entity ; struct Entity2XEntity1 Entity2XEntities1, * Entity2XEntities1_P ; *Geo_Element_NbrEntities2 = Nbr_Entities2 ; *Geo_Element_NumEntities2 = (int *)Malloc(Nbr_Entities2 * sizeof(int)) ; (*Geo_NbrElementsWithEntities2)++ ; for (i = 0 ; i < Nbr_Entities2 ; i++) { Entity_P = D_Element + i * NBR_MAX_SUBENTITIES_IN_ELEMENT ; Nbr_Entities1 = 0 ; while ((Entity = *(Entity_P++))) Num_Entities1[Nbr_Entities1++] = (Entity > 0)? Geo_Element_NumEntities1[Entity-1] : - Geo_Element_NumEntities1[-Entity-1] ; qsort(Num_Entities1, Nbr_Entities1, sizeof(int), fcmp_absint) ; if (Num_Entities1[0] < 0) { Sign_Entity2 = -1 ; for (j = 0 ; j < Nbr_Entities1 ; j++) Num_Entities1[j] *= -1 ; } else Sign_Entity2 = 1 ; Entity2XEntities1.NbrEntities = Nbr_Entities1 ; Entity2XEntities1.NumEntities = Num_Entities1 ; if ((Entity2XEntities1_P = (struct Entity2XEntity1*) Tree_PQuery(Geo_Entities2XEntities1, &Entity2XEntities1)) == NULL) { Entity2XEntities1.Num = ++(*Geo_NumCurrentEntity2) ; Entity2XEntities1.NumEntities = (int *)Malloc(Nbr_Entities1*sizeof(int)) ; for (j = 0 ; j < Nbr_Entities1 ; j++) Entity2XEntities1.NumEntities[j] = Num_Entities1[j] ; Tree_Add(Geo_Entities2XEntities1, &Entity2XEntities1) ; (*Geo_Element_NumEntities2)[i] = Entity2XEntities1.Num * Sign_Entity2 ; } else (*Geo_Element_NumEntities2)[i] = Entity2XEntities1_P->Num * Sign_Entity2 ; } } /* ------------------------------------------------------------------------ */ /* f c m p _ E 2 X E 1 */ /* ------------------------------------------------------------------------ */ int fcmp_E2XE1(const void * a, const void * b) { int i ; if (((struct Entity2XEntity1 *)a)->NbrEntities != ((struct Entity2XEntity1 *)b)->NbrEntities) return ((struct Entity2XEntity1 *)a)->NbrEntities - ((struct Entity2XEntity1 *)b)->NbrEntities ; for (i = 0 ; i < ((struct Entity2XEntity1 *)a)->NbrEntities ; i++) { if (((struct Entity2XEntity1 *)a)->NumEntities[i] > ((struct Entity2XEntity1 *)b)->NumEntities[i]) return 1 ; if (((struct Entity2XEntity1 *)a)->NumEntities[i] < ((struct Entity2XEntity1 *)b)->NumEntities[i]) return -1 ; } return 0 ; } /* ------------------------------------------------------------------------ */ /* f r e e _ E 2 X E 1 */ /* ------------------------------------------------------------------------ */ void free_E2XE1(void * a, void *b) { Free(((struct Entity2XEntity1 *)a)->NumEntities); } /* ------------------------------------------------------------------------ */ /* G e o _ W r i t e F i l e P R E */ /* ------------------------------------------------------------------------ */ void Geo_WriteFilePRE(struct GeoData * GeoData_P, List_T * Group_L) { if(Message::GetIsCommWorld() && Message::GetCommRank()) return; int i, Nbr_Elements, j, Index_Group, Nbr_Entities, * Num_Entities ; struct Geo_Element * Geo_Element_P0, * Geo_Element_P ; struct Group * Group_P ; Nbr_Elements = List_Nbr(GeoData_P->Elements) ; /* E l e m e n t s X E d g e s */ if (Nbr_Elements && GeoData_P->NumCurrentEdge) { fprintf(File_PRE, "$ElementsXEdges\n") ; fprintf(File_PRE, "%d %d\n", GeoData_P->Num, GeoData_P->NbrElementsWithEdges) ; Geo_Element_P0 = (struct Geo_Element*)List_Pointer(GeoData_P->Elements, 0) ; for (i = 0 ; i < Nbr_Elements ; i++) { if ((Geo_Element_P0 + i)->NbrEdges) { Geo_Element_P = Geo_Element_P0 + i ; fprintf(File_PRE, "%d %d", i, Geo_Element_P->NbrEdges) ; for (j = 0 ; j < Geo_Element_P->NbrEdges ; j++) fprintf(File_PRE, " %d", Geo_Element_P->NumEdges[j]) ; fprintf(File_PRE, "\n") ; } } fprintf(File_PRE, "$EndElementsXEdges\n") ; if (Flag_XDATA) { fprintf(File_PRE, "$EdgesXNodes /* Never used, only for test */\n") ; fprintf(File_PRE, "%d %d\n", GeoData_P->Num, Tree_Nbr(GeoData_P->EdgesXNodes)) ; Tree_Action(GeoData_P->EdgesXNodes, Geo_WriteEntities2XEntities1) ; fprintf(File_PRE, "$EndEdgesXNodes\n") ; } } /* E l e m e n t s X F a c e t s */ if (Nbr_Elements && GeoData_P->NumCurrentFacet) { fprintf(File_PRE, "$ElementsXFacets\n") ; fprintf(File_PRE, "%d %d\n", GeoData_P->Num, GeoData_P->NbrElementsWithFacets) ; Geo_Element_P0 = (struct Geo_Element*)List_Pointer(GeoData_P->Elements, 0) ; for (i = 0 ; i < Nbr_Elements ; i++) { if ((Geo_Element_P0 + i)->NbrFacets) { Geo_Element_P = Geo_Element_P0 + i ; fprintf(File_PRE, "%d %d", i, Geo_Element_P->NbrFacets) ; for (j = 0 ; j < Geo_Element_P->NbrFacets ; j++) fprintf(File_PRE, " %d", Geo_Element_P->NumFacets[j]) ; fprintf(File_PRE, "\n") ; } } fprintf(File_PRE, "$EndElementsXFacets\n") ; if (Flag_XDATA) { fprintf(File_PRE, "$FacetsXEdges /* Never used, only for test */\n") ; fprintf(File_PRE, "%d %d\n", GeoData_P->Num, Tree_Nbr(GeoData_P->FacetsXEdges)) ; Tree_Action(GeoData_P->FacetsXEdges, Geo_WriteEntities2XEntities1) ; fprintf(File_PRE, "$EndFacetsXEdges\n") ; } } /* E x t e n d e d G r o u p */ if (GeoData_P->GroupForPRE != NULL) { for (i = 0 ; i < List_Nbr(GeoData_P->GroupForPRE) ; i++) { List_Read(GeoData_P->GroupForPRE, i, &Index_Group) ; Group_P = (struct Group*)List_Pointer(Group_L, Index_Group) ; fprintf(File_PRE, "$ExtendedGroup /* %s */\n", Group_P->Name) ; fprintf(File_PRE, "%d %d\n", Index_Group, Nbr_Entities = List_Nbr(Group_P->ExtendedList)) ; if (Nbr_Entities) { Num_Entities = (int*)List_Pointer(Group_P->ExtendedList, 0) ; for (j = 0 ; j < Nbr_Entities ; j++) { fprintf(File_PRE, (j%10)? " %d" : "%d", Num_Entities[j]) ; if (j%10 == 9) fprintf(File_PRE, "\n") ; } if (j%10) fprintf(File_PRE, "\n") ; fprintf(File_PRE, "$EndExtendedGroup\n") ; } } } } /* --------------------------------------------------------- */ /* G e o _ W r i t e E n t i t i e s 2 X E n t i t i e s 1 */ /* --------------------------------------------------------- */ void Geo_WriteEntities2XEntities1(void * a, void * b) { int i ; fprintf(File_PRE, "%d %d", ((struct Entity2XEntity1 *)a)->Num, ((struct Entity2XEntity1 *)a)->NbrEntities) ; for (i = 0 ; i < ((struct Entity2XEntity1 *)a)->NbrEntities ; i++) fprintf(File_PRE, " %d", ((struct Entity2XEntity1 *)a)->NumEntities[i]) ; fprintf(File_PRE, "\n") ; } /* ------------------------------------------------------------------------ */ /* G e o _ R e a d F i l e P R E */ /* ------------------------------------------------------------------------ */ void Geo_ReadFilePRE(struct GeoData * GeoData_P0, int NbrGeoData, List_T * Group_L) { Message::Barrier(); struct GeoData * GeoData_P ; struct Geo_Element * Geo_Element_P0, * Geo_Element_P ; struct Group * Group_P ; int i, Index_Element, Nbr_Entities, j, Index_Group, Num_Entity ; int GeoDataIndex ; char String[256] ; for(GeoDataIndex = 0 ; GeoDataIndex < NbrGeoData ; GeoDataIndex++){ if(!(GeoData_P0 + GeoDataIndex)->Elements){ Message::Warning("No Element in GeoData %d", GeoDataIndex); return; } } while (1) { do { fgets(String, sizeof(String), File_PRE) ; if (feof(File_PRE)) break ; } while (String[0] != '$') ; if (feof(File_PRE)) break ; /* E l e m e n t s X E d g e s */ if (!strncmp(&String[1], "ElementsXEdges", 14)) { fscanf(File_PRE, "%d", &GeoDataIndex) ; if(GeoDataIndex > NbrGeoData-1){ Message::Error("Unknown GeoData: %d", GeoDataIndex); return; } GeoData_P = GeoData_P0 + GeoDataIndex ; Geo_Element_P0 = (struct Geo_Element*)List_Pointer(GeoData_P->Elements, 0) ; fscanf(File_PRE, "%d", &GeoData_P->NbrElementsWithEdges) ; for (i = 0 ; i < GeoData_P->NbrElementsWithEdges ; i++) { fscanf(File_PRE, "%d %d", &Index_Element, &Nbr_Entities) ; Geo_Element_P = Geo_Element_P0 + Index_Element ; Geo_Element_P->NbrEdges = Nbr_Entities ; Geo_Element_P->NumEdges = (int *)Malloc(Nbr_Entities * sizeof(int)) ; for (j = 0 ; j < Geo_Element_P->NbrEdges ; j++) fscanf(File_PRE, "%d", &Geo_Element_P->NumEdges[j]) ; } } /* E l e m e n t s X F a c e t s */ else if (!strncmp(&String[1], "ElementsXFacets", 15)) { fscanf(File_PRE, "%d", &GeoDataIndex) ; if(GeoDataIndex > NbrGeoData-1){ Message::Error("Unknown GeoData: %d", GeoDataIndex); return; } GeoData_P = GeoData_P0 + GeoDataIndex ; Geo_Element_P0 = (struct Geo_Element*)List_Pointer(GeoData_P->Elements, 0) ; fscanf(File_PRE, "%d", &GeoData_P->NbrElementsWithFacets) ; for (i = 0 ; i < GeoData_P->NbrElementsWithFacets ; i++) { fscanf(File_PRE, "%d %d", &Index_Element, &Nbr_Entities) ; Geo_Element_P = Geo_Element_P0 + Index_Element ; Geo_Element_P->NbrFacets = Nbr_Entities ; Geo_Element_P->NumFacets = (int *)Malloc(Nbr_Entities * sizeof(int)) ; for (j = 0 ; j < Geo_Element_P->NbrFacets ; j++) fscanf(File_PRE, "%d", &Geo_Element_P->NumFacets[j]) ; } } /* E x t e n d e d G r o u p */ else if (!strncmp(&String[1], "ExtendedGroup", 13)) { fscanf(File_PRE, "%d %d", &Index_Group, &Nbr_Entities) ; Group_P = (struct Group*)List_Pointer(Group_L, Index_Group) ; Group_P->ExtendedList = List_Create(Nbr_Entities, 1, sizeof(int)) ; for (i = 0 ; i < Nbr_Entities ; i++) { fscanf(File_PRE, "%d", &Num_Entity) ; List_Add(Group_P->ExtendedList, &Num_Entity) ; } } do { fgets(String, sizeof(String), File_PRE) ; if (feof(File_PRE)){ Message::Error("Prematured end of file"); return; } } while (String[0] != '$') ; } /* while 1 ... */ } /* ------------------------------------------------------------------------ */ /* G e o _ A d d G r o u p F o r P R E */ /* ------------------------------------------------------------------------ */ void Geo_AddGroupForPRE(int Num) { if (CurrentGeoData->GroupForPRE == NULL) CurrentGeoData->GroupForPRE = List_Create( 2, 2, sizeof(int)) ; List_Add(CurrentGeoData->GroupForPRE, &Num) ; } getdp-2.4.2-source/Legacy/BF_Node_2.cpp000644 001750 001750 00000042626 12116424202 021171 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "ProData.h" #include "Message.h" /* ------------------------------------------------------------------------ */ /* B F _ N o d e _ 2 */ /* ------------------------------------------------------------------------ */ /* ------- */ /* Edges */ /* ------- */ #define WrongNumEntity Message::Error("Wrong Edge number in 'BF_Node_2E'") void BF_Node_2E(struct Element * Element, int NumEntity, double u, double v, double w, double *s) { switch (Element->Type) { case LINE : switch(NumEntity) { case 1 : *s = 0.25 * (1.-u) * (1.+u) ; break ; default : WrongNumEntity ; } break ; case TRIANGLE : switch(NumEntity) { case 1 : *s = (1.-u-v) * u ; break ; case 2 : *s = (1.-u-v) * v ; break ; case 3 : *s = u * v ; break ; default : WrongNumEntity ; } break ; case QUADRANGLE : switch(NumEntity) { case 1 : *s = 0.0625 * (1.-u*u) * (1.-v)*(1.-v) ; break ; case 2 : *s = 0.0625 * (1.-u)*(1.-u) * (1.-v*v) ; break ; case 3 : *s = 0.0625 * (1.+u)*(1.+u) * (1.-v*v) ; break ; case 4 : *s = 0.0625 * (1.-u*u) * (1.+v)*(1.+v) ; break ; default : WrongNumEntity ; } break ; case TETRAHEDRON : switch(NumEntity) { case 1 : *s = (1.-u-v-w) * u ; break ; case 2 : *s = (1.-u-v-w) * v ; break ; case 3 : *s = (1.-u-v-w) * w ; break ; case 4 : *s = u * v ; break ; case 5 : *s = u * w ; break ; case 6 : *s = v * w ; break ; default : WrongNumEntity ; } break ; case HEXAHEDRON : switch(NumEntity) { case 1 : *s = 0.015625 * (1.-u) * (1.-v) * (1.-w) * (1.+u) * (1.-v) * (1.-w) ; break ; case 2 : *s = 0.015625 * (1.-u) * (1.-v) * (1.-w) * (1.-u) * (1.+v) * (1.-w) ; break ; case 3 : *s = 0.015625 * (1.-u) * (1.-v) * (1.-w) * (1.-u) * (1.-v) * (1.+w) ; break ; case 4 : *s = 0.015625 * (1.+u) * (1.-v) * (1.-w) * (1.+u) * (1.+v) * (1.-w) ; break ; case 5 : *s = 0.015625 * (1.+u) * (1.-v) * (1.-w) * (1.+u) * (1.-v) * (1.+w) ; break ; case 6 : *s = 0.015625 * (1.+u) * (1.+v) * (1.-w) * (1.-u) * (1.+v) * (1.-w) ; break ; case 7 : *s = 0.015625 * (1.+u) * (1.+v) * (1.-w) * (1.+u) * (1.+v) * (1.+w) ; break ; case 8 : *s = 0.015625 * (1.-u) * (1.+v) * (1.-w) * (1.-u) * (1.+v) * (1.+w) ; break ; case 9 : *s = 0.015625 * (1.-u) * (1.-v) * (1.+w) * (1.+u) * (1.-v) * (1.+w) ; break ; case 10 : *s = 0.015625 * (1.-u) * (1.-v) * (1.+w) * (1.-u) * (1.+v) * (1.+w) ; break ; case 11 : *s = 0.015625 * (1.+u) * (1.-v) * (1.+w) * (1.+u) * (1.+v) * (1.+w) ; break ; case 12 : *s = 0.015625 * (1.+u) * (1.+v) * (1.+w) * (1.-u) * (1.+v) * (1.+w) ; break ; default : WrongNumEntity ; } break ; case PRISM : // FIXME: not tested! switch(NumEntity) { case 1 : *s = 0.25 * (1.-u-v) * (1.-w) * u * (1.-w) ; break ; case 2 : *s = 0.25 * (1.-u-v) * (1.-w) * v * (1.-w) ; break ; case 3 : *s = 0.25 * (1.-u-v) * (1.-w) * (1.-u-v) * (1.+w) ; break ; case 4 : *s = 0.25 * u * (1.-w) * v * (1.-w) ; break ; case 5 : *s = 0.25 * u * (1.-w) * u * (1.+w) ; break ; case 6 : *s = 0.25 * v * (1.-w) * v * (1.+w) ; break ; case 7 : *s = 0.25 * (1.-u-v) * (1.+w) * u * (1.+w) ; break ; case 8 : *s = 0.25 * (1.-u-v) * (1.+w) * v * (1.+w) ; break ; case 9 : *s = 0.25 * u * (1.+w) * v * (1.+w) ; break ; default : WrongNumEntity ; } break ; case PYRAMID : switch(NumEntity) { default : Message::Error("BF_Node_2E not ready for PYRAMID"); } break ; default : Message::Error("Unkown type of Element in BF_Node_2E"); break ; } } #undef WrongNumEntity /* -------- */ /* Facets */ /* -------- */ #define WrongNumEntity Message::Error("Wrong Face number in 'BF_Node_2F'") void BF_Node_2F(struct Element * Element, int NumEntity, double u, double v, double w, double *s) { switch (Element->Type) { case LINE : case TRIANGLE : case TETRAHEDRON : Message::Error("BF_Node_2F cannot be associated with this type of element"); break; case QUADRANGLE : *s = 0.0625 * (1.-u) * (1.-v) * (1.+u) * (1.+v) ; break ; case HEXAHEDRON : switch(NumEntity) { case 1 : *s = 0.015625 * (1.-u) * (1.-v) * (1.-w) * (1.+u) * (1.-v) * (1.+w) ; break ; case 2 : *s = 0.015625 * (1.-u) * (1.-v) * (1.-w) * (1.+u) * (1.+v) * (1.-w) ; break ; case 3 : *s = 0.015625 * (1.-u) * (1.-v) * (1.-w) * (1.-u) * (1.+v) * (1.+w) ; break ; case 4 : *s = 0.015625 * (1.+u) * (1.-v) * (1.-w) * (1.+u) * (1.+v) * (1.+w) ; break ; case 5 : *s = 0.015625 * (1.+u) * (1.+v) * (1.-w) * (1.-u) * (1.+v) * (1.+w) ; break ; case 6 : *s = 0.015625 * (1.-u) * (1.-v) * (1.+w) * (1.+u) * (1.+v) * (1.+w) ; break ; default : WrongNumEntity ; } break ; case PRISM : switch(NumEntity) { default : Message::Error("BF_Node_2F not ready for PRISM"); // cannot do this yet in getdp, as dofs should only be // associated with quad-faces: if really necessary we could // implement actual 15 and 18-node prisms /* case 1 : *s = 0.25 * (1.-u-v) * (1.-w) * u * (1.+w) ; break ; case 3 : *s = 0.25 * (1.-u-v) * (1.-w) * v * (1.+w) ; break ; case 4 : *s = 0.25 * u * (1.-w) * v * (1.+w) ; break ; default : WrongNumEntity ; */ } break ; case PYRAMID : switch(NumEntity) { default : Message::Error("BF_Node_2F not ready for PYRAMID"); } break ; default : Message::Error("Unkown Element Type in BF_Node_2F"); break ; } } #undef WrongNumEntity /* -------- */ /* Volume */ /* -------- */ void BF_Node_2V(struct Element * Element, int NumEntity, double u, double v, double w, double *s) { switch (Element->Type) { case LINE : case TRIANGLE : case QUADRANGLE : case TETRAHEDRON : case PRISM : case PYRAMID : Message::Error("BF_Node_2V cannot be associated with this type of element"); break; case HEXAHEDRON : *s = 0.015625 * (1.-u) * (1.-v) * (1.-w) * (1.+u) * (1.+v) * (1.+w) ; break ; default : Message::Error("Unkown type of Element in BF_Node_2V"); break ; } } /* ------------------------------------------------------------------------ */ /* B F _ G r a d N o d e _ 2 */ /* ------------------------------------------------------------------------ */ /* ------- */ /* Edges */ /* ------- */ #define WrongNumEntity Message::Error("Wrong Edge number in 'BF_GradNode_2E'") void BF_GradNode_2E(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { switch (Element->Type) { case LINE : switch(NumEntity) { case 1 : s[0] = -0.5*u ; s[1] = 0. ; s[2] = 0. ; break ; default : WrongNumEntity ; } break ; case TRIANGLE : switch(NumEntity) { case 1 : s[0] = 1.-2.*u-v ; s[1] = -u ; s[2] = 0. ; break ; case 2 : s[0] = -v ; s[1] = 1.-u-2.*v ; s[2] = 0. ; break ; case 3 : s[0] = v ; s[1] = u ; s[2] = 0. ; break ; default : WrongNumEntity ; } break ; case QUADRANGLE : switch(NumEntity) { case 1 : s[0] = 0.0625 * (-2.*u) * (1.-v)*(1.-v) ; s[1] = 0.0625 * (1.-u*u) * (-2.)*(1.-v) ; s[2] = 0. ; break ; case 2 : s[0] = 0.0625 * (-2.)*(1.-u) * (1.-v*v) ; s[1] = 0.0625 * (1.-u)*(1.-u) * (-2.*v) ; s[2] = 0. ; break ; case 3 : s[0] = 0.0625 * (2.)*(1.+u) * (1.-v*v) ; s[1] = 0.0625 * (1.+u)*(1.+u) * (-2.*v) ; s[2] = 0. ; break ; case 4 : s[0] = 0.0625 * (-2.*u) * (1.+v)*(1.+v) ; s[1] = 0.0625 * (1.-u*u) * (2.)*(1.+v) ; s[2] = 0. ; break ; default : WrongNumEntity; } break ; case TETRAHEDRON : switch(NumEntity) { case 1 : s[0] = 1.-2.*u-v-w ; s[1] = -u ; s[2] = -u ; break ; case 2 : s[0] = -v ; s[1] = 1.-u-2.*v-w ; s[2] = -v ; break ; case 3 : s[0] = -w ; s[1] = -w ; s[2] = 1.-u-v-2.*w ; break ; case 4 : s[0] = v ; s[1] = u ; s[2] = 0. ; break ; case 5 : s[0] = w ; s[1] = 0. ; s[2] = u ; break ; case 6 : s[0] = 0. ; s[1] = w ; s[2] = v ; break ; default : WrongNumEntity ; } break ; case HEXAHEDRON : switch(NumEntity) { case 1 : s[0] = 0.015625 * (-2.*u) * (1.-v) * (1.-w) * (1.-v) * (1.-w) ; s[1] = 0.015625 * (1.-u) * (-2.)*(1.-v) * (1.-w) * (1.+u) * (1.-w) ; s[2] = 0.015625 * (1.-u) * (1.-v) * (-2.)*(1.-w) * (1.+u) * (1.-v) ; break ; case 2 : s[0] = 0.015625 * (-2.)*(1.-u) * (1.-v) * (1.-w) * (1.+v) * (1.-w) ; s[1] = 0.015625 * (1.-u) * (-2.*v) * (1.-w) * (1.-u) * (1.-w) ; s[2] = 0.015625 * (1.-u) * (1.-v) * (-2.)*(1.-w) * (1.-u) * (1.+v) ; break ; case 3 : s[0] = 0.015625 * (-2.)*(1.-u) * (1.-v) * (1.-w) * (1.-v) * (1.+w) ; s[1] = 0.015625 * (1.-u) * (-2.)*(1.-v) * (1.-w) * (1.-u) * (1.+w) ; s[2] = 0.015625 * (1.-u) * (1.-v) * (-2.*w) * (1.-u) * (1.-v) ; break ; case 4 : s[0] = 0.015625 * 2.*(1.+u) * (1.-v) * (1.-w) * (1.+v) * (1.-w) ; s[1] = 0.015625 * (1.+u) * (-2.*v) * (1.-w) * (1.+u) * (1.-w) ; s[2] = 0.015625 * (1.+u) * (1.-v) * (-2.)*(1.-w) * (1.+u) * (1.+v) ; break ; case 5 : s[0] = 0.015625 * 2.*(1.+u) * (1.-v) * (1.-w) * (1.-v) * (1.+w) ; s[1] = 0.015625 * (1.+u) * (-2.)*(1.-v) * (1.-w) * (1.+u) * (1.+w) ; s[2] = 0.015625 * (1.+u) * (1.-v) * (-2.*w) * (1.+u) * (1.-v) ; break ; case 6 : s[0] = 0.015625 * (-2.*u) * (1.+v) * (1.-w) * (1.+v) * (1.-w) ; s[1] = 0.015625 * (1.+u) * 2.*(1.+v) * (1.-w) * (1.-u) * (1.-w) ; s[2] = 0.015625 * (1.+u) * (1.+v) * (-2.)*(1.-w) * (1.-u) * (1.+v) ; break ; case 7 : s[0] = 0.015625 * 2.*(1.+u) * (1.+v) * (1.-w) * (1.+v) * (1.+w) ; s[1] = 0.015625 * (1.+u) * 2.*(1.+v) * (1.-w) * (1.+u) * (1.+w) ; s[2] = 0.015625 * (1.+u) * (1.+v) * (-2.*w) * (1.+u) * (1.+v) ; break ; case 8 : s[0] = 0.015625 * (-2.)*(1.-u) * (1.+v) * (1.-w) * (1.+v) * (1.+w) ; s[1] = 0.015625 * (1.-u) * 2.*(1.+v) * (1.-w) * (1.-u) * (1.+w) ; s[2] = 0.015625 * (1.-u) * (1.+v) * (-2.*w) * (1.-u) * (1.+v) ; break ; case 9 : s[0] = 0.015625 * (-2.*u) * (1.-v) * (1.+w) * (1.-v) * (1.+w) ; s[1] = 0.015625 * (1.-u) * (-2.)*(1.-v) * (1.+w) * (1.+u) * (1.+w) ; s[2] = 0.015625 * (1.-u) * (1.-v) * 2.*(1.+w) * (1.+u) * (1.-v) ; break ; case 10 : s[0] = 0.015625 * (-2.)*(1.-u) * (1.-v) * (1.+w) * (1.+v) * (1.+w) ; s[1] = 0.015625 * (1.-u) * (-2.*v) * (1.+w) * (1.-u) * (1.+w) ; s[2] = 0.015625 * (1.-u) * (1.-v) * 2.*(1.+w) * (1.-u) * (1.+v) ; break ; case 11 : s[0] = 0.015625 * 2.*(1.+u) * (1.-v) * (1.+w) * (1.+v) * (1.+w) ; s[1] = 0.015625 * (1.+u) * (-2.*v) * (1.+w) * (1.+u) * (1.+w) ; s[2] = 0.015625 * (1.+u) * (1.-v) * 2.*(1.+w) * (1.+u) * (1.+v) ; break ; case 12 : s[0] = 0.015625 * (-2.*u) * (1.+v) * (1.+w) * (1.+v) * (1.+w) ; s[1] = 0.015625 * (1.+u) * 2.*(1.+v) * (1.+w) * (1.-u) * (1.+w) ; s[2] = 0.015625 * (1.+u) * (1.+v) * 2.*(1.+w) * (1.-u) * (1.+v) ; break ; default : WrongNumEntity ; } break ; case PRISM : // FIXME: not tested! switch(NumEntity) { case 1 : s[0] = 0.25 * (1.-2.*u-v) * (1.-w) * (1.-w) ; s[1] = 0.25 * (-u) * (1.-w) * (1.-w) ; s[2] = 0.25 * (u-u*u-v*u) * (-2.)*(1.-w) ; break ; case 2 : s[0] = 0.25 * (-v) * (1.-w) * (1.-w) ; s[1] = 0.25 * (1-u-2*v) * (1.-w) * (1.-w) ; s[2] = 0.25 * (v-u*v-v*v) * (-2.) * (1.-w) ; break ; case 3 : s[0] = 0.25 * (-2. + 2.*u + 2.*v) * (1.-w) * (1.+w) ; s[1] = 0.25 * (-2. + 2.*u + 2.*v) * (1.-w) * (1.+w) ; s[2] = 0.25 * (1.- 2.*u - 2.*v + u*u + 2.*u*v + v*v) * (-2.*w) ; break ; case 4 : s[0] = 0.25 * (1.-w) * v * (1.-w) ; s[1] = 0.25 * u * (1.-w) * (1.-w) ; s[2] = 0.25 * u * (-2.) * (1.-w) * v ; break ; case 5 : s[0] = 0.25 * 2.*u * (1.-w) * (1.+w) ; s[1] = 0. ; s[2] = 0.25 * u*u * (-2.*w) ; break ; case 6 : s[0] = 0. ; s[1] = 0.25 * 2.*v * (1.-w) * (1.+w) ; s[2] = 0.25 * v*v * (-2.*w) ; break ; case 7 : s[0] = 0.25 * (1.-2.*u-v) * (1.+w) * (1.+w) ; s[1] = 0.25 * (-u) * (1.+w) * (1.+w) ; s[2] = 0.25 * (u-u*u-u*v) * 2.*(1.+w) ; break ; case 8 : s[0] = 0.25 * (-v) * (1.+w) * (1.+w) ; s[1] = 0.25 * (1.-u-2.*v) * (1.+w) * (1.+w) ; s[2] = 0.25 * (v-u*v-v*v) * 2.*(1.+w) ; break ; case 9 : s[0] = 0.25 * (1.+w) * v * (1.+w) ; s[1] = 0.25 * u * (1.+w) * (1.+w) ; s[2] = 0.25 * u * 2.*(1.+w) * v ; break ; default : WrongNumEntity ; } break ; case PYRAMID : switch(NumEntity) { default : Message::Error("BF_GradNode_2E not ready for PYRAMID"); } break ; default : Message::Error("Unkown type of Element in BF_GradNode_2E"); break ; } } #undef WrongNumEntity /* -------- */ /* Facets */ /* -------- */ #define WrongNumEntity Message::Error("Wrong Face number in 'BF_GradNode_2F'") void BF_GradNode_2F(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { switch (Element->Type) { case LINE : case TRIANGLE : case TETRAHEDRON : Message::Error("BF_GradNode_2F cannot be associated with this type of element"); break; case QUADRANGLE : s[0] = 0.0625 * (-2.*u) * (1.-v) * (1.+v) ; s[1] = 0.0625 * (1.-u) * (-2.*v) * (1.+u) ; s[2] = 0. ; break ; case HEXAHEDRON : switch(NumEntity) { case 1 : s[0] = 0.015625 * (-2.*u) * (1.-v) * (1.-w) * (1.-v) * (1.+w) ; s[1] = 0.015625 * (1.-u) * (-2.)*(1.-v) * (1.-w) * (1.+u) * (1.+w) ; s[2] = 0.015625 * (1.-u) * (1.-v) * (-2.*w) * (1.+u) * (1.-v) ; break ; case 2 : s[0] = 0.015625 * (-2.*u) * (1.-v) * (1.-w) * (1.+v) * (1.-w) ; s[1] = 0.015625 * (1.-u) * (-2.*v) * (1.-w) * (1.+u) * (1.-w) ; s[2] = 0.015625 * (1.-u) * (1.-v) * (-2.)*(1.-w) * (1.+u) * (1.+v) ; break; case 3 : s[0] = 0.015625 * (-2.)*(1.-u) * (1.-v) * (1.-w) * (1.+v) * (1.+w) ; s[1] = 0.015625 * (1.-u) * (-2.*v) * (1.-w) * (1.-u) * (1.+w) ; s[2] = 0.015625 * (1.-u) * (1.-v) * (-2.*w) * (1.-u) * (1.+v) ; break; case 4 : s[0] = 0.015625 * 2.*(1.+u) * (1.-v) * (1.-w) * (1.+v) * (1.+w) ; s[1] = 0.015625 * (1.+u) * (-2.*v) * (1.-w) * (1.+u) * (1.+w) ; s[2] = 0.015625 * (1.+u) * (1.-v) * (-2.*w) * (1.+u) * (1.+v) ; break; case 5 : s[0] = 0.015625 * (-2.*u) * (1.+v) * (1.-w) * (1.+v) * (1.+w) ; s[1] = 0.015625 * (1.+u) * 2.*(1.+v) * (1.-w) * (1.-u) * (1.+w) ; s[2] = 0.015625 * (1.+u) * (1.+v) * (-2.*w) * (1.-u) * (1.+v) ; break; case 6 : s[0] = 0.015625 * (-2.*u) * (1.-v) * (1.+w) * (1.+v) * (1.+w) ; s[1] = 0.015625 * (1.-u) * (-2.*v) * (1.+w) * (1.+u) * (1.+w) ; s[2] = 0.015625 * (1.-u) * (1.-v) * 2.*(1.+w) * (1.+u) * (1.+v) ; break; default : WrongNumEntity ; } break ; case PRISM : switch(NumEntity) { default : Message::Error("BF_GradNode_2F not ready for PRISM"); // cannot do this yet in getdp, as dofs should only be // associated with quad-faces: if really necessary we could // implement actual 15 and 18-node prisms /* case 1 : s[0] = 0.25 * (1.-2.*u-v) * (1.-w) * (1.+w) ; s[1] = 0.25 * (-u) * (1.-w) * (1.+w); s[2] = 0.25 * (u-u*u-u*v) * (-2.*w); break ; case 3 : s[0] = 0.25 * (-v) * (1.-w) * (1.+w) ; s[1] = 0.25 * (1.-u-2.*v) * (1.-w) * (1.+w) ; s[2] = 0.25 * (v-u*v-v*v) * (-2.*w) ; break; case 4 : s[0] = 0.25 * (1.-w) * v * (1.+w) ; s[1] = 0.25 * u * (1.-w) * (1.+w) ; s[2] = 0.25 * u * (-2.*w) * v ; break; */ } break ; case PYRAMID : switch(NumEntity) { default : Message::Error("BF_GradNode_2F not ready for PYRAMID"); } break ; default : Message::Error("Unknown type of Element in BF_GradNode_2F"); break ; } } #undef WrongNumEntity /* -------- */ /* Volume */ /* -------- */ void BF_GradNode_2V(struct Element * Element, int NumEntity, double u, double v, double w, double s[]) { switch (Element->Type) { case LINE : case TRIANGLE : case QUADRANGLE : case TETRAHEDRON : case PRISM : case PYRAMID : Message::Error("BF_GradNode_2V cannot be associated with this type of element"); break; case HEXAHEDRON : s[0] = 0.015625 * (-2.*u) * (1.-v) * (1.-w) * (1.+v) * (1.+w) ; s[1] = 0.015625 * (1.-u) * (-2.*v) * (1.-w) * (1.+u) * (1.+w) ; s[2] = 0.015625 * (1.-u) * (1.-v) * (-2.*w) * (1.+u) * (1.+v) ; break ; default : Message::Error("Unkown type of Element in BF_GradNode_2V"); break ; } } getdp-2.4.2-source/Legacy/Gauss_Triangle.h000644 001750 001750 00000014205 12116424202 022060 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . /* 1 integration point */ static double xt1[1] = {0.333333333333333}; static double yt1[1] = {0.333333333333333}; static double pt1[1] = {0.5}; /* 3 integration points */ static double xt3[3] = {0.16666666666666,0.66666666666666,0.16666666666666}; static double yt3[3] = {0.16666666666666,0.16666666666666,0.66666666666666}; static double pt3[3] = {0.16666666666666,0.16666666666666,0.16666666666666}; /* 4 integration points */ static double xt4[4] = {0.333333333333333,0.6,0.2,0.2}; static double yt4[4] = {0.3333333333333333,0.2,0.6,0.2}; static double pt4[4] = {-0.28125,.260416666666,.260416666666,.260416666666}; /* 6 integration points */ static double xt6[6] = {0.816847572980459,0.091576213509771,0.091576213509771, 0.108103018168070,0.445948490915965,0.445948490915965}; static double yt6[6] = {0.091576213509771,0.816847572980459,0.091576213509771, 0.445948490915965,0.108103018168070,0.445948490915965}; static double pt6[6] = {0.054975871827661,0.054975871827661,0.054975871827661, 0.111690794839,0.111690794839,0.111690794839}; /* 7 integration points */ static double xt7[7] = {0.333333333333333,0.797426985353087,0.101286507323456, 0.101286507323456,0.470142064105115,0.059715871789770, 0.470142064105115}; static double yt7[7] = {0.333333333333333,0.101286507323456,0.797426985353087, 0.101286507323456,0.059715871789770,0.470142064105115, 0.470142064105115}; static double pt7[7] = {0.112500000000000,0.062969590272414,0.062969590272414, 0.062969590272414,0.066197076394253,0.066197076394253, 0.066197076394253}; /* 12 integration points */ static double xt12[12] = {0.873821971016996,0.063089014491502,0.063089014491502, 0.501426509658179,0.249286745170910,0.249286745170910, 0.636502499121399,0.310352451033785,0.636502499121399, 0.310352451033785,0.053145049844816,0.053145049844816}; static double yt12[12] = {0.063089014491502,0.873821971016996,0.063089014491502, 0.249286745170910,0.501426509658179,0.249286745170910, 0.310352451033785,0.636502499121399,0.053145049844816, 0.053145049844816,0.310352451033785,0.636502499121399}; static double pt12[12] = {0.025422453185104,0.025422453185104,0.025422453185104, 0.058393137863189,0.058393137863189,0.058393137863189, 0.041425537809187,0.041425537809187,0.041425537809187, 0.041425537809187,0.041425537809187,0.041425537809187}; /* 13 integration points */ static double xt13[13] = {0.333333333333333,0.479308067841920,0.260345966079040, 0.260345966079040,0.869739794195568,0.065130102902216, 0.065130102902216,0.048690315425316,0.312865496004874, 0.638444188569810,0.048690315425316,0.312865496004874, 0.638444188569810}; static double yt13[13] = {0.333333333333333,0.260345966079040,0.479308067841920, 0.260345966079040,0.065130102902216,0.869739794195568, 0.065130102902216,0.312865496004874,0.048690315425316, 0.048690315425316,0.638444188569810,0.638444188569810, 0.312865496004874}; static double pt13[13] = {-0.074785022233841,0.087807628716604,0.087807628716604, 0.087807628716604,0.026673617804419,0.026673617804419, 0.026673617804419,0.038556880445128,0.038556880445128, 0.038556880445128,0.038556880445128,0.038556880445128, 0.038556880445128}; /* 16 integration points */ static double xt16[16] = {0.333333333333333,0.081414823414554,0.459292588292723, 0.459292588292723,0.658861384496480,0.170569307751760, 0.170569307751760,0.898905543365938,0.050547228317031, 0.050547228317031,0.008394777409958,0.728492392955404, 0.263112829634638,0.008394777409958,0.263112829634638, 0.728492392955404}; static double yt16[16] = {0.333333333333333,0.459292588292723,0.081414823414554, 0.459292588292723,0.170569307751760,0.658861384496480, 0.170569307751760,0.050547228317031,0.898905543365938, 0.050547228317031,0.728492392955404,0.008394777409958, 0.008394777409958,0.263112829634638,0.728492392955404, 0.263112829634638}; static double pt16[16] = {0.072157803838894,0.047545817133643,0.047545817133643, 0.047545817133643,0.051608685267359,0.051608685267359, 0.051608685267359,0.016229248811599,0.016229248811599, 0.016229248811599,0.013615157087217,0.013615157087217, 0.013615157087217,0.013615157087217,0.013615157087217, 0.013615157087217}; /* GAUSS TRIANGLE WITH 1/R SINGULARITY OVER NODE (0,0,0) ref.: H. L. G. Pina, J. L. M. Fernandes, C. A. Brebbia, Some numerical integration formulae over triangles and squares with a 1/R singularity, Appl. Math. Modelling, Vol 5, June 1981, pp 209--211 */ /* 1 integration point */ static double xts1[1] = {0.25}; static double yts1[1] = {0.25}; static double pts1[1] = {1.24645048}; /* 3 integration points */ static double xts3[3] = {0.16666667,0.81742619,0.18257381}; static double yts3[3] = {0.16666667,0.18257381,0.81742619}; static double pts3[3] = {0.93483790,0.15580629,0.15580629}; /* 4 integration points */ static double xts4[4] = {0.16385495,0.61114353,0.04756957,0.17753138}; static double yts4[4] = {0.04756957,0.17753138,0.16385495,0.61114353}; static double pts4[4] = {0.31161231,0.31161293,0.31161231,0.31161293}; getdp-2.4.2-source/Legacy/Gauss_Prism.h000644 001750 001750 00000017555 12116424202 021420 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . /* 6 integration points (DHATT ET TOUZOT) */ static double upri6[6] = {0.166666666666666, 0.666666666666666, 0.166666666666666, 0.166666666666666, 0.666666666666666, 0.166666666666666}; static double vpri6[6] = {0.166666666666666, 0.166666666666666, 0.666666666666666, 0.166666666666666, 0.166666666666666, 0.666666666666666}; static double wpri6[6] = {-0.577350269189, -0.577350269189, -0.577350269189, 0.577350269189, 0.577350269189, 0.577350269189}; static double ppri6[6] = {0.166666666666666,0.166666666666666,0.166666666666666, 0.166666666666666,0.166666666666666,0.166666666666666}; /* 9 integration points (DHATT ET TOUZOT) */ static double upri9[9] = {0.166666666666666, 0.666666666666666, 0.166666666666666, 0.166666666666666, 0.666666666666666, 0.166666666666666, 0.166666666666666, 0.666666666666666, 0.166666666666666}; static double vpri9[9] = {0.166666666666666, 0.166666666666666, 0.666666666666666, 0.166666666666666, 0.166666666666666, 0.666666666666666, 0.166666666666666, 0.166666666666666, 0.666666666666666}; static double wpri9[9] = {-0.774596669241483, -0.774596669241483, -0.774596669241483, 0. , 0. , 0. , 0.774596669241483, 0.774596669241483, 0.774596669241483}; static double ppri9[9] = {0.0925925925929,0.0925925925929,0.0925925925929, 0.1481481481481,0.1481481481481,0.1481481481481, 0.0925925925929,0.0925925925929,0.0925925925929}; /* 21 integration points (DHATT ET TOUZOT) */ static double upri21[21] = {0.333333333333333, 0.470142064105115, 0.05971587179 , 0.470142064105115, 0.101286507323456, 0.79742698535 , 0.101286507323456, 0.333333333333333, 0.470142064105115, 0.05971587179 , 0.470142064105115, 0.101286507323456, 0.79742698535 , 0.101286507323456, 0.333333333333333, 0.470142064105115, 0.05971587179 , 0.470142064105115, 0.101286507323456, 0.79742698535 , 0.101286507323456}; static double vpri21[21] = {0.333333333333333, 0.470142064105115, 0.470142064105115, 0.05971587179 , 0.101286507323456, 0.101286507323456, 0.79742698535 , 0.333333333333333, 0.470142064105115, 0.470142064105115, 0.05971587179 , 0.101286507323456, 0.101286507323456, 0.79742698535 , 0.333333333333333, 0.470142064105115, 0.470142064105115, 0.05971587179 , 0.101286507323456, 0.101286507323456, 0.79742698535}; static double wpri21[21] = {-0.774596669241483,-0.774596669241483, -0.774596669241483,-0.774596669241483, -0.774596669241483,-0.774596669241483, -0.774596669241483, 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0.774596669241483, 0.774596669241483, 0.774596669241483, 0.774596669241483, 0.774596669241483, 0.774596669241483, 0.774596669241483}; static double ppri21[21] = {0.625000000000000E-01, 0.367761535523628E-01, 0.367761535523628E-01, 0.367761535523628E-01, 0.349831057068964E-01, 0.349831057068964E-01, 0.349831057068964E-01, 0.100000000000000E+00, 0.588418456837804E-01, 0.588418456837804E-01, 0.588418456837804E-01, 0.559729691310342E-01, 0.559729691310342E-01, 0.559729691310342E-01, 0.625000000000000E-01, 0.367761535523628E-01, 0.367761535523628E-01, 0.367761535523628E-01, 0.349831057068964E-01, 0.349831057068964E-01, 0.349831057068964E-01}; /* 42 integration points (DHATT ET TOUZOT) */ static double upri42[42] = {0.333333333333333, 0.470142064105115, 0.05971587179 , 0.470142064105115, 0.101286507323456, 0.79742698535 , 0.101286507323456, 0.333333333333333, 0.470142064105115, 0.05971587179 , 0.470142064105115, 0.101286507323456, 0.79742698535 , 0.101286507323456, 0.333333333333333, 0.470142064105115, 0.05971587179 , 0.470142064105115, 0.101286507323456, 0.79742698535 , 0.101286507323456, 0.333333333333333, 0.470142064105115, 0.05971587179 , 0.470142064105115, 0.101286507323456, 0.79742698535 , 0.101286507323456, 0.333333333333333, 0.470142064105115, 0.05971587179 , 0.470142064105115, 0.101286507323456, 0.79742698535 , 0.101286507323456, 0.333333333333333, 0.470142064105115, 0.05971587179 , 0.470142064105115, 0.101286507323456, 0.79742698535 , 0.101286507323456}; static double vpri42[42] = {0.333333333333333, 0.470142064105115, 0.470142064105115, 0.05971587179 , 0.101286507323456, 0.101286507323456, 0.79742698535 , 0.333333333333333, 0.470142064105115, 0.470142064105115, 0.05971587179 , 0.101286507323456, 0.101286507323456, 0.79742698535 , 0.333333333333333, 0.470142064105115, 0.470142064105115, 0.05971587179 , 0.101286507323456, 0.101286507323456, 0.79742698535 , 0.333333333333333, 0.470142064105115, 0.470142064105115, 0.05971587179 , 0.101286507323456, 0.101286507323456, 0.79742698535 , 0.333333333333333, 0.470142064105115, 0.470142064105115, 0.05971587179 , 0.101286507323456, 0.101286507323456, 0.79742698535 , 0.333333333333333, 0.470142064105115, 0.470142064105115, 0.05971587179 , 0.101286507323456, 0.101286507323456, 0.79742698535}; static double wpri42[42] = {-0.238619186083197, -0.238619186083197,-0.238619186083197, -0.238619186083197,-0.238619186083197, -0.238619186083197,-0.238619186083197, 0.238619186083197, 0.238619186083197, 0.238619186083197, 0.238619186083197, 0.238619186083197, 0.238619186083197, 0.238619186083197, -0.661209386466265, -0.661209386466265,-0.661209386466265, -0.661209386466265,-0.661209386466265, -0.661209386466265,-0.661209386466265, 0.661209386466265, 0.661209386466265, 0.661209386466265, 0.661209386466265, 0.661209386466265, 0.661209386466265, 0.661209386466265, -0.932469514203152, -0.932469514203152,-0.932469514203152, -0.932469514203152,-0.932469514203152, -0.932469514203152,-0.932469514203152, 0.932469514203152, 0.932469514203152, 0.932469514203152, 0.932469514203152, 0.932469514203152, 0.932469514203152, 0.932469514203152}; static double ppri42[42] = {0.5264031763942775E-01, 0.3097453447284393E-01, 0.3097453447284393E-01, 0.3097453447284393E-01, 0.2946434874279526E-01, 0.2946434874279526E-01, 0.2946434874279526E-01, 0.5264031763942775E-01, 0.3097453447284393E-01, 0.3097453447284393E-01, 0.3097453447284393E-01, 0.2946434874279526E-01, 0.2946434874279526E-01, 0.2946434874279526E-01, 0.4058567696791564E-01, 0.2388136141117854E-01, 0.2388136141117854E-01, 0.2388136141117854E-01, 0.2271700844087269E-01, 0.2271700844087269E-01, 0.2271700844087269E-01, 0.4058567696791564E-01, 0.2388136141117854E-01, 0.2388136141117854E-01, 0.2388136141117854E-01, 0.2271700844087269E-01, 0.2271700844087269E-01, 0.2271700844087269E-01, 0.1927400539265662E-01, 0.1134118051023053E-01, 0.1134118051023053E-01, 0.1134118051023053E-01, 0.1078823308874557E-01, 0.1078823308874557E-01, 0.1078823308874557E-01, 0.1927400539265662E-01, 0.1134118051023053E-01, 0.1134118051023053E-01, 0.1134118051023053E-01, 0.1078823308874557E-01, 0.1078823308874557E-01, 0.1078823308874557E-01}; getdp-2.4.2-source/Legacy/ExtendedGroup.h000644 001750 001750 00000001670 12116424202 021730 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _EXTENDED_GROUP_H_ #define _EXTENDED_GROUP_H_ #include "ProData.h" #include "ListUtils.h" int Check_IsEntityInExtendedGroup(struct Group * Group_P, int Entity, int Flag) ; void Generate_ExtendedGroup(struct Group * Group_P) ; void Generate_ElementaryEntities(List_T * InitialList, List_T ** ExtendedList, int Type_Entity) ; void Generate_GroupsOfNodes(List_T * InitialList, List_T ** ExtendedList) ; void Generate_GroupsOfEdges(List_T * InitialList, int Type_SuppList, List_T * InitialSuppList, List_T ** ExtendedList) ; void Generate_GroupsOfFacets(List_T * InitialList, List_T ** ExtendedList) ; void Generate_Elements(List_T * InitialList, int Type_SuppList, List_T * InitialSuppList, List_T ** ExtendedList) ; #endif getdp-2.4.2-source/Legacy/Cal_GlobalTermOfFemEquation.h000644 001750 001750 00000001071 12116424202 024400 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _CAL_GLOBAL_TERM_OF_FEM_EQUATION_H_ #define _CAL_GLOBAL_TERM_OF_FEM_EQUATION_H_ #include "ProData.h" void Cal_GlobalTermOfFemEquation(int Num_Region, struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0, struct QuantityStorage * QuantityStorageNoDof, struct Dof * DofForNoDof_P); #endif getdp-2.4.2-source/Legacy/Cal_AssembleTerm.h000644 001750 001750 00000002372 12116424202 022315 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _CAL_ASSEMBLE_TERM_H_ #define _CAL_ASSEMBLE_TERM_H_ #include "ProData.h" void Cal_AssembleTerm_NoDt(struct Dof * Equ, struct Dof * Dof, double Val[]); void Cal_AssembleTerm_DtDof(struct Dof * Equ, struct Dof * Dof, double Val[]); void Cal_AssembleTerm_Dt(struct Dof * Equ, struct Dof * Dof, double Val[]); void Cal_AssembleTerm_DtNL(struct Dof * Equ, struct Dof * Dof, double Val[]); void Cal_AssembleTerm_DtDtDof(struct Dof * Equ, struct Dof * Dof, double Val[]); void Cal_AssembleTerm_DtDt(struct Dof * Equ, struct Dof * Dof, double Val[]); void Cal_AssembleTerm_JacNL(struct Dof * Equ, struct Dof * Dof, double Val[]); void Cal_AssembleTerm_DtDofJacNL(struct Dof * Equ, struct Dof * Dof, double Val[]); void Cal_AssembleTerm_NeverDt(struct Dof * Equ, struct Dof * Dof, double Val[]); void Cal_AssembleTerm_MH_Moving_simple(struct Dof * Equ, struct Dof * Dof, double Val[]); void Cal_AssembleTerm_MH_Moving_separate(struct Dof * Equ, struct Dof * Dof, double Val[]); void Cal_AssembleTerm_MH_Moving_probe(struct Dof * Equ, struct Dof * Dof, double Val[]); #endif getdp-2.4.2-source/Legacy/Get_ElementSource.h000644 001750 001750 00000000734 12116424202 022524 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _GET_ELEMENT_SOURCE_H_ #define _GET_ELEMENT_SOURCE_H_ #include "ProData.h" void Get_InitElementSource(struct Element *Element, int InIndex); int Get_NextElementSource(struct Element *ElementSource); void Get_ElementTrace(struct Element *Element, int InIndex); #endif getdp-2.4.2-source/Legacy/Get_DofOfElement.h000644 001750 001750 00000003224 12116424202 022256 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _GET_DOF_OF_ELEMENT_H_ #define _GET_DOF_OF_ELEMENT_H_ #include "ProData.h" void Get_InitDofOfElement(struct Element * Element) ; void Get_DofOfElement(struct Element * Element, struct FunctionSpace * FunctionSpace_P, struct QuantityStorage * QuantityStorage_P, List_T * BasisFunctionIndex_L) ; void Get_GroupsOfElementaryEntitiesOfElement (struct Element * Element, int * StartingIndex, int Nbr_ElementaryEntities, int Num_ElementaryEntities[], struct BasisFunction * BasisFunction_P) ; void Get_GroupsOfEdgesOnNodesOfElement (struct Element * Element, int * StartingIndex) ; void Get_RegionForElement(struct Element * Element, int * StartingIndex, struct BasisFunction * BasisFunction_P) ; void Get_GlobalForElement(struct Element * Element, int * StartingIndex, struct BasisFunction * BasisFunction_P) ; void Get_CodesOfElement(struct FunctionSpace * FunctionSpace_P, struct QuantityStorage * QuantityStorage_P, int Nbr_Entity, int Num_Entity[], int StartingIndex, int i_BFunction, int TypeConstraint, int * Num_SubFunction) ; void Get_PreResolutionForGlobalBasisFunction(int Nbr_Global, int StartingIndex, struct Element * Element) ; void Get_DofOfRegion(int Num_Region, struct GlobalQuantity * GlobalQuantity_P, struct FunctionSpace * FunctionSpace_P, struct QuantityStorage * QuantityStorage_P) ; #endif getdp-2.4.2-source/Legacy/Gauss_Line.h000644 001750 001750 00000027250 12116424202 021206 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . /* Please change the MAX_LINE_POINTS in Quadrature.h if you extend this list, in order for the Gauss-Legendre rules to be automatically updated. */ /* 1 integration point */ static double lx1[1]={ 0.000000000000000e+00}; static double lp1[1]={ 2.000000000000000e+00}; /* 2 integration points */ static double lx2[2]={ -5.773502691896257e-01, 5.773502691896257e-01}; static double lp2[2]={ 1.000000000000000e+00, 1.000000000000000e+00}; /* 3 integration points */ static double lx3[3]={ -7.745966692414834e-01, 0.000000000000000e+00, 7.745966692414834e-01}; static double lp3[3]={ 5.555555555555552e-01, 8.888888888888888e-01, 5.555555555555552e-01}; /* 4 integration points */ static double lx4[4]={ -8.611363115940526e-01,-3.399810435848563e-01, 3.399810435848563e-01, 8.611363115940526e-01}; static double lp4[4]={ 3.478548451374537e-01, 6.521451548625464e-01, 6.521451548625464e-01, 3.478548451374537e-01}; /* 5 integration points */ static double lx5[5]={ -9.061798459386640e-01,-5.384693101056831e-01, 0.000000000000000e+00, 5.384693101056831e-01, 9.061798459386640e-01}; static double lp5[5]={ 2.369268850561890e-01, 4.786286704993665e-01, 5.688888888888889e-01, 4.786286704993665e-01, 2.369268850561890e-01}; /* 6 integration points */ static double lx6[6]={ -9.324695142031521e-01,-6.612093864662646e-01,-2.386191860831969e-01, 2.386191860831969e-01, 6.612093864662646e-01, 9.324695142031521e-01}; static double lp6[6]={ 1.713244923791705e-01, 3.607615730481386e-01, 4.679139345726913e-01, 4.679139345726913e-01, 3.607615730481386e-01, 1.713244923791705e-01}; /* 7 integration points */ static double lx7[7]={ -9.491079123427585e-01,-7.415311855993945e-01,-4.058451513773972e-01, 0.000000000000000e+00, 4.058451513773972e-01, 7.415311855993945e-01, 9.491079123427585e-01}; static double lp7[7]={ 1.294849661688697e-01, 2.797053914892767e-01, 3.818300505051190e-01, 4.179591836734694e-01, 3.818300505051190e-01, 2.797053914892767e-01, 1.294849661688697e-01}; /* 8 integration points */ static double lx8[8]={ -9.602898564975363e-01,-7.966664774136268e-01,-5.255324099163290e-01,-1.834346424956498e-01, 1.834346424956498e-01, 5.255324099163290e-01, 7.966664774136268e-01, 9.602898564975363e-01}; static double lp8[8]={ 1.012285362903768e-01, 2.223810344533745e-01, 3.137066458778874e-01, 3.626837833783620e-01, 3.626837833783620e-01, 3.137066458778874e-01, 2.223810344533745e-01, 1.012285362903768e-01}; /* 9 integration points */ static double lx9[9]={ -9.681602395076261e-01,-8.360311073266359e-01,-6.133714327005905e-01,-3.242534234038089e-01, 0.000000000000000e+00, 3.242534234038089e-01, 6.133714327005905e-01, 8.360311073266359e-01, 9.681602395076261e-01}; static double lp9[9]={ 8.127438836157463e-02, 1.806481606948576e-01, 2.606106964029355e-01, 3.123470770400029e-01, 3.302393550012598e-01, 3.123470770400029e-01, 2.606106964029355e-01, 1.806481606948576e-01, 8.127438836157463e-02}; /* 10 integration points */ static double lx10[10]={ -9.739065285171716e-01,-8.650633666889845e-01,-6.794095682990244e-01,-4.333953941292472e-01, -1.488743389816312e-01, 1.488743389816312e-01, 4.333953941292472e-01, 6.794095682990244e-01, 8.650633666889845e-01, 9.739065285171716e-01}; static double lp10[10]={ 6.667134430868774e-02, 1.494513491505805e-01, 2.190863625159822e-01, 2.692667193099962e-01, 2.955242247147529e-01, 2.955242247147529e-01, 2.692667193099962e-01, 2.190863625159822e-01, 1.494513491505805e-01, 6.667134430868774e-02}; /* 11 integration points */ static double lx11[11]={ -9.782286581460570e-01,-8.870625997680953e-01,-7.301520055740494e-01,-5.190961292068118e-01, -2.695431559523450e-01, 0.000000000000000e+00, 2.695431559523450e-01, 5.190961292068118e-01, 7.301520055740494e-01, 8.870625997680953e-01, 9.782286581460570e-01}; static double lp11[11]={ 5.566856711617354e-02, 1.255803694649047e-01, 1.862902109277343e-01, 2.331937645919903e-01, 2.628045445102466e-01, 2.729250867779006e-01, 2.628045445102466e-01, 2.331937645919903e-01, 1.862902109277343e-01, 1.255803694649047e-01, 5.566856711617354e-02}; /* 12 integration points */ static double lx12[12]={ -9.815606342467192e-01,-9.041172563704748e-01,-7.699026741943047e-01,-5.873179542866175e-01, -3.678314989981802e-01,-1.252334085114689e-01, 1.252334085114689e-01, 3.678314989981802e-01, 5.873179542866175e-01, 7.699026741943047e-01, 9.041172563704748e-01, 9.815606342467192e-01}; static double lp12[12]={ 4.717533638651183e-02, 1.069393259953182e-01, 1.600783285433463e-01, 2.031674267230658e-01, 2.334925365383548e-01, 2.491470458134029e-01, 2.491470458134029e-01, 2.334925365383548e-01, 2.031674267230658e-01, 1.600783285433463e-01, 1.069393259953182e-01, 4.717533638651183e-02}; /* 13 integration points */ static double lx13[13]={ -9.841830547185881e-01,-9.175983992229780e-01,-8.015780907333099e-01,-6.423493394403402e-01, -4.484927510364468e-01,-2.304583159551348e-01, 1.232595164407831e-32, 2.304583159551348e-01, 4.484927510364468e-01, 6.423493394403402e-01, 8.015780907333099e-01, 9.175983992229780e-01, 9.841830547185881e-01}; static double lp13[13]={ 4.048400476531581e-02, 9.212149983772838e-02, 1.388735102197872e-01, 1.781459807619457e-01, 2.078160475368884e-01, 2.262831802628971e-01, 2.325515532308739e-01, 2.262831802628971e-01, 2.078160475368884e-01, 1.781459807619457e-01, 1.388735102197872e-01, 9.212149983772838e-02, 4.048400476531581e-02}; /* 14 integration points */ static double lx14[14]={ -9.862838086968123e-01,-9.284348836635736e-01,-8.272013150697650e-01,-6.872929048116855e-01, -5.152486363581541e-01,-3.191123689278897e-01,-1.080549487073437e-01, 1.080549487073437e-01, 3.191123689278897e-01, 5.152486363581541e-01, 6.872929048116855e-01, 8.272013150697650e-01, 9.284348836635736e-01, 9.862838086968123e-01}; static double lp14[14]={ 3.511946033175199e-02, 8.015808715976037e-02, 1.215185706879031e-01, 1.572031671581936e-01, 1.855383974779378e-01, 2.051984637212955e-01, 2.152638534631578e-01, 2.152638534631578e-01, 2.051984637212955e-01, 1.855383974779378e-01, 1.572031671581936e-01, 1.215185706879031e-01, 8.015808715976037e-02, 3.511946033175199e-02}; /* 15 integration points */ static double lx15[15]={ -9.879925180204854e-01,-9.372733924007060e-01,-8.482065834104272e-01,-7.244177313601701e-01, -5.709721726085388e-01,-3.941513470775634e-01,-2.011940939974345e-01, 1.232595164407831e-32, 2.011940939974345e-01, 3.941513470775634e-01, 5.709721726085388e-01, 7.244177313601701e-01, 8.482065834104272e-01, 9.372733924007060e-01, 9.879925180204854e-01}; static double lp15[15]={ 3.075324199611663e-02, 7.036604748810814e-02, 1.071592204671720e-01, 1.395706779261543e-01, 1.662692058169940e-01, 1.861610000155622e-01, 1.984314853271116e-01, 2.025782419255613e-01, 1.984314853271116e-01, 1.861610000155622e-01, 1.662692058169940e-01, 1.395706779261543e-01, 1.071592204671720e-01, 7.036604748810814e-02, 3.075324199611663e-02}; /* 16 integration points */ static double lx16[16]={ -9.894009349916499e-01,-9.445750230732326e-01,-8.656312023878318e-01,-7.554044083550030e-01, -6.178762444026438e-01,-4.580167776572274e-01,-2.816035507792589e-01,-9.501250983763744e-02, 9.501250983763744e-02, 2.816035507792589e-01, 4.580167776572274e-01, 6.178762444026438e-01, 7.554044083550030e-01, 8.656312023878318e-01, 9.445750230732326e-01, 9.894009349916499e-01}; static double lp16[16]={ 2.715245941175406e-02, 6.225352393864778e-02, 9.515851168249290e-02, 1.246289712555339e-01, 1.495959888165768e-01, 1.691565193950026e-01, 1.826034150449236e-01, 1.894506104550685e-01, 1.894506104550685e-01, 1.826034150449236e-01, 1.691565193950026e-01, 1.495959888165768e-01, 1.246289712555339e-01, 9.515851168249290e-02, 6.225352393864778e-02, 2.715245941175406e-02}; /* 17 integration points */ static double lx17[17]={ -9.905754753144174e-01,-9.506755217687678e-01,-8.802391537269859e-01,-7.815140038968014e-01, -6.576711592166907e-01,-5.126905370864769e-01,-3.512317634538763e-01,-1.784841814958479e-01, 1.232595164407831e-32, 1.784841814958479e-01, 3.512317634538763e-01, 5.126905370864769e-01, 6.576711592166907e-01, 7.815140038968014e-01, 8.802391537269859e-01, 9.506755217687678e-01, 9.905754753144174e-01}; static double lp17[17]={ 2.414830286854792e-02, 5.545952937398713e-02, 8.503614831717915e-02, 1.118838471934039e-01, 1.351363684685256e-01, 1.540457610768104e-01, 1.680041021564499e-01, 1.765627053669926e-01, 1.794464703562065e-01, 1.765627053669926e-01, 1.680041021564499e-01, 1.540457610768104e-01, 1.351363684685256e-01, 1.118838471934039e-01, 8.503614831717915e-02, 5.545952937398713e-02, 2.414830286854792e-02}; /* 18 integration points */ static double lx18[18]={ -9.915651684209310e-01,-9.558239495713977e-01,-8.926024664975557e-01,-8.037049589725231e-01, -6.916870430603532e-01,-5.597708310739475e-01,-4.117511614628426e-01,-2.518862256915055e-01, -8.477501304173531e-02, 8.477501304173531e-02, 2.518862256915055e-01, 4.117511614628426e-01, 5.597708310739475e-01, 6.916870430603532e-01, 8.037049589725231e-01, 8.926024664975557e-01, 9.558239495713977e-01, 9.915651684209310e-01}; static double lp18[18]={ 2.161601352648315e-02, 4.971454889496984e-02, 7.642573025488918e-02, 1.009420441062872e-01, 1.225552067114784e-01, 1.406429146706506e-01, 1.546846751262652e-01, 1.642764837458327e-01, 1.691423829631435e-01, 1.691423829631435e-01, 1.642764837458327e-01, 1.546846751262652e-01, 1.406429146706506e-01, 1.225552067114784e-01, 1.009420441062872e-01, 7.642573025488918e-02, 4.971454889496984e-02, 2.161601352648315e-02}; /* 19 integration points */ static double lx19[19]={ -9.924068438435844e-01,-9.602081521348300e-01,-9.031559036148179e-01,-8.227146565371428e-01, -7.209661773352294e-01,-6.005453046616810e-01,-4.645707413759609e-01,-3.165640999636298e-01, -1.603586456402254e-01, 1.232595164407831e-32, 1.603586456402254e-01, 3.165640999636298e-01, 4.645707413759609e-01, 6.005453046616810e-01, 7.209661773352294e-01, 8.227146565371428e-01, 9.031559036148179e-01, 9.602081521348300e-01, 9.924068438435844e-01}; static double lp19[19]={ 1.946178822972643e-02, 4.481422676569959e-02, 6.904454273764125e-02, 9.149002162245014e-02, 1.115666455473341e-01, 1.287539625393363e-01, 1.426067021736066e-01, 1.527660420658597e-01, 1.589688433939544e-01, 1.610544498487837e-01, 1.589688433939544e-01, 1.527660420658597e-01, 1.426067021736066e-01, 1.287539625393363e-01, 1.115666455473341e-01, 9.149002162245014e-02, 6.904454273764125e-02, 4.481422676569959e-02, 1.946178822972643e-02}; /* 20 integration points */ static double lx20[20]={ -9.931285991850949e-01,-9.639719272779138e-01,-9.122344282513259e-01,-8.391169718222189e-01, -7.463319064601508e-01,-6.360536807265150e-01,-5.108670019508271e-01,-3.737060887154195e-01, -2.277858511416451e-01,-7.652652113349734e-02, 7.652652113349734e-02, 2.277858511416451e-01, 3.737060887154195e-01, 5.108670019508271e-01, 6.360536807265150e-01, 7.463319064601508e-01, 8.391169718222189e-01, 9.122344282513259e-01, 9.639719272779138e-01, 9.931285991850949e-01}; static double lp20[20]={ 1.761400713915226e-02, 4.060142980038705e-02, 6.267204833410904e-02, 8.327674157670474e-02, 1.019301198172405e-01, 1.181945319615183e-01, 1.316886384491766e-01, 1.420961093183819e-01, 1.491729864726038e-01, 1.527533871307260e-01, 1.527533871307260e-01, 1.491729864726038e-01, 1.420961093183819e-01, 1.316886384491766e-01, 1.181945319615183e-01, 1.019301198172405e-01, 8.327674157670474e-02, 6.267204833410904e-02, 4.060142980038705e-02, 1.761400713915226e-02}; getdp-2.4.2-source/Legacy/Treatment_Formulation.cpp000644 001750 001750 00000062144 12166744450 024052 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "ProData.h" #include "GeoData.h" #include "DofData.h" #include "Get_DofOfElement.h" #include "Get_ElementSource.h" #include "Pre_TermOfFemEquation.h" #include "Cal_GalerkinTermOfFemEquation.h" #include "Cal_GlobalTermOfFemEquation.h" #include "Cal_AssembleTerm.h" #include "Generate_Network.h" #include "ExtendedGroup.h" #include "Message.h" extern struct Problem Problem_S ; extern struct CurrentData Current ; extern int TreatmentStatus ; extern List_T * GeoData_L ; /* ------------------------------------------------------------------------ */ /* C a l _ F e m G l o b a l E q u a t i o n */ /* ------------------------------------------------------------------------ */ struct Dof * Cal_FemGlobalEquation2(int Index_DefineQuantity, int Num_Region, struct DefineQuantity * DefineQuantity_P0, struct QuantityStorage * QuantityStorage_P0) { struct DefineQuantity * DefineQuantity_P ; struct QuantityStorage * QuantityStorage_P ; struct GlobalQuantity * GlobalQuantity_P ; struct QuantityStorage QuaSto_S ; DefineQuantity_P = DefineQuantity_P0 + Index_DefineQuantity ; QuantityStorage_P = QuantityStorage_P0 + Index_DefineQuantity ; GlobalQuantity_P = (struct GlobalQuantity*) List_Pointer(QuantityStorage_P->FunctionSpace->GlobalQuantity, *(int *)List_Pointer(DefineQuantity_P->IndexInFunctionSpace, 0)) ; Get_DofOfRegion(Num_Region, GlobalQuantity_P, QuantityStorage_P->FunctionSpace, &QuaSto_S) ; if (QuaSto_S.NbrElementaryBasisFunction == 1){ return QuaSto_S.BasisFunction[0].Dof ; } else { Message::Error( "Not 1 Dof associated with GlobalQuantity (Region #%d)", Num_Region) ; return NULL ; } } void Cal_FemGlobalEquation(struct EquationTerm * EquationTerm_P, struct DefineQuantity * DefineQuantity_P0, struct QuantityStorage * QuantityStorage_P0) { int Nbr_GlobalEquationTerm, i_GlobalEquationTerm ; struct Constraint * Constraint_P ; struct GlobalEquationTerm * GlobalEquationTerm_P ; int Nbr_EquAndDof ; List_T * InitialListInIndex_L, * RegionIndex_L ; int Nbr_Region, i_Region, Num_Region, k ; int Nbr_MCPR, i_MCPR, Nbr_CPR, i_CPR, i_Node, i_Loop, j_Branch, Num_Equ ; struct MultiConstraintPerRegion * MCPR_P ; struct ConstraintPerRegion * CPR_P ; struct Group * Group_P ; double Val[NBR_MAX_HARMONIC] ; struct DofGlobal { int NumRegion ; struct Dof * Dof ; } ; List_T * DofGlobal_Equ_L, * DofGlobal_DofNode_L, * DofGlobal_DofLoop_L ; struct DofGlobal * DofGlobal_Equ, * DofGlobal_DofNode, * DofGlobal_DofLoop ; struct DofGlobal DofGlobal_S, * DofGlobal_P ; /* Liste des Regions auxquelles on associe des Equations de Type 'Network' */ RegionIndex_L = List_Create(50,50, sizeof(int)) ; Constraint_P = (struct Constraint*) List_Pointer(Problem_S.Constraint, EquationTerm_P->Case.GlobalEquation.ConstraintIndex) ; Nbr_MCPR = List_Nbr(Constraint_P->MultiConstraintPerRegion) ; for (i_MCPR = 0 ; i_MCPR < Nbr_MCPR ; i_MCPR++) { MCPR_P = (struct MultiConstraintPerRegion*) List_Pointer(Constraint_P->MultiConstraintPerRegion, i_MCPR) ; Nbr_CPR = List_Nbr(MCPR_P->ConstraintPerRegion) ; for (i_CPR = 0 ; i_CPR < Nbr_CPR ; i_CPR++) { CPR_P = (struct ConstraintPerRegion*) List_Pointer(MCPR_P->ConstraintPerRegion, i_CPR) ; Group_P = (struct Group *) List_Pointer(Problem_S.Group, CPR_P->RegionIndex) ; List_Read(Group_P->InitialList, 0, &Num_Region) ; if (!List_Search(RegionIndex_L, &Num_Region, fcmp_int)) List_Add(RegionIndex_L, &Num_Region) ; else { Message::Error("2 occurences of Elementary Region #%d in Contraint '%s'", Num_Region, Constraint_P->Name); return; } } } Nbr_EquAndDof = List_Nbr(RegionIndex_L) ; if (!Nbr_EquAndDof){ return ; } DofGlobal_Equ_L = List_Create(Nbr_EquAndDof, 1, sizeof(struct DofGlobal)) ; DofGlobal_DofNode_L = List_Create(Nbr_EquAndDof, 1, sizeof(struct DofGlobal)) ; DofGlobal_DofLoop_L = List_Create(Nbr_EquAndDof, 1, sizeof(struct DofGlobal)) ; /* Construction des listes de Dof globaux pour Equ, DofNode, DofLoop */ Nbr_GlobalEquationTerm = List_Nbr(EquationTerm_P->Case.GlobalEquation.GlobalEquationTerm) ; for (i_GlobalEquationTerm = 0 ; i_GlobalEquationTerm < Nbr_GlobalEquationTerm ; i_GlobalEquationTerm++) { GlobalEquationTerm_P = (struct GlobalEquationTerm*) List_Pointer(EquationTerm_P->Case.GlobalEquation.GlobalEquationTerm, i_GlobalEquationTerm) ; InitialListInIndex_L = ((struct Group *)List_Pointer(Problem_S.Group, GlobalEquationTerm_P->InIndex))->InitialList ; Nbr_Region = List_Nbr(InitialListInIndex_L) ; List_Sort(InitialListInIndex_L, fcmp_int) ; for (i_Region = 0 ; i_Region < Nbr_Region ; i_Region++) { List_Read(InitialListInIndex_L, i_Region, &Num_Region) ; if (List_Search(RegionIndex_L, &Num_Region, fcmp_int)) { DofGlobal_S.NumRegion = Num_Region ; DofGlobal_S.Dof = Cal_FemGlobalEquation2 (GlobalEquationTerm_P->DefineQuantityIndexEqu, Num_Region, DefineQuantity_P0, QuantityStorage_P0) ; List_Add(DofGlobal_Equ_L, &DofGlobal_S) ; DofGlobal_S.Dof = Cal_FemGlobalEquation2 (GlobalEquationTerm_P->DefineQuantityIndexNode, Num_Region, DefineQuantity_P0, QuantityStorage_P0) ; List_Add(DofGlobal_DofNode_L, &DofGlobal_S) ; DofGlobal_S.Dof = Cal_FemGlobalEquation2 (GlobalEquationTerm_P->DefineQuantityIndexLoop, Num_Region, DefineQuantity_P0, QuantityStorage_P0) ; List_Add(DofGlobal_DofLoop_L, &DofGlobal_S) ; } } } if (List_Nbr(DofGlobal_Equ_L) != Nbr_EquAndDof) { Message::Error("Incompatible number of equations with Contraint '%s' " "(%d equations obtained while %d branches are defined)", Constraint_P->Name, List_Nbr(DofGlobal_Equ_L), Nbr_EquAndDof); return; } DofGlobal_Equ = (struct DofGlobal*)List_Pointer(DofGlobal_Equ_L , 0) ; DofGlobal_DofNode = (struct DofGlobal*)List_Pointer(DofGlobal_DofNode_L, 0) ; DofGlobal_DofLoop = (struct DofGlobal*)List_Pointer(DofGlobal_DofLoop_L, 0) ; for (k = 0 ; k < List_Nbr(DofGlobal_Equ_L) ; k++) { if (DofGlobal_Equ[k].Dof->Type == DOF_FIXED || DofGlobal_Equ[k].Dof->Type == DOF_LINK) { if (DofGlobal_Equ[k].Dof == DofGlobal_DofNode[k].Dof) DofGlobal_Equ[k].Dof = DofGlobal_DofLoop[k].Dof ; else DofGlobal_Equ[k].Dof = DofGlobal_DofNode[k].Dof ; } } /* Construction des equations (assemblage) */ Num_Equ = 0 ; Nbr_MCPR = List_Nbr(Constraint_P->MultiConstraintPerRegion) ; for (i_MCPR = 0 ; i_MCPR < Nbr_MCPR ; i_MCPR++) { MCPR_P = (struct MultiConstraintPerRegion*) List_Pointer(Constraint_P->MultiConstraintPerRegion, i_MCPR) ; if (!MCPR_P->Active) MCPR_P->Active = Generate_Network(MCPR_P->Name, MCPR_P->ConstraintPerRegion) ; for (i_Node = 0 ; i_Node < MCPR_P->Active->Case.Network.NbrNode ; i_Node++) { for (j_Branch = 0 ; j_Branch < MCPR_P->Active->Case.Network.NbrBranch ; j_Branch++) { if (MCPR_P->Active->Case.Network.MatNode[i_Node][j_Branch]) { Group_P = (struct Group *) List_Pointer (Problem_S.Group, ((struct ConstraintPerRegion *) List_Pointer(MCPR_P->ConstraintPerRegion, j_Branch))->RegionIndex) ; List_Read(Group_P->InitialList, 0, &Num_Region) ; DofGlobal_P = (struct DofGlobal*) List_PQuery(DofGlobal_DofNode_L, &Num_Region, fcmp_int) ; Val[0] = (double)(MCPR_P->Active->Case.Network.MatNode[i_Node][j_Branch]) ; if (Current.NbrHar > 1) { Val[1] = 0. ; for (k = 2 ; k < Current.NbrHar ; k += 2) { Val[k] = Val[0] ; Val[k+1] = 0. ; } } /* Message::Info("Node: eq.(%d) [%d, %d], dof [%d, %d] : %.16g\n", Num_Equ, DofGlobal_Equ[Num_Equ].Dof->NumType, DofGlobal_Equ[Num_Equ].Dof->Entity, DofGlobal_P->Dof->NumType, DofGlobal_P->Dof->Entity, Val[0] ) ; */ Cal_AssembleTerm_NeverDt(DofGlobal_Equ[Num_Equ].Dof, DofGlobal_P->Dof, Val) ; } } Num_Equ++ ; } /* for i_Node ... */ for (i_Loop = 0 ; i_Loop < MCPR_P->Active->Case.Network.NbrLoop ; i_Loop++) { for (j_Branch = 0 ; j_Branch < MCPR_P->Active->Case.Network.NbrBranch ; j_Branch++) { if (MCPR_P->Active->Case.Network.MatLoop[i_Loop][j_Branch]) { Group_P = (struct Group *) List_Pointer (Problem_S.Group, ((struct ConstraintPerRegion *) List_Pointer(MCPR_P->ConstraintPerRegion, j_Branch))->RegionIndex) ; List_Read(Group_P->InitialList, 0, &Num_Region) ; DofGlobal_P = (struct DofGlobal*) List_PQuery(DofGlobal_DofLoop_L, &Num_Region, fcmp_int) ; Val[0] = (double)(MCPR_P->Active->Case.Network.MatLoop[i_Loop][j_Branch]) ; if (Current.NbrHar > 1) { Val[1] = 0. ; for (k = 2 ; k < Current.NbrHar ; k += 2) { Val[k] = Val[0] ; Val[k+1] = 0. ; } } /* Message::Info("Loop: eq.(%d) [%d, %d], dof [%d, %d] : %.16g\n", Num_Equ, DofGlobal_Equ[Num_Equ].Dof->NumType, DofGlobal_Equ[Num_Equ].Dof->Entity, DofGlobal_P->Dof->NumType, DofGlobal_P->Dof->Entity, Val[0] ) ; */ Cal_AssembleTerm_NeverDt(DofGlobal_Equ[Num_Equ].Dof, DofGlobal_P->Dof, Val) ; } } Num_Equ++ ; } /* for i_Loop ... */ } /* for i_MCPR ... */ List_Delete(DofGlobal_Equ_L) ; List_Delete(DofGlobal_DofNode_L) ; List_Delete(DofGlobal_DofLoop_L) ; List_Delete(RegionIndex_L) ; } /* ------------------------------------------------------------------------ */ /* T r e a t m e n t _ F e m F o r m u l a t i o n */ /* ------------------------------------------------------------------------ */ void Treatment_FemFormulation(struct Formulation * Formulation_P) { struct Element Element ; struct QuantityStorage * QuantityStorage_P0, * QuantityStorage_P ; struct QuantityStorage QuantityStorage_S ; struct Dof DofForNoDof_P [NBR_MAX_HARMONIC] ; struct EquationTerm * EquationTerm_P0 , * EquationTerm_P ; struct GlobalQuantity * GlobalQuantity_P ; int Nbr_DefineQuantity ; struct DefineQuantity * DefineQuantity_P0 , * DefineQuantity_P ; List_T * FemLocalTermActive_L ; struct FemLocalTermActive FemLocalTermActive_S ; List_T * QuantityStorage_L ; struct Group * GroupIn_P ; int i, j, Nbr_Element, i_Element, Nbr_EquationTerm, i_EquTerm ; int Index_DefineQuantity, TraceGroupIndex_DefineQuantity ; List_T * InitialListInIndex_L ; int Nbr_Region, i_Region, Num_Region ; extern struct Group * Generate_Group ; extern double ** MH_Moving_Matrix ; gMatrix A = Current.DofData->A ; gVector b = Current.DofData->b ; int Flag_Only ; /* --------------------------------------------------------------- */ /* 0. Initialization of an active zone (QuantityStorage) for each */ /* DefineQuantity */ /* --------------------------------------------------------------- */ if (!(Nbr_EquationTerm = List_Nbr(Formulation_P->Equation))){ Message::Error("No equation in Formulation '%s'", Formulation_P->Name); return; } if (!(Nbr_DefineQuantity = List_Nbr(Formulation_P->DefineQuantity))){ Message::Error("No Quantity in Formulation '%s'", Formulation_P->Name); return; } DefineQuantity_P0 = (struct DefineQuantity*) List_Pointer(Formulation_P->DefineQuantity, 0) ; QuantityStorage_L = List_Create(Nbr_DefineQuantity, 1, sizeof (struct QuantityStorage) ) ; QuantityStorage_S.NumLastElementForFunctionSpace = QuantityStorage_S.NumLastElementForDofDefinition = QuantityStorage_S.NumLastElementForEquDefinition = 0 ; for (i = 0 ; i < Nbr_DefineQuantity ; i++) { QuantityStorage_S.DefineQuantity = DefineQuantity_P0 + i ; if(QuantityStorage_S.DefineQuantity->Type == INTEGRALQUANTITY && QuantityStorage_S.DefineQuantity->IntegralQuantity.DefineQuantityIndexDof < 0){ QuantityStorage_S.FunctionSpace = NULL ; QuantityStorage_S.TypeQuantity = VECTOR ; /* to change */ } else{ QuantityStorage_S.FunctionSpace = (struct FunctionSpace*) List_Pointer(Problem_S.FunctionSpace, QuantityStorage_S.DefineQuantity->FunctionSpaceIndex) ; QuantityStorage_S.TypeQuantity = QuantityStorage_S.FunctionSpace->Type ; } List_Add(QuantityStorage_L, &QuantityStorage_S) ; } QuantityStorage_P0 = (struct QuantityStorage*)List_Pointer(QuantityStorage_L, 0) ; Get_InitDofOfElement(&Element) ; /* --------------------------------------------------------------- */ /* 1. Initialization of equation terms */ /* --------------------------------------------------------------- */ EquationTerm_P0 = (struct EquationTerm*)List_Pointer(Formulation_P->Equation, 0) ; FemLocalTermActive_L = List_Create(Nbr_EquationTerm, 1, sizeof (struct FemLocalTermActive) ) ; for (i_EquTerm = 0 ; i_EquTerm < Nbr_EquationTerm ; i_EquTerm++) { List_Add(FemLocalTermActive_L, &FemLocalTermActive_S) ; EquationTerm_P = EquationTerm_P0 + i_EquTerm ; switch(EquationTerm_P->Type){ case GALERKIN : EquationTerm_P->Case.LocalTerm.Active = (struct FemLocalTermActive*) List_Pointer(FemLocalTermActive_L, i_EquTerm) ; switch (TreatmentStatus) { case _PRE : Pre_InitTermOfFemEquation(EquationTerm_P, QuantityStorage_P0) ; break ; case _CAL : Cal_InitGalerkinTermOfFemEquation(EquationTerm_P, QuantityStorage_P0, &QuantityStorage_S, DofForNoDof_P) ; break ; } break; case GLOBALTERM : switch (TreatmentStatus) { case _PRE : Pre_InitGlobalTermOfFemEquation(EquationTerm_P, QuantityStorage_P0) ; break ; } break; case GLOBALEQUATION : break ; default : Message::Error("Unknown type of equation term") ; break ; } } /* ---------------------------------------------------------- */ /* 2. Loop on geometrical elements : */ /* Treatment of eventual GALERKIN terms */ /* --------------------------------------------------------- */ Nbr_Element = Geo_GetNbrGeoElements() ; Message::ResetProgressMeter(); for (i_Element = 0 ; i_Element < Nbr_Element; i_Element++) { if (Generate_Group) { Element.Region = Geo_GetGeoElement(i_Element)->Region ; while (i_Element < Nbr_Element && !List_Search(Generate_Group->InitialList, &Element.Region, fcmp_int) ) { i_Element++ ; if (i_Element < Nbr_Element) Element.Region = Geo_GetGeoElement(i_Element)->Region ; } if (i_Element == Nbr_Element) break ; } Element.GeoElement = Geo_GetGeoElement(i_Element) ; Element.Num = Element.GeoElement->Num ; Element.Type = Element.GeoElement->Type ; Current.Region = Element.Region = Element.GeoElement->Region ; /* ---------------------------- */ /* 2.1. Loop on equation terms */ /* ---------------------------- */ for (i_EquTerm = 0 ; i_EquTerm < Nbr_EquationTerm ; i_EquTerm++) { EquationTerm_P = EquationTerm_P0 + i_EquTerm ; if (EquationTerm_P->Type == GALERKIN) { /* if the element is in the support of integration of the term */ /* ----------------------------------------------------------- */ GroupIn_P = (struct Group *) List_Pointer(Problem_S.Group, EquationTerm_P->Case.LocalTerm.InIndex); if ((GroupIn_P->Type != ELEMENTLIST && List_Search(GroupIn_P->InitialList, &Element.Region, fcmp_int)) || (GroupIn_P->Type == ELEMENTLIST && Check_IsEntityInExtendedGroup(GroupIn_P, Element.Num, 0)) ) { /* if (List_Search(((struct Group *) List_Pointer(Problem_S.Group, EquationTerm_P->Case. LocalTerm.InIndex))->InitialList, &Element.Region, fcmp_int ) ) { */ if(Message::GetVerbosity() == 10) printf("==> Element #%d, EquationTerm #%d/%d\n", Element.Num, i_EquTerm+1, Nbr_EquationTerm) ; Current.IntegrationSupportIndex = EquationTerm_P->Case.LocalTerm.InIndex ; /* ---------------------------------------------------------- */ /* 2.1.1. Loop on quantities (test fcts and shape functions) */ /* ---------------------------------------------------------- */ for (i = 0 ; i < EquationTerm_P->Case.LocalTerm.Term.NbrQuantityIndex ; i++) { Index_DefineQuantity = EquationTerm_P->Case.LocalTerm.Term.QuantityIndexTable[i] ; DefineQuantity_P = DefineQuantity_P0 + Index_DefineQuantity ; QuantityStorage_P = QuantityStorage_P0 + Index_DefineQuantity ; TraceGroupIndex_DefineQuantity = EquationTerm_P->Case.LocalTerm.Term.QuantityTraceGroupIndexTable[i] ; /* Only one analysis for each function space */ /* * Attention : l'operateur de trace ne fonctionne que si le champ * dont on prend la trace n'intervient qu'une seule fois dans le terme. * du a - manque de generalite du code au niveau de la gestion des * espaces fonctionnels des fcts tests pour 'Trace de Dof' * - et Christophe fatigu */ if (QuantityStorage_P->NumLastElementForFunctionSpace != Element.Num || TraceGroupIndex_DefineQuantity >= 0 ) { QuantityStorage_P->NumLastElementForFunctionSpace = Element.Num ; switch (DefineQuantity_P->Type) { case LOCALQUANTITY : if(TraceGroupIndex_DefineQuantity >= 0){ Get_ElementTrace(&Element, TraceGroupIndex_DefineQuantity) ; QuantityStorage_P->NumLastElementForFunctionSpace = Element.ElementTrace->Num ; Get_DofOfElement (Element.ElementTrace, QuantityStorage_P->FunctionSpace, QuantityStorage_P, DefineQuantity_P->IndexInFunctionSpace) ; } else{ Get_DofOfElement (&Element, QuantityStorage_P->FunctionSpace, QuantityStorage_P, DefineQuantity_P->IndexInFunctionSpace) ; } break ; case INTEGRALQUANTITY : QuantityStorage_P->NbrElementaryBasisFunction = 0 ; break ; default : Message::Error("Bad kind of Quantity in Formulation '%s'", Formulation_P->Name); break; } } } /* for i = 0, 1 ... */ /* -------------------------------------- */ /* 2.1.2. Treatment of the equation term */ /* -------------------------------------- */ switch (TreatmentStatus) { case _PRE : Pre_TermOfFemEquation(&Element, EquationTerm_P, QuantityStorage_P0) ; break ; case _CAL : Flag_Only = 0 ; if (Current.DofData->Flag_Only){ A = Current.DofData->A ; b = Current.DofData->b ; if (EquationTerm_P->Case.LocalTerm.MatrixIndex == -1) EquationTerm_P->Case.LocalTerm.MatrixIndex = 0 ; j = List_ISearch(Current.DofData->OnlyTheseMatrices, &EquationTerm_P->Case.LocalTerm.MatrixIndex, fcmp_int) ; if(j!=-1){ Flag_Only = 1 ; switch(EquationTerm_P->Case.LocalTerm.MatrixIndex){ case 1 : Current.DofData->A = Current.DofData->A1 ; Current.DofData->b = Current.DofData->b1 ; break; case 2 : Current.DofData->A = Current.DofData->A2 ; Current.DofData->b = Current.DofData->b2 ; break; case 3 : Current.DofData->A = Current.DofData->A3 ; Current.DofData->b = Current.DofData->b3 ; break; } } }/* Only the matrices that vary are recalculated */ if (!Current.DofData->Flag_Only || (Current.DofData->Flag_Only && Flag_Only) ){ QuantityStorage_P = QuantityStorage_P0 + EquationTerm_P->Case.LocalTerm.Term.DefineQuantityIndexEqu ; if(EquationTerm_P->Type == GALERKIN) Cal_GalerkinTermOfFemEquation(&Element, EquationTerm_P, QuantityStorage_P0) ; if (Current.DofData->Flag_Only && Flag_Only){ Current.DofData->A = A ; Current.DofData->b = b ; } }/* Flag_Only */ break ; case _CST : Cst_TermOfFemEquation(&Element, EquationTerm_P, QuantityStorage_P0) ; break ; } }/* if Support ... */ } /* if GALERKIN ... */ } /* for i_EquTerm ... */ Message::ProgressMeter(i_Element + 1, Nbr_Element, (TreatmentStatus == _PRE) ? "Pre-processing" : "Processing (Generate)"); if(Message::GetErrorCount()) break; } /* for i_Element ... */ if (MH_Moving_Matrix) { List_Delete(FemLocalTermActive_L) ; List_Delete(QuantityStorage_L) ; return; } /* ------------------------------------------------------ */ /* 3. Loop on equation terms : */ /* Treatment of eventual GLOBAL terms */ /* ------------------------------------------------------ */ for (i_EquTerm = 0 ; i_EquTerm < Nbr_EquationTerm ; i_EquTerm++) { EquationTerm_P = EquationTerm_P0 + i_EquTerm ; if (EquationTerm_P->Type == GLOBALTERM) { InitialListInIndex_L = ((struct Group *)List_Pointer(Problem_S.Group, EquationTerm_P->Case.GlobalTerm.InIndex)) ->InitialList ; List_Sort(InitialListInIndex_L, fcmp_int) ; Nbr_Region = List_Nbr(InitialListInIndex_L) ; /* ---------------------------------------------- */ /* 3.1. Loop on Regions belonging to the support */ /* ---------------------------------------------- */ for (i_Region = 0 ; i_Region < Nbr_Region ; i_Region++) { List_Read(InitialListInIndex_L, i_Region, &Num_Region) ; Current.Region = Num_Region ; /* ---------------------------------------------------------------- */ /* 3.1.1. Loop on Quantities (test functions and shape functions) */ /* ---------------------------------------------------------------- */ for (i = 0 ; i < EquationTerm_P->Case.GlobalTerm.Term.NbrQuantityIndex ; i++) { Index_DefineQuantity = EquationTerm_P->Case.GlobalTerm.Term.QuantityIndexTable[i] ; DefineQuantity_P = DefineQuantity_P0 + Index_DefineQuantity ; QuantityStorage_P = QuantityStorage_P0 + Index_DefineQuantity ; GlobalQuantity_P = (struct GlobalQuantity*) List_Pointer(QuantityStorage_P->FunctionSpace->GlobalQuantity, *(int*)List_Pointer(DefineQuantity_P->IndexInFunctionSpace, 0)) ; /* Only one Function space analysis */ /* -------------------------------- */ if (QuantityStorage_P->NumLastElementForFunctionSpace != Num_Region) { QuantityStorage_P->NumLastElementForFunctionSpace = Num_Region ; switch (DefineQuantity_P->Type) { case GLOBALQUANTITY : Get_DofOfRegion (Num_Region, GlobalQuantity_P, QuantityStorage_P->FunctionSpace, QuantityStorage_P) ; break ; default : Message::Error("Bad kind of Quantity in Formulation '%s'", Formulation_P->Name); break; } } } /* for i = 0, 1 ... */ /* ------------------------------ */ /* 3.1.2. Treatment of the term */ /* ------------------------------ */ switch (TreatmentStatus) { case _PRE : Pre_GlobalTermOfFemEquation(Num_Region, EquationTerm_P, QuantityStorage_P0) ; break ; case _CAL : Cal_GlobalTermOfFemEquation(Num_Region, EquationTerm_P, QuantityStorage_P0, &QuantityStorage_S, DofForNoDof_P) ; break ; case _CST : Cst_GlobalTermOfFemEquation(Num_Region, EquationTerm_P, QuantityStorage_P0) ; break ; } } } /* if GLOBALTERM ... */ } /* for i_EquTerm ... */ /* --------------------------------------------------------- */ /* 4. Loop on equation terms : */ /* Treatment of eventual GLOBAL EQUATION terms */ /* --------------------------------------------------------- */ for (i_EquTerm = 0 ; i_EquTerm < Nbr_EquationTerm ; i_EquTerm++) { EquationTerm_P = EquationTerm_P0 + i_EquTerm ; if (EquationTerm_P->Type == GLOBALEQUATION) { if (EquationTerm_P->Case.GlobalEquation.ConstraintIndex >= 0) switch (TreatmentStatus) { case _PRE : Pre_FemGlobalEquation(EquationTerm_P, DefineQuantity_P0, QuantityStorage_P0) ; break ; case _CAL : Cal_FemGlobalEquation(EquationTerm_P, DefineQuantity_P0, QuantityStorage_P0) ; break ; } } /* if GLOBALEQUATION ... */ } /* for i_EquTerm ... */ /* -------------------------- */ /* 5. End of FEM treatment */ /* -------------------------- */ List_Delete(FemLocalTermActive_L) ; List_Delete(QuantityStorage_L) ; } /* ------------------------------------------------------------------------ */ /* T r e a t m e n t _ G l o b a l F o r m u l a t i o n */ /* ------------------------------------------------------------------------ */ void Treatment_GlobalFormulation(struct Formulation * Formulation_P) { Message::Error("You should not be here!") ; } /* ------------------------------------------------------------------------ */ /* T r e a t m e n t _ F o r m u l a t i o n */ /* ------------------------------------------------------------------------ */ void Treatment_Formulation(struct Formulation * Formulation_P) { switch (Formulation_P->Type) { case FEMEQUATION : Treatment_FemFormulation(Formulation_P) ; break ; case GLOBALEQUATION : Treatment_GlobalFormulation(Formulation_P) ; break ; default : Message::Error("Unknown type for Formulation '%s'", Formulation_P->Name) ; break ; } } getdp-2.4.2-source/Legacy/Cal_Value.h000644 001750 001750 00000006701 12116424202 021006 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _CAL_VALUE_H_ #define _CAL_VALUE_H_ #include #include "ProData.h" void Cal_CopyValue (struct Value *V1, struct Value *R); void Cal_CopyValueArray (struct Value *V1, struct Value *R, int Nbr_Values); void Cal_ZeroValue (struct Value *V1); void Cal_AddValue (struct Value *V1, struct Value *V2, struct Value *R) ; void Cal_AddValueArray (struct Value *V1, struct Value *V2, struct Value *R, int Nbr_Values); void Cal_SubstractValue (struct Value *V1, struct Value *V2, struct Value *R) ; void Cal_ProductValue (struct Value *V1, struct Value *V2, struct Value *R) ; void Cal_SqrtValue (struct Value *V1, struct Value *R) ; void Cal_DivideValue (struct Value *V1, struct Value *V2, struct Value *R) ; void Cal_ModuloValue (struct Value *V1, struct Value *V2, struct Value *R) ; void Cal_CrossProductValue (struct Value *V1, struct Value *V2, struct Value *R) ; void Cal_PowerValue (struct Value *V1, struct Value *V2, struct Value *R) ; void Cal_RotateValue (struct Value *V1, struct Value *V2, struct Value *R); void Cal_InvertValue (struct Value *V1, struct Value *R); void Cal_DetValue (struct Value *V1, struct Value *R); void Cal_TransposeValue (struct Value *V1, struct Value *R); void Cal_TraceValue (struct Value *V1, struct Value *R); void Cal_LessValue (struct Value *V1, struct Value *V2, struct Value *R) ; void Cal_GreaterValue (struct Value *V1, struct Value *V2, struct Value *R) ; void Cal_LessOrEqualValue (struct Value *V1, struct Value *V2, struct Value *R) ; void Cal_GreaterOrEqualValue (struct Value *V1, struct Value *V2, struct Value *R) ; void Cal_EqualValue (struct Value *V1, struct Value *V2, struct Value *R) ; void Cal_NotEqualValue (struct Value *V1, struct Value *V2, struct Value *R) ; void Cal_ApproxEqualValue (struct Value *V1, struct Value *V2, struct Value *R) ; void Cal_AndValue (struct Value *V1, struct Value *V2, struct Value *R) ; void Cal_OrValue (struct Value *V1, struct Value *V2, struct Value *R) ; void Cal_NegValue (struct Value *V1) ; void Cal_NotValue (struct Value *V1) ; void Cal_SetHarmonicValue (struct Value *R) ; void Cal_SetZeroHarmonicValue(struct Value *R, int Save_NbrHar) ; void Cal_MultValue (struct Value * V1, double d, struct Value * R) ; void Cal_AddMultValue (struct Value *V1, struct Value *V2, double d, struct Value *R) ; void Cal_AddMultValueArray (struct Value *V1, struct Value *V2, double d, struct Value *R,int Nbr_Values) ; void Cal_AddMultValue2 (struct Value *V1, double d1, struct Value *V2, double d2) ; void Cal_ComplexProduct (double V1[], double V2[], double P[]); void Cal_ComplexDivision (double V1[], double V2[], double P[]); void Cal_ComplexInvert (double V1[], double P[]); /* Debug */ std::string Print_Value_ToString(struct Value *A); void Print_Value (struct Value *A); void Show_Value (struct Value *A); /* From struct Value to array of doubles */ void Cal_ValueArray2DoubleArray(struct Value *V1, double *R, int Nbr_Values) ; void Cal_AddValueArray2DoubleArray(struct Value *V1, double *R, int Nbr_Values) ; #endif getdp-2.4.2-source/Legacy/Operation_IterativeLinearSolver.cpp000644 001750 001750 00000157571 12171526422 026034 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributed by Bertrand Thierry #include #include "GetDPConfig.h" #include "ProData.h" #include "SolvingOperations.h" #include "Message.h" #include "OS.h" #include #include #include // for performance tests #if !defined(WIN32) //#define TIMER #endif #if defined(HAVE_PETSC) && defined(HAVE_GMSH) #include "petscksp.h" #include #include #include class ILS{ //A new communicator can be created. If some processes have no work they must //be excluded from the communicator to avoir dead-lock private: // current cpu number and total number of cpus static MPI_Comm _comm; static int _commRank, _commSize; //static std::vector< double > time_MatMult; //static std::vector< double > time_Bcast; public: static int GetCommRank(){ return _commRank; } static int GetCommSize(){ return _commSize; } static MPI_Comm GetComm(){ return _comm; } // static void AddTimeMatMult(double t){time_MatMult.push_back(t);}; //static void AddTimeBcast(double t){time_Bcast.push_back(t);}; }; MPI_Comm ILS::_comm = MPI_COMM_WORLD; int ILS::_commRank = 0; int ILS::_commSize = 1; class Field{ public: PetscInt nb_field; //number of Fields in this class PetscInt n_elem; //total number of element of all fields in this class std::vector GmshTag; //GmshTag[j] = tag of field j (in getdp/gmsh, ie : outside IterativeLinearSolver) std::vector ILSTag; //ILSTag[j] = local tag of field j in the function IterativeLinearSolver (usefull for MyField). std::vector rank; //rank[j] is the mpi_rank of the process that owns field j std::vector size; //size[j] = nb of elements in the field j std::vector iStart; //starting index in the Petsc Vec containing all the fields std::vector iEnd; //same as iStart but ending (a priori useless) //variables for transfering data with neighbors static bool areNeighbor; int nb_field_to_receive; // number of field that this process must receive // std::vector comm; //comm[j] is the communicator of process that need Field[j] (i.e : process that will participate to the broadcast of the view) std::vector > myN; std::vector > mySizeV; //sizes of vectors of PView that this process is in charge std::vector > theirN; std::vector > theirSizeV; std::vector FieldToReceive; //GmshTag of the fields that must be received by the current MPI processe (concatenation of myNeighbor) std::vector > RankToSend; //RankToSend[j] returns the rank to which the j^th local field must be sent //CPU Time std::vector TimeBcast, TimeIt, TimeTreatment; //The bellow function is usefull to do a reverse search: //Given the GmshTag of a field (GetDP/GMSH) it returns its local tag in IterativeLinearSolver (ILSTag) //Indeed, ILS can renumber the field in another way than gmsh/getdp int GetILSTagFromGmshTag(int gTag){ for (int j = 0; j < nb_field ; j++) if(GmshTag[j] == gTag) return ILSTag[j]; return -1; //error } int GetRankFromGmshTag(int gTag){ for (int j = 0; j < nb_field ; j++) if(GmshTag[j] == gTag) return rank[j]; return -1; //error } int GetRankFromILSTag(int ilsTag){ for (int j = 0; j < nb_field ; j++) if(ILSTag[j] == ilsTag) return rank[j]; return -1; //error } int GetGmshTagFromRank(int irank){ for (int j = 0; j < nb_field ; j++) if(rank[j] == irank) return GmshTag[j]; return -1; //error } }; bool Field::areNeighbor = false; // Matrix Free structure (Matrix Shell) typedef struct{ char *LinearSystemType; Field *MyField; Field *AllField; struct Resolution *Resolution_P; struct Operation *Operation_P; struct DofData *DofData_P0; struct GeoData *GeoData_P0; } ILSMat; PetscErrorCode ReadFields(int nb_field, int nth_vect, struct Operation *Operation_P, std::vector > > *vector_field, std::vector *tagFields_loc, std::vector *sizes_field, int *n); PetscErrorCode InitData(Field *MyField, Field *AllField, struct Operation *Operation_P, std::vector > > *B_std); PetscErrorCode PViewBCast(Field MyField, Field AllField); PetscErrorCode Orthonormalizer(std::vector X, int SizeX); PetscErrorCode DgmresDDM_Build(Mat A, int nb_field, int nb_deflation, Mat *M); PetscErrorCode BuildIterationMatrix(Mat A, Mat *IterationMatrix); PetscErrorCode PrintMatrix(Mat A, const char* fileName, const char* varname); PetscErrorCode PrintVec(Vec b, const char* filename, const char* varname); PetscErrorCode PrintVecSeq(Vec b, const char* filename, const char* varname); PetscErrorCode Jacobi_Solver(Mat A, Vec X, Vec B, double Tol, int MaxIter); PetscErrorCode MatMultILSMat(Mat A, Vec X, Vec Y); PetscErrorCode MatMultPC(PC pc, Vec X, Vec Y); PetscErrorCode STD_vector_to_PETSc_Vec(std::vector > > std_vec, Vec petsc_vec, Field *Local); PetscErrorCode PETSc_Vec_to_STD_Vec(Vec petsc_vec, Field *Local, std::vector > > *std_vec); PetscErrorCode CreateILSMat(ILSMat **shell); PetscErrorCode SetILSMat(ILSMat **shell, char *LinearSystemType, Field *MyField, Field *AllField, struct Resolution *Resolution_P, struct Operation *Operation_P, struct DofData *DofData_P0, struct GeoData *GeoData_P0); int Operation_IterativeLinearSolver(struct Resolution *Resolution_P, struct Operation *Operation_P, struct DofData *DofData_P0, struct GeoData *GeoData_P0) { PetscErrorCode ierr; int mpi_comm_size = Message::GetCommSize(); int mpi_comm_rank = Message::GetCommRank(); ILSMat *ctx, *ctx_pc; // Matrix Shell context and PC context Mat A; KSP ksp; #if (PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR == 4) const char *ksp_choice = ""; #else const KSPType ksp_choice; #endif int MaxIter, Restart; double Tol; std::vector > > B_std; // right hand side (std version) Vec B, X;// right hand side and Solution PC pc; MPI_Comm ILSComm = PETSC_COMM_WORLD; //by default, KSP is launch in total parallel char *LinearSystemType; Field MyField, AllField; #if defined(TIMER) double time_total = 0.; double time_start = MPI_Wtime(); #endif /*------------- Initializing -----------*/ MPI_Barrier(PETSC_COMM_WORLD); Message::Info("Initalizing Iterative Linear Solver"); InitData(&MyField, &AllField, Operation_P, &B_std); /*------------------- Print Informations -----------------*/ Tol = Operation_P->Case.IterativeLinearSolver.Tolerance; MaxIter = Operation_P->Case.IterativeLinearSolver.MaxIter; Restart = Operation_P->Case.IterativeLinearSolver.Restart; ksp_choice = Operation_P->Case.IterativeLinearSolver.Type; LinearSystemType = Operation_P->Case.IterativeLinearSolver.OpMatMult; if(strcmp(LinearSystemType, "I-A") && strcmp(LinearSystemType, "I+A") && strcmp(LinearSystemType, "A")){ char tmp[1024]; sprintf(tmp, "Linear system type \"%s\" unknown. Try \"A\", \"I-A\" or \"I+A\".", LinearSystemType); Message::Error(tmp); } //Print informations if(!strcmp(LinearSystemType, "A")) ierr = PetscPrintf(PETSC_COMM_WORLD, "Linear system type\t: %sX = B\n", LinearSystemType); else ierr = PetscPrintf(PETSC_COMM_WORLD, "Linear system type\t: (%s)X = B\n", LinearSystemType); CHKERRQ(ierr); if(mpi_comm_size >1){ ierr = PetscPrintf(PETSC_COMM_WORLD, "Number of Processus\t: %d\n", mpi_comm_size);CHKERRQ(ierr);} ierr = PetscPrintf(PETSC_COMM_WORLD, "Iterative solver\t: %s\n", ksp_choice);CHKERRQ(ierr); ierr = PetscPrintf(PETSC_COMM_WORLD, "Tolerance\t\t: %g\n", Tol);CHKERRQ(ierr); ierr = PetscPrintf(PETSC_COMM_WORLD, "Max. numb. of iterations: %i\n", MaxIter);CHKERRQ(ierr); if(Restart >0){ierr = PetscPrintf(PETSC_COMM_WORLD, "Restart\t\t\t: %i\n", Restart);CHKERRQ(ierr);} else{ierr = PetscPrintf(PETSC_COMM_WORLD, "Restart\t\t\t: No Restart\n");CHKERRQ(ierr);} //if jacobi then MatMult(A,X) = A*X for linear system (I-A)*X=B if(!strcmp(ksp_choice, "jacobi")){ if(strcmp(LinearSystemType, "I-A")) Message::Error("Jacobi method implemented only for linear system of type \"I-A\""); LinearSystemType = (char *)"A"; } ierr = PetscPrintf(PETSC_COMM_WORLD, "Number of Fields\t: %d\n", AllField.nb_field);CHKERRQ(ierr); if(Field::areNeighbor) ierr = PetscPrintf(PETSC_COMM_WORLD, "Neighbors are specified\t: Fast exchange between process\n");CHKERRQ(ierr); for(int iField = 0; iField < AllField.nb_field; iField++) if(mpi_comm_size>1) if(AllField.GmshTag[iField] < 10) ierr = PetscPrintf(PETSC_COMM_WORLD, "Size of Field %d\t\t: %d (on CPU %d)\n", AllField.GmshTag[iField], AllField.size[iField], AllField.rank[iField]); else ierr = PetscPrintf(PETSC_COMM_WORLD, "Size of Field %d\t: %d (on CPU %d)\n", AllField.GmshTag[iField], AllField.size[iField], AllField.rank[iField]); else if(AllField.GmshTag[iField] < 10) ierr = PetscPrintf(PETSC_COMM_WORLD, "Size of Field %d\t\t: %d\n", AllField.GmshTag[iField], AllField.size[iField]); else ierr = PetscPrintf(PETSC_COMM_WORLD, "Size of Field %d\t: %d\n", AllField.GmshTag[iField], AllField.size[iField]); CHKERRQ(ierr); ierr = PetscPrintf(PETSC_COMM_WORLD, "Total system size\t: %d\n", AllField.n_elem); CHKERRQ(ierr); #if !defined(PETSC_USE_COMPLEX) AllField.n_elem *= 2; MyField.n_elem *= 2; ierr = PetscPrintf(PETSC_COMM_WORLD, "PETSc REAL arithmetic -> system size is doubled: n=%d\n", AllField.n_elem); CHKERRQ(ierr); #endif /*------------------------- Creating the vector/matrix -----------------------*/ //Petsc Vec of unknown ierr = VecCreate(ILSComm, &X);CHKERRQ(ierr); ierr = VecSetSizes(X, MyField.n_elem, AllField.n_elem);CHKERRQ(ierr); ierr = VecSetFromOptions(X);CHKERRQ(ierr); //Petsc Vec Right Hand Side ierr = VecDuplicate(X,&B);CHKERRQ(ierr); STD_vector_to_PETSc_Vec(B_std, B, &MyField); //context of the shell matrix ierr = CreateILSMat(&ctx); CHKERRQ(ierr); ierr = SetILSMat(&ctx, LinearSystemType, &MyField, &AllField, Resolution_P, Operation_P, DofData_P0, GeoData_P0); CHKERRQ(ierr); //Shell matrix containg the indices of the unknown field (on which the iterative solver works) ierr = MatCreateShell(ILSComm, MyField.n_elem, MyField.n_elem, AllField.n_elem, AllField.n_elem, ctx, &A); CHKERRQ(ierr); ierr = MatShellSetContext(A, ctx); CHKERRQ(ierr); ierr = MatShellSetOperation(A, MATOP_MULT, (void(*)(void))MatMultILSMat); CHKERRQ(ierr); ierr = PetscBarrier((PetscObject)PETSC_NULL); CHKERRQ(ierr); /*-------------------------------------------- Creation of the iterative solver + solving --------------------------------------------*/ /*Jacobi Method (hand-made)*/ if(!strcmp(ksp_choice,"print")){ ierr = PetscPrintf(PETSC_COMM_WORLD, "Launching Print mode (no resolution):\n");CHKERRQ(ierr); // Print ITERATION MATRIX Mat IterationMatrix; ierr = PetscPrintf(PETSC_COMM_WORLD, "Print mode: computing Iteration Matrix...");CHKERRQ(ierr); ierr = BuildIterationMatrix(A, &IterationMatrix);CHKERRQ(ierr); ierr = PetscPrintf(PETSC_COMM_WORLD, "done\nPrint mode: printing Iteration Matrix...");CHKERRQ(ierr); ierr = PrintMatrix(IterationMatrix, "file_mat_itmat.m", "IterationMatrix");CHKERRQ(ierr); ierr = PetscPrintf(PETSC_COMM_WORLD, "done\nPrint mode: printing Right Hand Side...");CHKERRQ(ierr); ierr = PrintVec(B, "file_vec_rhs.m", "RightHandSide");CHKERRQ(ierr); ierr = PetscPrintf(PETSC_COMM_WORLD, "done\n");CHKERRQ(ierr); #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) ierr = VecDestroy(&X);CHKERRQ(ierr); ierr = VecDestroy(&B);CHKERRQ(ierr); ierr = MatDestroy(&A);CHKERRQ(ierr); #else ierr = VecDestroy(X);CHKERRQ(ierr); ierr = VecDestroy(B);CHKERRQ(ierr); ierr = MatDestroy(A);CHKERRQ(ierr); #endif PetscFunctionReturn(0); }else if(!strcmp(ksp_choice,"jacobi")) ierr = Jacobi_Solver(A, X, B, Tol, MaxIter); else{//KRYLOV SUBSPACE SOLVER ierr = KSPCreate(ILSComm,&ksp);CHKERRQ(ierr); ierr = KSPSetOperators(ksp,A,A,DIFFERENT_NONZERO_PATTERN);CHKERRQ(ierr); //tol etc. ierr = KSPSetTolerances(ksp, Tol, PETSC_DEFAULT, PETSC_DEFAULT, MaxIter); CHKERRQ(ierr); //Preconditioning ierr = KSPGetPC(ksp,&pc);CHKERRQ(ierr); if(!strcmp(ksp_choice,"dgmres_ddm")){ // Special Deflated GMRES for the DDM (creation of a deflated vector space before the first iteration) ksp_choice = "gmres"; Mat M; //deflation preconditioner int nb_deflation = List_Nbr(Operation_P->Case.IterativeLinearSolver.DeflationIndices); nb_deflation /= AllField.nb_field; // number of effective vectors if(nb_deflation >0){ ierr = PetscPrintf(PETSC_COMM_WORLD, "DGMRES for DDM: adding %d vectors to the deflation...\n", nb_deflation); CHKERRQ(ierr); ierr = DgmresDDM_Build(A, AllField.nb_field, nb_deflation, &M); CHKERRQ(ierr); ierr = PCSetType(pc,PCMAT);CHKERRQ(ierr); ierr = PCSetOperators(pc, A, M, SAME_PRECONDITIONER);CHKERRQ(ierr); #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) ierr = KSPSetPCSide(ksp, PC_RIGHT);CHKERRQ(ierr); #else ierr = KSPSetPreconditionerSide(ksp, PC_RIGHT); CHKERRQ(ierr); #endif } }else{ //PETSc Krylov solver //check if a preconditioner is specified int nb_pc = List_Nbr(Operation_P->Case.IterativeLinearSolver.Operations_Mx); if(nb_pc == 0) {ierr = PCSetType(pc,PCNONE);CHKERRQ(ierr);} else{ printf("Right Preconditioner detected\n"); //context of the shell PC ierr = CreateILSMat(&ctx_pc); CHKERRQ(ierr); ierr = SetILSMat(&ctx_pc, LinearSystemType, &MyField, &AllField, Resolution_P, Operation_P, DofData_P0, GeoData_P0); CHKERRQ(ierr); //Shell PC ierr = PCSetType(pc,PCSHELL);CHKERRQ(ierr); ierr = PCShellSetContext(pc, ctx_pc); CHKERRQ(ierr); ierr = PCShellSetApply(pc, MatMultPC); CHKERRQ(ierr); #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) ierr = KSPSetPCSide(ksp, PC_RIGHT);CHKERRQ(ierr); #else ierr = KSPSetPreconditionerSide(ksp, PC_RIGHT); CHKERRQ(ierr); #endif } } ierr = KSPSetType(ksp, ksp_choice); CHKERRQ(ierr); if(Restart>0 && (!strcmp(ksp_choice,"gmres") || !strcmp(ksp_choice,"dgmres") || !strcmp(ksp_choice,"lgmres") ||!strcmp(ksp_choice,"fgmres") )) ierr = KSPGMRESSetRestart(ksp, Restart); CHKERRQ(ierr); //set ksp ierr = KSPSetFromOptions(ksp);CHKERRQ(ierr); //Solve ierr = KSPSolve(ksp,B,X);CHKERRQ(ierr); ierr = KSPView(ksp,PETSC_VIEWER_STDOUT_WORLD);CHKERRQ(ierr); #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) ierr = KSPDestroy(&ksp);CHKERRQ(ierr); //if(nb_pc > 0) // ierr = PCDestroy(&pc); CHKERRQ(ierr); #else ierr = KSPDestroy(ksp);CHKERRQ(ierr); // if(nb_pc > 0) //ierr = PCDestroy(pc); CHKERRQ(ierr); #endif } /*---------------------- computing solution ----------------------*/ //we reuse B_std to avoid the creation of a new std::vector ... ierr = PETSc_Vec_to_STD_Vec(X, &MyField, &B_std); CHKERRQ(ierr); //update views for (int cpt_view = 0 ; cpt_view < MyField.nb_field; cpt_view++){ PView *view = PView::getViewByTag(MyField.GmshTag[cpt_view]); view->getData()->fromVector(B_std[cpt_view]); } // Transfer PView #ifdef TIMER double tbcast_start = MPI_Wtime(); #endif PViewBCast(MyField, AllField); #ifdef TIMER double tbcast_end = MPI_Wtime(); double t_bcast = tbcast_end - tbcast_start; printf("Process %d: tbcast = %g\n", mpi_comm_rank, t_bcast); #endif /*------------- cleaning -------------*/ #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) ierr = VecDestroy(&X);CHKERRQ(ierr); ierr = VecDestroy(&B);CHKERRQ(ierr); ierr = MatDestroy(&A);CHKERRQ(ierr); #else ierr = VecDestroy(X);CHKERRQ(ierr); ierr = VecDestroy(B);CHKERRQ(ierr); ierr = MatDestroy(A);CHKERRQ(ierr); #endif #ifdef TIMER // time_total = difftime(clock(), time_start)/CLOCKS_PER_SEC; time_total = MPI_Wtime() - time_start; #endif //CPU Times double aver_it = 0, aver_com = 0; char filename[50]; FILE *fid; sprintf(filename, "log_cpu_%d", mpi_comm_rank); fid = FOpen(filename, "w"); fprintf(fid, "Process rank %d\n", mpi_comm_rank); fprintf(fid, "it. CPU Total \t ... Treatment \t ... Communication\n"); for (unsigned int i = 0; i < MyField.TimeBcast.size() ; i ++){ fprintf(fid, "%d \t%g\t %g\t %g\t (%g%%)\n", i+1, MyField.TimeIt[i], MyField.TimeTreatment[i], MyField.TimeBcast[i], MyField.TimeBcast[i]/MyField.TimeIt[i]*100); aver_com += MyField.TimeBcast[i]/MyField.TimeBcast.size(); aver_it += MyField.TimeIt[i]/MyField.TimeIt.size(); } fprintf(fid, "Average: %g %g\n", aver_it, aver_com); fprintf(fid, "Percent of communication in average: %g%%\n", aver_com/aver_it*100); fclose(fid); #ifdef TIMER printf("Processus %d : ended in %g. \n", mpi_comm_rank, time_total); printf("Processus %d : Average iteration time %g with %g for communication (%g%%). \n", mpi_comm_rank, aver_it, aver_com, aver_com/aver_it*100); #endif PetscBarrier((PetscObject)PETSC_NULL);CHKERRQ(ierr); PetscFunctionReturn(0); } ////////////////////////////// PetscErrorCode InitData(Field *MyField, Field *AllField, struct Operation *Operation_P, std::vector > > *B_std) { int mpi_comm_size = Message::GetCommSize(); int mpi_comm_rank = Message::GetCommRank(); std::vector tab_nb_field_loc; std::vector displs(mpi_comm_size); int counter = 0; //number of fields owned by me and the other tasks MyField->nb_field = List_Nbr(Operation_P->Case.IterativeLinearSolver.MyFieldTag); tab_nb_field_loc.resize(mpi_comm_size); MPI_Allgather(&MyField->nb_field, 1, MPI_INT, &tab_nb_field_loc[0], 1, MPI_INT, PETSC_COMM_WORLD); AllField->nb_field = 0; for (int irank = 0 ; irank < mpi_comm_size ; irank ++) AllField->nb_field += tab_nb_field_loc[irank]; //displacement vector (for MPI_AllGatherV) displs[0] = 0; for (int irank = 1 ; irank < mpi_comm_size ; irank ++) displs[irank] = tab_nb_field_loc[irank-1] + displs[irank-1]; // Tag of the fields owned by me .... MyField->GmshTag.resize(MyField->nb_field); MyField->ILSTag.resize(MyField->nb_field); MyField->rank.resize(MyField->nb_field); for(int iField = 0; iField < MyField->nb_field; iField++) { double d; List_Read(Operation_P->Case.IterativeLinearSolver.MyFieldTag, iField, &d); MyField->GmshTag[iField] = (int)d; MyField->rank[iField] = mpi_comm_rank; MyField->ILSTag[iField] = displs[mpi_comm_rank] + iField; } //...and by the other tasks AllField->GmshTag.resize(AllField->nb_field); AllField->rank.resize(AllField->nb_field); AllField->ILSTag.resize(AllField->nb_field); for (int iField = 0; iField < AllField->nb_field ; iField ++) AllField->ILSTag[iField] = iField; MPI_Allgatherv(&MyField->GmshTag[0], MyField->nb_field, MPI_INT, &AllField->GmshTag[0], &tab_nb_field_loc[0], &displs[0], MPI_INT, PETSC_COMM_WORLD); MPI_Allgatherv(&MyField->rank[0], MyField->nb_field, MPI_INT, &AllField->rank[0], &tab_nb_field_loc[0], &displs[0], MPI_INT, PETSC_COMM_WORLD); // Now the (local) fields in RAM must be read (*B_std).resize(MyField->nb_field); MyField->n_elem = 0; MyField->size.resize(MyField->nb_field); for(int iField = 0; iField < MyField->nb_field; iField ++) { (*B_std)[iField].resize(2); int d; PView *view = PView::getViewByTag(MyField->GmshTag[iField]); view->getData()->toVector((*B_std)[iField]); d = (*B_std)[iField][0].size(); MyField->size[iField] = d; MyField->n_elem += d; } //Share information on the size of the local fields with other tasks MPI_Allreduce(&MyField->n_elem, &AllField->n_elem, 1, MPI_INT, MPI_SUM, PETSC_COMM_WORLD); AllField->size.resize(AllField->nb_field); MPI_Allgatherv(&MyField->size[0], MyField->nb_field, MPI_INT, &AllField->size[0], &tab_nb_field_loc[0], &displs[0], MPI_INT, PETSC_COMM_WORLD); //Compute the starting/ending index in the futur Petsc Vec containing all the Gmsh fields AllField->iStart.resize(AllField->nb_field); AllField->iEnd.resize(AllField->nb_field); MyField->iStart.resize(MyField->nb_field); MyField->iEnd.resize(MyField->nb_field); AllField->iStart[0] = 0; counter = 0; for(int j = 0; j < AllField->nb_field; j ++) { if(j > 0) AllField->iStart[j] = AllField->iEnd[j-1] + 1; AllField->iEnd[j] = AllField->iStart[j] + AllField->size[j] - 1; //Store in MyField if I am in charge of the Field if(AllField->rank[j] == mpi_comm_rank) { MyField->iStart[counter] = AllField->iStart[j]; MyField->iEnd[counter] = AllField->iEnd[j]; counter++; } } //Who are my Neighbor for the Broadcast ? // At the time of writing, GetDP does not manage 2D-List. Thus, to act as-if, the list of neighbors is composed as follows: // NeighborFieldTag = {n_0, ... n_0 GmshTag ... , n_1, ... n_1 GmshTag, ...} // example, if // MyFieldTag = {0, 3} // NeighborFieldTag = {2, 5, 1, 3, 2, 4, 6} // This mean that current process is in charge of Field with GmshTag 0 and 7. // Field of GmshTag 0 has 2 neighbors : fields of GmshTag 5 and 1 // Field of GmshTag 7 has 3 neighbors : fields of GmshTag 2, 4 and 6 //(if GetDP changes and accept list of list, then this trick should be useless and changed !) int nNeighbor_aux = 0; //, nNeighbor; nNeighbor_aux = List_Nbr(Operation_P->Case.IterativeLinearSolver.NeighborFieldTag); //make every process agreed on whether there is neighbor or not if(mpi_comm_size < 2) Field::areNeighbor=false; // AllField->comm.resize(0); // No Neighbor were provided -> PVIEWBcast on every process else{ //suppose it's true Field::areNeighbor=true; //share info on neighbor int bool_neigh = (nNeighbor_aux > 0); std::vector tab_bool_neigh(mpi_comm_size); MPI_Allgather(&bool_neigh, 1, MPI_INT, &tab_bool_neigh[0], 1, MPI_INT, MPI_COMM_WORLD); for(int irank = 0; irank < mpi_comm_size ; irank ++) if(tab_bool_neigh[irank] == 0 && AllField->GetGmshTagFromRank(irank) >= 0) //if one process has no neighbord AND is charge of some fields (=is a worker) Field::areNeighbor=false; } if(Field::areNeighbor){ int cpt_neigh = 0; //counter in list IterativeLinearSolver.NeighborFieldTag //for every field, RankToSend contain the rank of the process in need of the field MyField->RankToSend.resize(MyField->nb_field); int cpt_send = 0; //over-sizing FieldToReceive, which contains the field that are needed by this mpi process MyField->FieldToReceive.resize(AllField->nb_field - MyField->nb_field); int cpt_recv = 0; //read through every neighbors for(int ifield = 0 ; ifield < MyField->nb_field ; ifield ++) { double d; List_Read(Operation_P->Case.IterativeLinearSolver.NeighborFieldTag, cpt_neigh, &d); int n_neigh = (int)d; cpt_send = 0; //at maximum n_neigh process to send this view MyField->RankToSend[ifield].resize(n_neigh); for(int j = 0; j < n_neigh ; j ++) { //counter in list NeighborFieldTag cpt_neigh ++; List_Read(Operation_P->Case.IterativeLinearSolver.NeighborFieldTag, cpt_neigh, &d); int GmshTag_newneigh = (int)d; //Check if not already stored (either because this process is in charge of the field or due to a doublon) bool isStored = false; for(int i = 0; i < MyField->nb_field ; i++) {if(GmshTag_newneigh == MyField->GmshTag[i]) { isStored = true; break; } } for(int i = 0; i < cpt_recv ; i++) {if(GmshTag_newneigh == MyField->FieldToReceive[i]) { isStored = true; break; } } // in case it's not already store if(!isStored) { MyField->FieldToReceive[cpt_recv] = GmshTag_newneigh; cpt_recv++; } //check if stored in the table of Mpi processes which will receive this field isStored = false; int rank_new_neigh = AllField->rank[AllField->GetILSTagFromGmshTag(GmshTag_newneigh)]; MyField->RankToSend[ifield].resize(n_neigh); //Maybe this process is in charge of this field.. if(rank_new_neigh == mpi_comm_rank) isStored = true; else{//...or maybe it is already stored ... for(int i = 0; i < cpt_send ; i++) { if(rank_new_neigh == MyField->RankToSend[ifield][i]) { isStored = true; break; } } } if(!isStored) // not already stored { MyField->RankToSend[ifield][cpt_send] = rank_new_neigh; cpt_send++; } } //resize MyField->RankToSend[ifield].resize(cpt_send); cpt_neigh++; } //resize MyField->FieldToReceive.resize(cpt_recv); MyField->nb_field_to_receive = cpt_recv; //Check and exchange information on the size of the PView //Exchange information on the size of the PView (Field) with the neighbors MyField->myN.resize(MyField->nb_field); MyField->mySizeV.resize(MyField->nb_field); std::vector< MPI_Request > tab_request(0); for (int mfield = 0 ; mfield < MyField->nb_field ; mfield ++) { //Measure the size of the vectors of Field of local number mfield int GmshTag = MyField->GmshTag[mfield]; PView *view = PView::getViewByTag(GmshTag); std::vector< std::vector* > V(24); MyField->myN[mfield].resize(24); MyField->mySizeV[mfield].resize(24); view->getData()->getListPointers(&(MyField->myN[mfield][0]), &V[0]); for(int j = 0 ; j < 24 ; j++) MyField->mySizeV[mfield][j] = (*(V[j])).size(); //Exchange information about the sizes (mySizeV and myN) int n_proc_to_send = MyField->RankToSend[mfield].size(); for(int j = 0 ; j < n_proc_to_send ; j++) { MPI_Request sendN, sendSizeV; int tagN = 10*GmshTag + 1; int tagSizeV = 10*GmshTag + 2; //send vector myN and mysizeV MPI_Isend(&(MyField->myN[mfield][0]), 24, MPI_INT, MyField->RankToSend[mfield][j], tagN, MPI_COMM_WORLD, &sendN); MPI_Isend(&(MyField->mySizeV[mfield][0]), 24, MPI_INT, MyField->RankToSend[mfield][j], tagSizeV, MPI_COMM_WORLD, &sendSizeV); tab_request.push_back(sendN); tab_request.push_back(sendSizeV); } } //Receive information from the other process MyField->theirN.resize(MyField->nb_field_to_receive); MyField->theirSizeV.resize(MyField->nb_field_to_receive); for (int ifield = 0 ; ifield < MyField->nb_field_to_receive ; ifield ++) { MPI_Request recvN, recvSizeV; //receive information on vectors N and sizeV from the other int fieldGmshTag = MyField->FieldToReceive[ifield]; int fieldILSTag = AllField->GetILSTagFromGmshTag(fieldGmshTag); int rank_emiter = AllField->rank[fieldILSTag]; int tagN = 10*fieldGmshTag + 1; int tagSizeV = 10*fieldGmshTag + 2; //resize before receiving MyField->theirN[ifield].resize(24); MyField->theirSizeV[ifield].resize(24); //Receive MPI_Irecv(&(MyField->theirN[ifield][0]), 24, MPI_INT, rank_emiter, tagN, MPI_COMM_WORLD, &recvN); MPI_Irecv(&(MyField->theirSizeV[ifield][0]), 24, MPI_INT, rank_emiter, tagSizeV, MPI_COMM_WORLD, &recvSizeV); tab_request.push_back(recvN); tab_request.push_back(recvSizeV); } //check if reception is ok std::vector< MPI_Status > tab_status; MPI_Waitall(tab_request.size(), &tab_request[0], &tab_status[0]); } PetscFunctionReturn(0); } /*-----PViewBCast-------- BCast of all PView -----------------------*/ PetscErrorCode PViewBCast(Field MyField, Field AllField) { //TRANSFER PVIEW if(!(Field::areNeighbor)) { for (int iField = 0 ; iField < AllField.nb_field ; iField ++) { int GmshTag = AllField.GmshTag[iField]; int fieldRank = AllField.rank[iField]; std::vector< std::vector* > V(24); std::vector sizeV(24); std::vector N(24); int masterRank = fieldRank; MPI_Comm fieldcomm = MPI_COMM_WORLD; int mpi_fieldcomm_rank = Message::GetCommRank(); if(mpi_fieldcomm_rank == fieldRank) { PView *view = PView::getViewByTag(GmshTag); view->getData()->getListPointers(&N[0], &V[0]); for(int j = 0 ; j < 24 ; j++) sizeV[j] = (*(V[j])).size(); } //Transfer PView MPI_Bcast(&N[0], 24, MPI_INT, masterRank, fieldcomm); MPI_Bcast(&sizeV[0], 24, MPI_INT, masterRank, fieldcomm); for(int j = 0; j < 24 ; j ++) { if(mpi_fieldcomm_rank != masterRank) { V[j] = new std::vector; (*(V[j])).resize(sizeV[j]); } if(sizeV[j] > 0) //avoid useless BCast MPI_Bcast(&(*(V[j]))[0], sizeV[j], MPI_DOUBLE, masterRank, fieldcomm); } //All other tasks of the communicator create/update the views if(mpi_fieldcomm_rank != masterRank) { PView *view = new PView(GmshTag); view->getData()->importLists(&N[0], &V[0]); for(int j = 0 ; j < 24 ; j++) delete V[j] ; } } } //With a specification on the neighbors //Asynchrone Send/Recv (only with the neighbors) else{ std::vector< MPI_Request > tab_request(0); //send my PView to my neighbors for (int ifield = 0 ; ifield < MyField.nb_field ; ifield ++) { int GmshTag = MyField.GmshTag[ifield]; PView *view = PView::getViewByTag(GmshTag); std::vector< std::vector* > V_send(24); std::vector N(24); view->getData()->getListPointers(&N[0], &V_send[0]); for (int j = 0 ; j < 24 ; j ++) { int tag = 100*GmshTag + j; int n_data = MyField.mySizeV[ifield][j]; if(n_data > 0) { //Loop on the receiver for (unsigned int ineigh = 0 ; ineigh < MyField.RankToSend[ifield].size() ; ineigh ++) { MPI_Request sendV; int receiver = MyField.RankToSend[ifield][ineigh]; MPI_Isend(&(*(V_send[j]))[0], n_data, MPI_DOUBLE, receiver, tag, MPI_COMM_WORLD, &sendV); tab_request.push_back(sendV); } } } } //receive all the PView I need std::vector< std::vector< std::vector* > > V_recv(MyField.nb_field_to_receive); for (int ifield = 0 ; ifield < MyField.nb_field_to_receive ; ifield ++) { int GmshTag = MyField.FieldToReceive[ifield]; int sender = AllField.GetRankFromGmshTag(GmshTag); /* PView *view = new PView(GmshTag); std::vector< std::vector* > V_recv(24); std::vector< std::vector* > VV(24); //used to initialize PView*/ V_recv[ifield].resize(24); std::vector N(24); //allocate memory for (int j = 0 ; j < 24 ; j ++) { /* VV[j] = new std::vector; (*(VV[j])).resize(MyField.theirSizeV[ifield][j]);*/ V_recv[ifield][j] = new std::vector; (*(V_recv[ifield][j])).resize(MyField.theirSizeV[ifield][j]); } /* //Allocate memory in PView (could be better ... ?) view->getData()->importLists(&MyField.theirN[ifield][0], &VV[0]); for (int j = 0 ; j < 24 ; j ++) delete VV[j]; view->getData()->getListPointers(&N[0], &V_recv[0]);*/ for (int j = 0 ; j < 24 ; j ++) { int n_data = MyField.theirSizeV[ifield][j]; if(n_data > 0) { MPI_Request recvV; int tag = 100*GmshTag + j; // MPI_Irecv(&(*(V_recv[j]))[0], n_data, MPI_DOUBLE, sender, tag, MPI_COMM_WORLD, &recvV); MPI_Irecv(&(*(V_recv[ifield][j]))[0], n_data, MPI_DOUBLE, sender, tag, MPI_COMM_WORLD, &recvV); tab_request.push_back(recvV); } } } //check if reception is ok std::vector< MPI_Status > tab_status(tab_request.size()); MPI_Waitall(tab_request.size(), &tab_request[0], &tab_status[0]); for (int ifield = 0 ; ifield < MyField.nb_field_to_receive ; ifield ++) { int GmshTag = MyField.FieldToReceive[ifield]; PView *view = new PView(GmshTag); view->getData()->importLists(&MyField.theirN[ifield][0], &V_recv[ifield][0]); } } PetscFunctionReturn(0); } /*-------- MatMultILSMat ------ User Matrix-vector product --------------------------------*/ PetscErrorCode MatMultILSMat(Mat A, Vec X, Vec Y) { PetscErrorCode ierr; std::vector > > std_vec; Field MyField, AllField; ILSMat *ctx; char *LinearSystemType; #ifdef TIMER double tBcast_start, tBcast_end; double tTreatment_start, tTreatment_end; double t_start = MPI_Wtime(), t_end; #endif ierr = MatShellGetContext(A, (void**)&ctx);CHKERRQ(ierr); LinearSystemType = ctx->LinearSystemType; //convert X to a std vector ierr = PETSc_Vec_to_STD_Vec(X, ctx->MyField, &std_vec);CHKERRQ(ierr); // Update PViews for (int cpt_view = 0; cpt_view < ctx->MyField->nb_field; cpt_view++){ PView *view = PView::getViewByTag(ctx->MyField->GmshTag[cpt_view]); view->getData()->fromVector(std_vec[cpt_view]); } //PVIEW BCAST ! #ifdef TIMER tBcast_start = MPI_Wtime(); #endif PViewBCast(*(ctx->MyField), *(ctx->AllField)); #ifdef TIMER tBcast_end = MPI_Wtime(); #endif //Getdp resolution (contained in the matrix context) //Barrier to ensure that every process have the good data in RAM #ifdef TIMER tTreatment_start = MPI_Wtime(); #endif Treatment_Operation(ctx->Resolution_P, ctx->Operation_P->Case.IterativeLinearSolver.Operations_Ax, ctx->DofData_P0, ctx->GeoData_P0, NULL, NULL); #ifdef TIMER tTreatment_end = MPI_Wtime(); #endif //Extract the (std) vector from the (new) .pos files //This assumes that every process reads every .pos files for(int cpt_view = 0; cpt_view < ctx->MyField->nb_field; cpt_view++) { PView *view = PView::getViewByTag(ctx->MyField->GmshTag[cpt_view]); view->getData()->toVector(std_vec[cpt_view]); } //Convert the obtained vector to a Petsc Vec ierr = STD_vector_to_PETSc_Vec(std_vec, Y, ctx->MyField);CHKERRQ(ierr); //Set Y = X - Y if(!strcmp(LinearSystemType,"I-A")){ ierr = VecAYPX(Y, -1.,X); CHKERRQ(ierr); }else if(!strcmp(LinearSystemType,"I+A")){ ierr = VecAYPX(Y, 1.,X); CHKERRQ(ierr); } #ifdef TIMER //time computation t_end = MPI_Wtime(); double t_MatMult, t_Bcast, t_Treatment; t_MatMult = t_end - t_start; t_Bcast = tBcast_end - tBcast_start; t_Treatment = tTreatment_end - tTreatment_start; ctx->MyField->TimeTreatment.push_back(t_Treatment); ctx->MyField->TimeBcast.push_back(t_Bcast); ctx->MyField->TimeIt.push_back(t_MatMult); printf("Processus %d ended iteration in %g seconds with %g for communication\n", Message::GetCommRank(), t_MatMult, t_Bcast); #endif ierr = PetscBarrier((PetscObject)PETSC_NULL);CHKERRQ(ierr); PetscFunctionReturn(0); } /* ----- STD_vector_to_PETSc_Vec ---- Copy a STD Vector (std_vec) to a PETSc VEc (petsc_vec) In fact, copy the local part only of the PETSc Vec */ PetscErrorCode STD_vector_to_PETSc_Vec(std::vector > > std_vec, Vec petsc_vec, Field *Local) { PetscInt cpt = 0, nb_view = Local->nb_field; PetscErrorCode ierr; for (int cpt_view = 0; cpt_view < nb_view; cpt_view++){ std::vector val; int nb_element = Local->size[cpt_view]; std::vector ix(nb_element); for (int i = 0 ; i < nb_element ; i++){ ix[i] = Local->iStart[cpt_view] + i; #if defined(PETSC_USE_COMPLEX) val.resize(nb_element); val[i] = std_vec[cpt_view][0][i] + PETSC_i*std_vec[cpt_view][1][i]; #else val.resize(2*nb_element); val[2*i] = std_vec[cpt_view][0][i]; val[2*i+1] = std_vec[cpt_view][1][i]; #endif } #if defined(PETSC_USE_COMPLEX) ierr = VecSetValues(petsc_vec, nb_element, &ix[0], &val[0], INSERT_VALUES); #else ierr = VecSetValues(petsc_vec, 2*nb_element, &ix[0], &val[0], INSERT_VALUES); #endif cpt += nb_element; } ierr = VecAssemblyBegin(petsc_vec);CHKERRQ(ierr); ierr = VecAssemblyEnd(petsc_vec);CHKERRQ(ierr); PetscBarrier((PetscObject)petsc_vec); PetscFunctionReturn(0); } /* ----- PETSc_Vec_to_STD_Vec ---- Copy Petsc Vec to a std::vector Send ONLY THE LOCAL Part of the PETSC VEC !! */ PetscErrorCode PETSc_Vec_to_STD_Vec(Vec petsc_vec, Field *Local, std::vector > > *std_vec) { PetscErrorCode ierr; PetscScalar val; int nb_view = Local->nb_field; //initializing std_vec (*std_vec).resize(Local->nb_field); for (int cpt_view = 0 ; cpt_view < nb_view ; cpt_view++){ int nb_elem = Local->size[cpt_view]; (*std_vec)[cpt_view].resize(2); (*std_vec)[cpt_view][0].resize(nb_elem); (*std_vec)[cpt_view][1].resize(nb_elem); } for (int cpt_view = 0 ; cpt_view < nb_view ; cpt_view++){ int nb_element = Local->size[cpt_view]; int iStart = Local->iStart[cpt_view]; for (int j = 0 ; j < nb_element ; j++) { int cpt = iStart + j; #if defined(PETSC_USE_COMPLEX) ierr = VecGetValues(petsc_vec, 1, &cpt, &val); CHKERRQ(ierr); (*std_vec)[cpt_view][0][j] = (double)PetscRealPart(val); (*std_vec)[cpt_view][1][j] = (double)PetscImaginaryPart(val); #else ierr = VecGetValues(petsc_vec, 1, &cpt, &val); CHKERRQ(ierr); (*std_vec)[cpt_view][0][j] = (double)(val); ierr = VecGetValues(petsc_vec, 1, &cpt, &val);CHKERRQ(ierr); (*std_vec)[cpt_view][1][j] = (double)(val); #endif } } PetscFunctionReturn(0); } /* ----- CreateILSMat ---- Initialize the MatShell Matrix Preallocate the memory */ PetscErrorCode CreateILSMat(ILSMat **shell) { ILSMat *newctx; std::vector vec_indice, vec_size; PetscErrorCode ierr; ierr = PetscNew(ILSMat,&newctx);CHKERRQ(ierr); newctx->MyField = NULL; newctx->AllField = NULL; newctx->LinearSystemType = NULL; newctx->Resolution_P = NULL; newctx->Operation_P = NULL; newctx->DofData_P0 = NULL; newctx->GeoData_P0 = NULL; *shell = newctx; PetscFunctionReturn(0); } /* ----- SetILSMat ---- Set data to the shell matrix contex */ PetscErrorCode SetILSMat(ILSMat **shell, char *LinearSystemType, Field *MyField, Field *AllField, struct Resolution *Resolution_P, struct Operation *Operation_P, struct DofData *DofData_P0, struct GeoData *GeoData_P0) { // PetscErrorCode ierr; (*shell)->LinearSystemType = LinearSystemType; (*shell)->MyField = MyField; (*shell)->AllField = AllField; (*shell)->Resolution_P = Resolution_P; (*shell)->Operation_P = Operation_P; (*shell)->DofData_P0 = DofData_P0; (*shell)->GeoData_P0 = GeoData_P0; PetscFunctionReturn(0); } /* ----- JACOBI METHOD ----- */ PetscErrorCode Jacobi_Solver(Mat A, Vec X, Vec B, double Tol, int MaxIter) { PetscErrorCode ierr; Vec X_old, W; double residu; ierr = VecSet(X, 0.); ierr = VecDuplicate(X, &X_old);CHKERRQ(ierr); ierr = VecDuplicate(X, &W);CHKERRQ(ierr); ierr = VecCopy(X, W); for (int j=1; j < MaxIter; j++){ ierr = VecCopy(X, X_old); ierr = MatMultILSMat(A, X_old, X); ierr = VecAYPX(X, 1.,B); // X = X + B //convergence test ierr = VecWAXPY(W, -1.,X_old, X); //W = X-X_old ierr = VecNorm(W, NORM_2, &residu); printf("jacobi iteration %d residu %g\n", j, residu); if(residu < Tol){ break; } } PetscFunctionReturn(0); } // ------------------------ // PRECONDITIONING matrix-free // ------------------------ // Matrix-vector product for the preconditioning. Quite a copy/past of MatMultILSMat PetscErrorCode MatMultPC(PC pc, Vec X, Vec Y) { PetscErrorCode ierr; std::vector > > std_vec; Field MyField, AllField; ILSMat *ctx; ierr = PCShellGetContext(pc, (void**)&ctx);CHKERRQ(ierr); //convert X to a std vector ierr = PETSc_Vec_to_STD_Vec(X, ctx->MyField, &std_vec);CHKERRQ(ierr); // Update PViews for (int cpt_view = 0; cpt_view < ctx->MyField->nb_field; cpt_view++){ PView *view = PView::getViewByTag(ctx->MyField->GmshTag[cpt_view]); view->getData()->fromVector(std_vec[cpt_view]); } //PVIEW BCAST ! PViewBCast(*(ctx->MyField), *(ctx->AllField)); //Getdp resolution (contained in the matrix context) Treatment_Operation(ctx->Resolution_P, ctx->Operation_P->Case.IterativeLinearSolver.Operations_Mx, //PRECONDITIONER ! ctx->DofData_P0, ctx->GeoData_P0, NULL, NULL); //Extract the (std) vector from the (new) .pos files //This assumes that every process reads every .pos files for(int cpt_view = 0; cpt_view < ctx->MyField->nb_field; cpt_view++) { PView *view = PView::getViewByTag(ctx->MyField->GmshTag[cpt_view]); view->getData()->toVector(std_vec[cpt_view]); } //Convert the obtained vector to a Petsc Vec ierr = STD_vector_to_PETSc_Vec(std_vec, Y, ctx->MyField);CHKERRQ(ierr); ierr = PetscBarrier((PetscObject)PETSC_NULL);CHKERRQ(ierr); PetscFunctionReturn(0); } /*----- Orthonormalizer (modified gram-schmidt algormith) -------- ----Used to orthonormalize initial deflated data (with DGMRES)----*/ PetscErrorCode Orthonormalizer(std::vector X, int SizeX) { PetscErrorCode ierr; PetscScalar alpha; PetscReal modul; /* modified Gram-Schmidt */ // normalize first vector ierr = VecNormalize(X[0], &modul); for (int j = 1; j > > *vector_field, std::vector *tagFields_loc, std::vector *sizes_field, int *n) { int loc_size; (*vector_field).resize(nb_field); (*sizes_field).resize(nb_field); (*tagFields_loc).resize(nb_field); *n = 0; for(int cpt_view = 0; cpt_view < nb_field; cpt_view++) { double d; if(nth_vect == 0){ //we are creating the vector from the first argument of IterativeLinearSolver List_Read(Operation_P->Case.IterativeLinearSolver.MyFieldTag, cpt_view, &d); } else{ //Here is the (nth_vect+1) vector from the last argument of IterativeLinearSolver (deflation !) int shift = (nth_vect-1)*nb_field; // one vector contains nb_field views List_Read(Operation_P->Case.IterativeLinearSolver.DeflationIndices, shift + cpt_view, &d); } (*tagFields_loc)[cpt_view] = (int)d; // PView *view = PView::list[(int)d]; PView *view = PView::getViewByTag((int)d); view->getData()->toVector((*vector_field)[cpt_view]); loc_size = (int)(*vector_field)[cpt_view][0].size(); (*sizes_field)[cpt_view] = loc_size; // how many components ? *n += loc_size; } PetscFunctionReturn(0); } PetscErrorCode DgmresDDM_Build(Mat A, int nb_field, int nb_deflation, Mat *M) { //Right Preconditionner for "Deflated GMRES" with pre-given vectors. This is used for, e.g., DDM //We follow the paper Burrage, Kevin and Erhel, Jocelyne //On the performance of various adaptive preconditioned {GMRES} strategies //Numer. Linear Algebra Appl., 1998 PetscErrorCode ierr; PetscInt m, n; ILSMat *ctx; ierr = MatShellGetContext(A, (void**)&ctx);CHKERRQ(ierr); ierr = MatGetSize(A, &m, &n); int n_aux = 0; std::vector ix(n); for(PetscInt i = 0; i DeflationVec(nb_deflation); Mat U, Ut, AU; //Matrix U, its transpose and A*U Mat UtAU; //Ut*A*U Mat invUtAU; //inverte of UtAU Mat Id_def; //identity matrix (size nb_deflation) and inverste of UtAU Mat Id_defUt; //Id_def*Ut Mat UId_defUt; //U*Id_defUt // ierr = MatCreate(PETSC_COMM_WORLD, &U);CHKERRQ(ierr); // ierr = MatSetSizes(U, PETSC_DECIDE, PETSC_DECIDE, n, nb_deflation);CHKERRQ(ierr); // ierr = MatSetFromOptions(U);CHKERRQ(ierr); ierr = MatCreateSeqDense(PETSC_COMM_SELF, n, nb_deflation, PETSC_NULL, &U); CHKERRQ(ierr); //next two variables are useless but necessary to run ReadFields std::vector indices_deflation, sizes_deflation; for(int cpt_deflation = 0; cpt_deflation < nb_deflation; cpt_deflation ++){ std::vector > > new_field; ierr = ReadFields(nb_field, cpt_deflation+1, (ctx->Operation_P), &new_field, &indices_deflation, &sizes_deflation, &n_aux);CHKERRQ(ierr); //create a Vec from the std::vec ierr = VecCreateSeq(PETSC_COMM_SELF, n, &DeflationVec[cpt_deflation]);CHKERRQ(ierr); // ierr = VecCreate(PETSC_COMM_WORLD, &DeflationVec[cpt_deflation]);CHKERRQ(ierr); // ierr = VecSetSizes(DeflationVec[cpt_deflation], PETSC_DECIDE, n);CHKERRQ(ierr); // ierr = VecSetFromOptions(DeflationVec[cpt_deflation]);CHKERRQ(ierr); // COMMENTED BELOW BUT TO BE CHANGED !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! // ierr = STD_vector_to_PETSc_Vec(new_field, DeflationVec[cpt_deflation]);CHKERRQ(ierr); } ierr = Orthonormalizer(DeflationVec, nb_deflation); CHKERRQ(ierr); //Stocking into matrix U for(int cpt_deflation = 0; cpt_deflation < nb_deflation; cpt_deflation ++){ std::vector vec_temp(n); ierr = VecGetValues(DeflationVec[cpt_deflation], n, &ix[0], &vec_temp[0]);CHKERRQ(ierr); ierr = MatSetValues(U, n, &ix[0], 1, &cpt_deflation, &vec_temp[0], INSERT_VALUES);CHKERRQ(ierr); } ierr = MatAssemblyBegin(U, MAT_FINAL_ASSEMBLY);CHKERRQ(ierr); ierr = MatAssemblyEnd(U, MAT_FINAL_ASSEMBLY);CHKERRQ(ierr); //transpose U ierr = MatHermitianTranspose(U, MAT_INITIAL_MATRIX, &Ut);CHKERRQ(ierr); //Now compute AU ierr = MatCreateSeqDense(PETSC_COMM_SELF, n, nb_deflation, PETSC_NULL , &AU); CHKERRQ(ierr); // ierr = MatCreate(PETSC_COMM_WORLD, &AU);CHKERRQ(ierr); // ierr = MatSetSizes(AU, PETSC_DECIDE, PETSC_DECIDE, n, nb_deflation);CHKERRQ(ierr); // ierr = MatSetFromOptions(AU); for (int cpt_deflation =0; cpt_deflation vec_temp(n); ierr = VecDuplicate(DeflationVec[0],&Y);CHKERRQ(ierr); MatMultILSMat(A, DeflationVec[cpt_deflation], Y); //plug Y into matrix AU ierr = VecGetValues(Y, n, &ix[0], &vec_temp[0]);CHKERRQ(ierr); ierr = MatSetValues(AU, n, &ix[0], 1, &cpt_deflation, &vec_temp[0], INSERT_VALUES);CHKERRQ(ierr); } ierr = MatAssemblyBegin(AU, MAT_FINAL_ASSEMBLY);CHKERRQ(ierr); ierr = MatAssemblyEnd(AU, MAT_FINAL_ASSEMBLY);CHKERRQ(ierr); //Multiply Ut and AU ierr = MatMatMult(Ut, AU, MAT_INITIAL_MATRIX, PETSC_DEFAULT, &UtAU);CHKERRQ(ierr); //invert UtAU (= T) ierr = MatDuplicate(UtAU, MAT_DO_NOT_COPY_VALUES, &Id_def);CHKERRQ(ierr); PetscScalar one = 1.; for(int cpt =0; cpt = 2))) ierr = MatDestroy(&U);CHKERRQ(ierr); ierr = MatDestroy(&Ut);CHKERRQ(ierr); ierr = MatDestroy(&AU);CHKERRQ(ierr); ierr = MatDestroy(&UtAU);CHKERRQ(ierr); ierr = MatDestroy(&invUtAU);CHKERRQ(ierr); ierr = MatDestroy(&Id_def);CHKERRQ(ierr); ierr = MatDestroy(&UId_defUt);CHKERRQ(ierr); #else ierr = MatDestroy(U);CHKERRQ(ierr); ierr = MatDestroy(Ut);CHKERRQ(ierr); ierr = MatDestroy(AU);CHKERRQ(ierr); ierr = MatDestroy(UtAU);CHKERRQ(ierr); ierr = MatDestroy(invUtAU);CHKERRQ(ierr); ierr = MatDestroy(Id_def);CHKERRQ(ierr); ierr = MatDestroy(UId_defUt);CHKERRQ(ierr); #endif PetscFunctionReturn(0); } //Build the iteration matrix of the Matrix-free vector-product. //Used to, e.g., study eigenvalues of the operators PetscErrorCode BuildIterationMatrix(Mat A, Mat *IterationMatrix) { const PetscScalar one = 1., zero = 0.; PetscErrorCode ierr; PetscInt n_proc, m,n, m_loc, n_loc; PetscInt m_start, m_end, vec_m_start, vec_m_end; ierr = MPI_Comm_size(PETSC_COMM_WORLD, &n_proc); CHKERRQ(ierr); ierr = MatGetSize(A, &m, &n); ierr = MatCreate(PETSC_COMM_WORLD, IterationMatrix);CHKERRQ(ierr); ierr = MatSetSizes((*IterationMatrix), PETSC_DECIDE, PETSC_DECIDE, m, n);CHKERRQ(ierr); ierr = MatSetType((*IterationMatrix), MATMPIAIJ);CHKERRQ(ierr); ierr = MatSetFromOptions((*IterationMatrix));CHKERRQ(ierr); // ierr = MatMPIAIJSetPreallocation((*IterationMatrix), n/n_proc+1, PETSC_NULL, n-n/n_proc+1, PETSC_NULL);CHKERRQ(ierr); ierr = MatSetUp((*IterationMatrix)); ierr = MatGetOwnershipRange((*IterationMatrix), &m_start, &m_end); CHKERRQ(ierr); ierr = MatGetLocalSize((*IterationMatrix), &m_loc, &n_loc); CHKERRQ(ierr); ierr = MatMPIAIJSetPreallocation((*IterationMatrix), m_loc, PETSC_NULL, n-m_loc, PETSC_NULL);CHKERRQ(ierr); std::vector ix(m); for(PetscInt i = 0; i vec_temp(n); VecSet(ej, zero);CHKERRQ(ierr); if(cpt >= vec_m_start && cpt= 2))) ierr = PetscViewerDestroy(&viewer);CHKERRQ(ierr); #else ierr = PetscViewerDestroy(viewer);CHKERRQ(ierr); #endif } else{ ierr = PetscPrintf(PETSC_COMM_WORLD, "Warning: Matrix is too large, no ASCII Output (m=%d>%d)\n", m,m_max); CHKERRQ(ierr); } //BINARY //Add the petscfolder/bin/matlab path to your matlab paths and //type the following command in matlab, for real arithmetic : // A = PetscBinaryRead(filename) ; // and for complex arithmetic : // A = PetscBinaryRead(filename , 'complex', true) ; PetscViewer viewer_bin; ierr = PetscViewerBinaryOpen(PETSC_COMM_WORLD, (tmp + ".bin").c_str(), FILE_MODE_WRITE, &viewer_bin);CHKERRQ(ierr); ierr = PetscViewerSetFormat(viewer_bin, PETSC_VIEWER_DEFAULT);CHKERRQ(ierr); ierr = MatView(A, viewer_bin);CHKERRQ(ierr); #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) ierr = PetscViewerDestroy(&viewer_bin);CHKERRQ(ierr); #else ierr = PetscViewerDestroy(viewer_bin);CHKERRQ(ierr); #endif PetscFunctionReturn(0); } //Print a Petsc Vec into a Matlab File // TO BE CHANGED !!!!!!!!!!!!! PetscErrorCode PrintVec(Vec b, const char* filename, const char* varname) { //This function is copy/paste of function LinAlg_PrintMatrix function // located in Legacy/LinAlg_PETSC.cpp PetscErrorCode ierr; #if (PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR == 4) const char *type = ""; #else const VecType type; #endif ierr = VecGetType(b, &type);CHKERRQ(ierr); if(!strcmp(type, "seq")){ // AND NUM_PROC > 1 !!!!! ierr = PrintVecSeq(b, filename, varname);CHKERRQ(ierr); PetscFunctionReturn(0); } PetscViewer viewer, viewer_bin; std::string tmp(filename); ierr = PetscObjectSetName((PetscObject)b, varname);CHKERRQ(ierr); // ASCII ierr = PetscViewerASCIIOpen(PETSC_COMM_WORLD, filename, &viewer);CHKERRQ(ierr); ierr = PetscViewerSetFormat(viewer, PETSC_VIEWER_ASCII_MATLAB);CHKERRQ(ierr); //see PrintMat function for the how-to use it ierr = PetscViewerBinaryOpen(PETSC_COMM_WORLD, (tmp + ".bin").c_str(), FILE_MODE_WRITE, &viewer_bin);CHKERRQ(ierr); ierr = PetscViewerSetFormat(viewer_bin, PETSC_VIEWER_DEFAULT);CHKERRQ(ierr); VecView(b,viewer); VecView(b,viewer_bin); #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) ierr = PetscViewerDestroy(&viewer);CHKERRQ(ierr); ierr = PetscViewerDestroy(&viewer_bin);CHKERRQ(ierr); #else ierr = PetscViewerDestroy(viewer);CHKERRQ(ierr); ierr = PetscViewerDestroy(viewer_bin);CHKERRQ(ierr); #endif PetscFunctionReturn(0); } //Print a SEQUENTIAL Petsc Vec into a Matlab File PetscErrorCode PrintVecSeq(Vec b, const char* filename, const char* varname){ PetscErrorCode ierr; std::string tmp(filename); PetscViewer viewer, viewer_bin; ierr = PetscObjectSetName((PetscObject)b, varname);CHKERRQ(ierr); ierr = PetscViewerASCIIOpen(PETSC_COMM_SELF, filename, &viewer);CHKERRQ(ierr); ierr = PetscViewerSetFormat(viewer, PETSC_VIEWER_ASCII_MATLAB);CHKERRQ(ierr); //see PrintMat function for the how-to use it ierr = PetscViewerBinaryOpen(PETSC_COMM_SELF, (tmp + ".bin").c_str(), FILE_MODE_WRITE, &viewer_bin);CHKERRQ(ierr); ierr = PetscViewerSetFormat(viewer_bin, PETSC_VIEWER_DEFAULT);CHKERRQ(ierr); VecView(b,viewer); VecView(b,viewer_bin); #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) ierr = PetscViewerDestroy(&viewer);CHKERRQ(ierr); ierr = PetscViewerDestroy(&viewer_bin);CHKERRQ(ierr); #else ierr = PetscViewerDestroy(viewer);CHKERRQ(ierr); ierr = PetscViewerDestroy(viewer_bin);CHKERRQ(ierr); #endif PetscFunctionReturn(0); } #else int Operation_IterativeLinearSolver(struct Resolution *Resolution_P, struct Operation *Operation_P, struct DofData *DofData_P0, struct GeoData *GeoData_P0) { Message::Error("IterativeLinearSolver requires PETSc and Gmsh"); return 0; } #endif getdp-2.4.2-source/Legacy/EigenSolve_ARPACK.cpp000644 001750 001750 00000065224 12166744450 022613 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Alexandru Mustatea // Andre Nicolet // #include "GetDPConfig.h" #if defined(HAVE_ARPACK) #include #include #include "Message.h" #include "ProData.h" #include "DofData.h" #include "MallocUtils.h" #include "OS.h" #define SQU(a) ((a)*(a)) #define TWO_PI 6.2831853071795865 extern struct CurrentData Current ; extern char *Name_Path ; struct EigenPar { double prec; int size; int reortho; } ; #if defined(HAVE_NO_UNDERSCORE) #define znaupd_ znaupd #define zneupd_ zneupd #endif extern "C" { typedef struct {double re; double im;} complex_16; extern void znaupd_(int *ido, char *bmat, int *n, char *which, int *nev, double *tol, complex_16 resid[], int *ncv, complex_16 v[], int *ldv, int iparam[], int ipntr[], complex_16 workd[], complex_16 workl[], int *lworkl, double rwork[], int *info); extern void zneupd_(unsigned int *rvec, char *howmny, unsigned int select[], complex_16 d[], complex_16 z[], int *ldz, complex_16 *sigma, complex_16 workev[], char *bmat, int *n, char *which, int *nev, double *tol, complex_16 resid[], int *ncv, complex_16 v[], int *ldv, int iparam[], int ipntr[], complex_16 workd[], complex_16 workl[], int *lworkl, double rwork[], int *info); } static void EigenGetDouble(const char *text, double *d) { char str[256]; printf("%s (default=%.16g): ", text, *d); fgets(str, sizeof(str), stdin); if(strlen(str) && strcmp(str, "\n")) *d = atof(str); } static void EigenGetInt(const char *text, int *i) { char str[256]; printf("%s (default=%d): ", text, *i); fgets(str, sizeof(str), stdin); if(strlen(str) && strcmp(str, "\n")) *i = atoi(str); } void EigenPar(const char *filename, struct EigenPar *par) { char path[1024]; FILE *fp; /* set some defaults */ par->prec = 1.e-4; par->reortho = 0; par->size = 50; /* try to read parameters from file */ strcpy(path, Name_Path); strcat(path, filename); fp = FOpen(path, "r"); if(fp) { Message::Info("Loading eigenproblem parameter file '%s'", path); fscanf(fp, "%lf", &par->prec); fscanf(fp, "%d", &par->reortho); fscanf(fp, "%d", &par->size); fclose(fp); } else{ fp = FOpen(path, "w"); if(fp){ /* get parameters from command line */ EigenGetDouble("Precision", &par->prec); EigenGetInt("Reorthogonalization", &par->reortho); EigenGetInt("Krylov basis size", &par->size); /* write file */ fprintf(fp, "%.16g\n", par->prec); fprintf(fp, "%d\n", par->reortho); fprintf(fp, "%d\n", par->size); fprintf(fp, "/*\n" " The numbers above are the parameters for the numerical\n" " eigenvalue problem:\n" "\n" " prec = aimed accuracy for eigenvectors (default=1.e-4)\n" " reortho = reorthogonalisation of Krylov basis: yes=1, no=0 (default=0) \n" " size = size of the Krylov basis\n" "\n" " The shift is given in the .pro file because its choice relies\n" " on physical considerations.\n" "*/"); fclose(fp); } else{ Message::Error("Unable to open file '%s'", path); } } Message::Info("Eigenproblem parameters: prec = %g, reortho = %d, size = %d", par->prec, par->reortho, par->size); } /* This routine uses Arpack to solve Generalized Complex Non-Hermitian eigenvalue problems. We don't use the "Generalized" Arpack mode (bmat=='G') since it requires M to be Hermitian. Instead, we use the regular mode (bmat='I') and apply the shift "by hand", which allows us to use arbitrary matrices K and M. */ static void Arpack2GetDP(int N, complex_16 *in, gVector *out) { int i, j; double re, im; for(i = 0; i < N; i++){ re = in[i].re; im = in[i].im; j = i * gCOMPLEX_INCREMENT; LinAlg_SetComplexInVector(re, im, out, j, j+1); } LinAlg_AssembleVector(out); } static void Arpack2GetDPSplit(int N, complex_16 *in, gVector *out1, gVector *out2) { int i, j; double re, im; for(i = 0; i < N/2; i++){ j = i * gCOMPLEX_INCREMENT; re = in[i].re; im = in[i].im; LinAlg_SetComplexInVector(re, im, out1, j, j+1); re = in[N/2+i].re; im = in[N/2+i].im; LinAlg_SetComplexInVector(re, im, out2, j, j+1); } LinAlg_AssembleVector(out1); LinAlg_AssembleVector(out2); } static void GetDP2Arpack(gVector *in, complex_16 *out) { int i, N; double re, im; LinAlg_GetVectorSize(in, &N); for(i = 0; i < N; i += gCOMPLEX_INCREMENT){ LinAlg_GetComplexInVector(&re, &im, in, i, i+1); out[i/gCOMPLEX_INCREMENT].re = re; out[i/gCOMPLEX_INCREMENT].im = im; } } static void GetDP2ArpackMerge(gVector *in1, gVector *in2, complex_16 *out) { int i, N; double re, im; LinAlg_GetVectorSize(in1, &N); for(i = 0; i < N; i += gCOMPLEX_INCREMENT){ LinAlg_GetComplexInVector(&re, &im, in1, i, i+1); out[i/gCOMPLEX_INCREMENT].re = re; out[i/gCOMPLEX_INCREMENT].im = im; LinAlg_GetComplexInVector(&re, &im, in2, i, i+1); out[N/gCOMPLEX_INCREMENT + i/gCOMPLEX_INCREMENT].re = re; out[N/gCOMPLEX_INCREMENT + i/gCOMPLEX_INCREMENT].im = im; } } void EigenSolve_ARPACK(struct DofData * DofData_P, int NumEigenvalues, double shift_r, double shift_i) { struct EigenPar eigenpar; struct Solution Solution_S; gVector v1, v2, w1, w2, x, y; int n, j, k, l, newsol, quad_evp = 0; double tmp, d1, d2, abs, arg; complex_16 f, omega, omega2; gMatrix *K = &DofData_P->M1; /* matrix associated with terms with no Dt nor DtDt */ gMatrix *L = &DofData_P->M2; /* matrix associated with Dt terms */ gMatrix *M = &DofData_P->M3; /* matrix associated with DtDt terms */ gMatrix D; /* temp matrix for quadratic eigenvalue problem */ /* Arpack parameters: see below for explanation */ int ido, nev, ncv, ldv, iparam[11], ipntr[14], lworkl, info, ldz; char bmat, *which, howmny; double tol, *rwork; unsigned int rvec, *select; complex_16 *resid, *v, *workd, *workl, *d, *z, sigma, *workev; /* Bail out if we are not in harmonic regime: it's much easier this way (since, for real, non-symmetric matrices we would get complex eigenvectors we could not easily store) */ if(Current.NbrHar != 2){ Message::Error("EigenSolve requires system defined with \"Type Complex\""); return; } /* Sanity checks */ if(!DofData_P->Flag_Init[1] || !DofData_P->Flag_Init[3]){ Message::Error("No System available for EigenSolve: check 'DtDt' and 'GenerateSeparate'"); return; } /* Check if we have a "quadratic" evp (- w^2 M x + i w L x + K x = 0) */ if(DofData_P->Flag_Init[2]) quad_evp = 1; /* Get eigenproblem parameters */ EigenPar("eigen.par", &eigenpar); n = DofData_P->NbrDof / gCOMPLEX_INCREMENT; /* size of the system */ if(quad_evp) n *= 2; ido = 0; /* Reverse communication flag. IDO must be zero on the first call to znaupd. IDO will be set internally to indicate the type of operation to be performed. Control is then given back to the calling routine which has the responsibility to carry out the requested operation and call znaupd with the result. The operand is given in WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). ------------------------------------------------------------- IDO = 0: first call to the reverse communication interface IDO = -1: compute Y = OP * X where IPNTR(1) is the pointer into WORKD for X, IPNTR(2) is the pointer into WORKD for Y. This is for the initialization phase to force the starting vector into the range of OP. IDO = 1: compute Y = OP * X where IPNTR(1) is the pointer into WORKD for X, IPNTR(2) is the pointer into WORKD for Y. In mode 3, the vector B * X is already available in WORKD(ipntr(3)). It does not need to be recomputed in forming OP * X. IDO = 2: compute Y = M * X where IPNTR(1) is the pointer into WORKD for X, IPNTR(2) is the pointer into WORKD for Y. IDO = 3: compute and return the shifts in the first NP locations of WORKL. IDO = 99: done ------------------------------------------------------------- After the initialization phase, when the routine is used in the "shift-and-invert" mode, the vector M * X is already available and does not need to be recomputed in forming OP*X. */ bmat = 'I'; /* BMAT specifies the type of the matrix B that defines the semi-inner product for the operator OP. BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x */ which = (char*)"LM"; /* Which eigenvalues we want: SM = smallest magnitude ( magnitude = absolute value ) LM = largest magnitude SR = smallest real part LR = largest real part SI = smallest imaginary part LI = largest imaginary part */ nev = NumEigenvalues; /* Number of eigenvalues of OP to be computed. 0 < NEV < N-1. Therefore, you'll be able to compute AT MOST n-2 eigenvalues! */ /* sanity check */ if(nev >= n-1){ Message::Warning("NumEigenvalues too large (%d < %d): setting to %d", nev, n-1, n-2); nev = n-2; } tol = eigenpar.prec; /* 1.e-4; */ /* Stopping criteria: the relative accuracy of the Ritz value is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. DEFAULT = dlamch('EPS') (machine precision as computed by the LAPACK auxiliary subroutine dlamch). */ resid = (complex_16*)Malloc(n * sizeof(complex_16)); /* On INPUT: If INFO .EQ. 0, a random initial residual vector is used. If INFO .NE. 0, RESID contains the initial residual vector, possibly from a previous run. On OUTPUT: RESID contains the final residual vector. */ ncv = eigenpar.size; /* Rule of thumb: NumEigenvalues * 2; */ /* Number of columns of the matrix V. NCV must satisfy the two inequalities 1 <= NCV-NEV and NCV <= N. This will indicate how many Arnoldi vectors are generated at each iteration. After the startup phase in which NEV Arnoldi vectors are generated, the algorithm generates approximately NCV-NEV Arnoldi vectors at each subsequent update iteration. Most of the cost in generating each Arnoldi vector is in the matrix-vector operation OP*x. */ /* sanity checks */ if(ncv <= nev){ Message::Warning("Krylov space size too small (%d <= %d), setting to %d", ncv, nev, nev*2); ncv = nev * 2; } if(ncv > n){ Message::Warning("Krylov space size too large (%d > %d), setting to %d", ncv, n, n); ncv = n; } v = (complex_16*)Malloc(n * ncv * sizeof(complex_16)); /* At the end of calculations, here will be stored the Arnoldi basis vectors */ ldv = n; /* Leading dimension of "v". In our case, the number of lines of "v". */ iparam[0] = 1; iparam[1] = 0; iparam[2] = 10000; iparam[3] = 1; iparam[4] = 0; iparam[5] = 0; iparam[6] = 1; iparam[7] = 0; iparam[8] = 0; iparam[9] = 0; iparam[10] = 0; /* IPARAM(1) = ISHIFT: method for selecting the implicit shifts. The shifts selected at each iteration are used to filter out the components of the unwanted eigenvector. ------------------------------------------------------------- ISHIFT = 0: the shifts are to be provided by the user via reverse communication. The NCV eigenvalues of the Hessenberg matrix H are returned in the part of WORKL array corresponding to RITZ. ISHIFT = 1: exact shifts with respect to the current Hessenberg matrix H. This is equivalent to restarting the iteration from the beginning after updating the starting vector with a linear combination of Ritz vectors associated with the "wanted" eigenvalues. ISHIFT = 2: other choice of internal shift to be defined. ------------------------------------------------------------- IPARAM(2) = No longer referenced IPARAM(3) = MXITER On INPUT: maximum number of Arnoldi update iterations allowed. On OUTPUT: actual number of Arnoldi update iterations taken. IPARAM(4) = NB: blocksize to be used in the recurrence. The code currently works only for NB = 1. IPARAM(5) = NCONV: number of "converged" Ritz values. This represents the number of Ritz values that satisfy the convergence criterion. IPARAM(6) = IUPD No longer referenced. Implicit restarting is ALWAYS used. IPARAM(7) = MODE On INPUT determines what type of eigenproblem is being solved. Must be 1,2,3; See under \Description of znaupd for the four modes available. IPARAM(8) = NP When ido = 3 and the user provides shifts through reverse communication (IPARAM(1)=0), _naupd returns NP, the number of shifts the user is to provide. 0 < NP < NCV-NEV. IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, OUTPUT: NUMOP = total number of OP*x operations, NUMOPB = total number of B*x operations if BMAT='G', NUMREO = total number of steps of re-orthogonalization. */ ipntr[0] = 0; /* Pointer to mark the starting locations in the WORKD and WORKL arrays for matrices/vectors used by the Arnoldi iteration. ------------------------------------------------------------- IPNTR(1): pointer to the current operand vector X in WORKD. IPNTR(2): pointer to the current result vector Y in WORKD. IPNTR(3): pointer to the vector B * X in WORKD when used in the shift-and-invert mode. IPNTR(4): pointer to the next available location in WORKL that is untouched by the program. IPNTR(5): pointer to the NCV by NCV upper Hessenberg matrix H in WORKL. IPNTR(6): pointer to the ritz value array RITZ IPNTR(7): pointer to the (projected) ritz vector array Q IPNTR(8): pointer to the error BOUNDS array in WORKL. IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. Note: IPNTR(9:13) is only referenced by zneupd. See Remark 2 below. IPNTR(9): pointer to the NCV RITZ values of the original system. IPNTR(10): Not Used IPNTR(11): pointer to the NCV corresponding error bounds. IPNTR(12): pointer to the NCV by NCV upper triangular Schur matrix for H. IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors of the upper Hessenberg matrix H. Only referenced by zneupd if RVEC = .TRUE. See Remark 2 below. */ workd = (complex_16*)Malloc(3 * n * sizeof(complex_16)); /* Distributed array to be used in the basic Arnoldi iteration for reverse communication. The user should not use WORKD as temporary workspace during the iteration !!!!!!!!!! See Data Distribution Note below. */ lworkl = 3*ncv*ncv + 5*ncv; /* Dimension of the "workl" vector (see below). On must have: lworkl >= 3*ncv*ncv + 5*ncv */ workl = (complex_16*)Malloc(lworkl * sizeof(complex_16)); /* Private (replicated) array on each PE or array allocated on the front end. See Data Distribution Note below. */ rwork = (double*)Malloc(ncv * sizeof(double)); /* Used as workspace */ info = 0; /* If INFO .EQ. 0, a randomly initial residual vector is used. If INFO .NE. 0, RESID contains the initial residual vector, possibly from a previous run. Error flag on output. = 0: Normal exit. = 1: Maximum number of iterations taken. All possible eigenvalues of OP has been found. IPARAM(5) returns the number of wanted converged Ritz values. = 2: No longer an informational error. Deprecated starting with release 2 of ARPACK. = 3: No shifts could be applied during a cycle of the Implicitly restarted Arnoldi iteration. One possibility is to increase the size of NCV relative to NEV. See remark 4 below. = -1: N must be positive. = -2: NEV must be positive. = -3: NCV-NEV >= 1 and less than or equal to N. = -4: The maximum number of Arnoldi update iteration must be greater than zero. = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' = -6: BMAT must be one of 'I' or 'G'. = -7: Length of private work array is not sufficient. = -8: Error return from LAPACK eigenvalue calculation; = -9: Starting vector is zero. = -10: IPARAM(7) must be 1,2,3. = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. = -12: IPARAM(1) must be equal to 0 or 1. = -9999: Could not build an Arnoldi factorization. User input error highly likely. Please check actual array dimensions and layout. IPARAM(5) returns the size of the current Arnoldi factorization. */ rvec = 1; /* .true. */ /* If we want Ritz vectors to be computed as well. */ howmny = 'A'; /* What do we want: Ritz or Schur vectors? For Schur, choose: howmny = 'P' */ select = (unsigned int*)Malloc(ncv * sizeof(unsigned int)); /* Internal workspace */ d = (complex_16*)Malloc(nev * sizeof(complex_16)); /* Vector containing the "nev" eigenvalues computed. VERY IMPORTANT: on line 69 of zneupd.f they say it should be nev+1; this is wrong, for see line 283 where it is declared as d(nev) */ z = (complex_16*)Malloc(n * nev * sizeof(complex_16)); /* On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of Z represents approximate eigenvectors (Ritz vectors) corresponding to the NCONV=IPARAM(5) Ritz values for eigensystem A*z = lambda*B*z. If RVEC = .FALSE. or HOWMNY = 'P', then Z is NOT REFERENCED. NOTE: If if RVEC = .TRUE. and a Schur basis is not required, the array Z may be set equal to first NEV+1 columns of the Arnoldi basis array V computed by ZNAUPD. In this case the Arnoldi basis will be destroyed and overwritten with the eigenvector basis. */ ldz = n; /* Leading dimension of "z". In our case, the number of lines of "z". */ sigma.re = 0.; sigma.im = 0.; /* The shift. Not used in this case: we deal with the shift "by hand". */ workev = (complex_16*)Malloc(2 * ncv * sizeof(complex_16)); /* Workspace */ if(bmat != 'I' || iparam[6] != 1){ Message::Error("General and/or shift-invert mode should not be used"); return; } /* Create temp vectors and matrices and apply shift. Warning: with PETSc, the shifting can be very slow if the masks are very different, for example if we are in real arithmetic and have one real matrix and one complex "simulated-real" matrix */ if(!quad_evp){ LinAlg_CreateVector(&v1, &DofData_P->Solver, DofData_P->NbrDof); LinAlg_CreateVector(&v2, &DofData_P->Solver, DofData_P->NbrDof); /* K = K - shift * M */ LinAlg_AddMatrixProdMatrixDouble(K, M, -shift_r, K) ; } else{ /* This is an explanation of our approach to a quadratic eigenvalue problem i.e. - w^2 M x + i w L x + K x = 0. This system is equivalent to (y = i w x) and (i w M y + i w L x + K x = 0), or, in matrix form: | L M | |x| |-K 0 | |x| | I 0 | |y| iw = | 0 I | |y| , or |x| |x| A |y| iw = B |y|. To apply Arpack with a shift 's' (but not in shift inverted mode to avoid the Hermitian constraint!), we build the following operator: (B- sA)^-1 A. To do this, the following computation is performed: (x,y) is transformed to (Solve(D,Lx+sMx+My),Solve(D,-Kx+sMy)) where Solve(D,v) means the solution of the Dx=v linear system and where D=-(s^2M+sL+K). Note that if the number of degrees of freedom is N, the matrix computations are still performed on NxN matrices but the Arpack vector is of size n=2*N. Only the x part of the (x,y) eigenvectors are retained as physical solutions. */ LinAlg_CreateVector(&x, &DofData_P->Solver, DofData_P->NbrDof); LinAlg_CreateVector(&y, &DofData_P->Solver, DofData_P->NbrDof); LinAlg_CreateVector(&v1, &DofData_P->Solver, DofData_P->NbrDof); LinAlg_CreateVector(&w1, &DofData_P->Solver, DofData_P->NbrDof); LinAlg_CreateVector(&w2, &DofData_P->Solver, DofData_P->NbrDof); LinAlg_CreateMatrix(&D, &DofData_P->Solver, DofData_P->NbrDof, DofData_P->NbrDof); /* D = -(shift^2 * M + shift * L + K) */ LinAlg_CopyMatrix(M, &D); LinAlg_AddMatrixProdMatrixDouble(L, &D, shift_r, &D); LinAlg_AddMatrixProdMatrixDouble(K, &D, shift_r, &D); LinAlg_ProdMatrixDouble(&D, -1., &D); } /* Keep calling znaupd again and again until ido == 99 */ k = 0; do { znaupd_(&ido, &bmat, &n, which, &nev, &tol, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, rwork, &info); if(ido == 1 || ido == -1){ Message::Info("Arpack iteration %d", k+1); if(!quad_evp){ Arpack2GetDP(n, &workd[ipntr[0]-1], &v1); LinAlg_ProdMatrixVector(M, &v1, &v2); if(!k) LinAlg_Solve(K, &v2, &DofData_P->Solver, &v1); else LinAlg_SolveAgain(K, &v2, &DofData_P->Solver, &v1); GetDP2Arpack(&v1, &workd[ipntr[1]-1]); } else{ Arpack2GetDPSplit(n, &workd[ipntr[0]-1], &x, &y); LinAlg_ProdMatrixVector(M, &y, &w2); LinAlg_ProdMatrixVector(L, &x, &v1); LinAlg_AddVectorVector(&v1, &w2, &v1); LinAlg_ProdMatrixVector(M, &x, &w1); LinAlg_AddVectorProdVectorDouble(&v1, &w1, shift_r, &v1); if(!k) LinAlg_Solve(&D, &v1, &DofData_P->Solver, &w1); else LinAlg_SolveAgain(&D, &v1, &DofData_P->Solver, &w1); LinAlg_ProdMatrixVector(K, &x, &v1); LinAlg_ProdVectorDouble(&v1, -1., &v1); LinAlg_AddVectorProdVectorDouble(&v1, &w2, shift_r, &v1); LinAlg_SolveAgain(&D, &v1, &DofData_P->Solver, &w2); GetDP2ArpackMerge(&w1, &w2, &workd[ipntr[1]-1]); } k++; } else if(ido == 99){ /* We're done! */ break; } else{ Message::Info("Arpack code = %d (ignored)", info); } } while (1); Message::Info("Arpack required %d iterations", k); /* Testing for errors */ if(info == 0){ /* OK */ } else if(info == 1){ Message::Warning("Maxmimum number of iteration reached in EigenSolve"); } else if(info == 2){ Message::Warning("No shifts could be applied during a cycle of the"); Message::Warning("Implicitly restarted Arnoldi iteration. One possibility"); Message::Warning("is to increase the size of NCV relative to NEV."); } else if(info < 0){ Message::Error("Arpack code = %d", info); } else{ Message::Warning("Arpack code = %d (unknown)", info); } /* Call to zneupd for post-processing */ zneupd_(&rvec, &howmny, select, d, z, &ldz, &sigma, workev, &bmat, &n, which, &nev, &tol, resid, &ncv, v, &ldv, iparam, ipntr, workd, workl, &lworkl, rwork, &info); /* Test for errors */ if(info != 0) Message::Error("Arpack code = %d (eigenvector post-processing)", info); /* Compute the unshifted eigenvalues and print them, and store the associated eigenvectors */ newsol = 0; for (k = 0; k < nev; k++){ /* Unshift the eigenvalues */ tmp = SQU(d[k].re) + SQU(d[k].im); d[k].re = shift_r + d[k].re/tmp; d[k].im = shift_i - d[k].im/tmp; if(!quad_evp){ /* Eigenvalue = omega^2 */ omega2.re = d[k].re; omega2.im = d[k].im; abs = sqrt(SQU(omega2.re) + SQU(omega2.im)); arg = atan2(omega2.im, omega2.re); omega.re = sqrt(abs) * cos(0.5*arg); omega.im = sqrt(abs) * sin(0.5*arg); f.re = omega.re / TWO_PI; f.im = omega.im / TWO_PI; } else{ /* Eigenvalue = i*omega */ omega.re = d[k].im; omega.im = -d[k].re; omega2.re = SQU(omega.re) - SQU(omega.im); omega2.im = 2. * omega.re * omega.im; f.re = omega.re / TWO_PI; f.im = omega.im / TWO_PI; } Message::Info("Eigenvalue %03d: w^2 = %.12e %s %.12e * i", k+1, omega2.re, (omega2.im > 0) ? "+" : "-", (omega2.im > 0) ? omega2.im : -omega2.im); Message::Info(" w = %.12e %s %.12e * i", omega.re, (omega.im > 0) ? "+" : "-", (omega.im > 0) ? omega.im : -omega.im); Message::Info(" f = %.12e %s %.12e * i", f.re, (f.im > 0) ? "+" : "-", (f.im > 0) ? f.im : -f.im); if(newsol) { /* Create new solution */ Solution_S.TimeFunctionValues = NULL; LinAlg_CreateVector(&Solution_S.x, &DofData_P->Solver, DofData_P->NbrDof); List_Add(DofData_P->Solutions, &Solution_S); DofData_P->CurrentSolution = (struct Solution*) List_Pointer(DofData_P->Solutions, List_Nbr(DofData_P->Solutions)-1); } newsol = 1; DofData_P->CurrentSolution->Time = omega.re; DofData_P->CurrentSolution->TimeImag = omega.im; DofData_P->CurrentSolution->TimeStep = (int)Current.TimeStep; Free(DofData_P->CurrentSolution->TimeFunctionValues); DofData_P->CurrentSolution->TimeFunctionValues = NULL; DofData_P->CurrentSolution->SolutionExist = 1; for(l = 0; l < DofData_P->NbrDof; l+=gCOMPLEX_INCREMENT){ j = l / gCOMPLEX_INCREMENT; LinAlg_SetComplexInVector(z[k*n+j].re, z[k*n+j].im, &DofData_P->CurrentSolution->x, l, l+1); } LinAlg_AssembleVector(&DofData_P->CurrentSolution->x); /* Arpack returns eigenvectors normalized in L-2 norm. Renormalize them in L-infty norm so that the absolute value of the largest element is 1 */ tmp = 0.; for(l = 0; l < DofData_P->NbrDof; l+=gCOMPLEX_INCREMENT){ LinAlg_GetComplexInVector(&d1, &d2, &DofData_P->CurrentSolution->x, l, l+1); abs = sqrt(SQU(d1) + SQU(d2)); if(abs > tmp) tmp = abs; } if(tmp > 1.e-16) LinAlg_ProdVectorDouble(&DofData_P->CurrentSolution->x, 1./tmp, &DofData_P->CurrentSolution->x); /* Increment the global timestep counter so that a future GenerateSystem knows which solutions exist */ Current.TimeStep += 1.; /* Update the current value of Time and TimeImag so that $EigenvalueReal and $EigenvalueImag are up-to-date */ Current.Time = omega.re; Current.TimeImag = omega.im; } /* Deallocate */ if(!quad_evp){ LinAlg_DestroyVector(&v1); LinAlg_DestroyVector(&v2); } else{ LinAlg_DestroyVector(&x); LinAlg_DestroyVector(&y); LinAlg_DestroyVector(&v1); LinAlg_DestroyVector(&w1); LinAlg_DestroyVector(&w2); LinAlg_DestroyMatrix(&D); } Free(resid); Free(v); Free(workd); Free(workl); Free(rwork); Free(select); Free(d); Free(z); Free(workev); } #endif getdp-2.4.2-source/Legacy/LinAlg.cpp000644 001750 001750 00000014477 12116424202 020665 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "GetDPConfig.h" #include "LinAlg.h" #include "Message.h" // default dummy solver interface #if !defined(HAVE_PETSC) && !defined(HAVE_SPARSKIT) #define err Message::Error("No solver is compiled in this version of GetDP") void LinAlg_InitializeSolver(int* argc, char*** argv){} void LinAlg_FinalizeSolver(){} void LinAlg_SetCommSelf(){} void LinAlg_SetCommWorld(){} void LinAlg_CreateSolver(gSolver *Solver, const char * SolverDataFileName){ err; } void LinAlg_CreateVector(gVector *V, gSolver *Solver, int n){ err; } void LinAlg_CreateMatrix(gMatrix *M, gSolver *Solver, int n, int m){ err; } void LinAlg_DestroySolver(gSolver *Solver){ err; } void LinAlg_DestroyVector(gVector *V){ err; } void LinAlg_DestroyMatrix(gMatrix *M){ err; } void LinAlg_CopyScalar(gScalar *S1, gScalar *S2){ err; } void LinAlg_CopyVector(gVector *V1, gVector *V2){ err; } void LinAlg_CopyMatrix(gMatrix *M1, gMatrix *M2){ err; } void LinAlg_ZeroScalar(gScalar *S){ err; } void LinAlg_ZeroVector(gVector *V){ err; } void LinAlg_ZeroMatrix(gMatrix *M){ err; } void LinAlg_ScanScalar(FILE *file, gScalar *S){ err; } void LinAlg_ScanVector(FILE *file, gVector *V){ err; } void LinAlg_ScanMatrix(FILE *file, gMatrix *M){ err; } void LinAlg_ReadScalar(FILE *file, gScalar *S){ err; } void LinAlg_ReadVector(FILE *file, gVector *V){ err; } void LinAlg_ReadMatrix(FILE *file, gMatrix *M){ err; } void LinAlg_PrintScalar(FILE *file, gScalar *S){ err; } void LinAlg_PrintVector(FILE *file, gVector *V, bool matlab, const char* fileName, const char* varName){ err; } void LinAlg_PrintMatrix(FILE *file, gMatrix *M, bool matlab, const char* fileName, const char*varName){ err; } void LinAlg_WriteScalar(FILE *file, gScalar *S){ err; } void LinAlg_WriteVector(FILE *file, gVector *V){ err; } void LinAlg_WriteMatrix(FILE *file, gMatrix *M){ err; } void LinAlg_GetVectorSize(gVector *V, int *i){ err; } void LinAlg_GetLocalVectorRange(gVector *V, int *low, int *high){ err; } void LinAlg_GetMatrixSize(gMatrix *M, int *i, int *j){ err; } void LinAlg_GetLocalMatrixRange(gMatrix *M, int *low, int *high){ err; } void LinAlg_GetDoubleInScalar(double *d, gScalar *S){ err; } void LinAlg_GetComplexInScalar(double *d1, double *d2, gScalar *S){ err; } void LinAlg_GetScalarInVector(gScalar *S, gVector *V, int i){ err; } void LinAlg_GetDoubleInVector(double *d, gVector *V, int i){ err; } void LinAlg_GetAbsDoubleInVector(double *d, gVector *V, int i){ err; } void LinAlg_GetComplexInVector(double *d1, double *d2, gVector *V, int i, int j){ err; } void LinAlg_GetScalarInMatrix(gScalar *S, gMatrix *M, int i, int j){ err; } void LinAlg_GetDoubleInMatrix(double *d, gMatrix *M, int i, int j){ err; } void LinAlg_GetComplexInMatrix(double *d1, double *d2, gMatrix *M, int i, int j, int k, int l){ err; } void LinAlg_GetColumnInMatrix(gMatrix *M, int col, gVector *V1){ err; } void LinAlg_GetMatrixContext(gMatrix *A, void **myCtx){ err; } void LinAlg_SetScalar(gScalar *S, double *d){ err; } void LinAlg_SetVector(gVector *V, double *v){ err; } void LinAlg_SetScalarInVector(gScalar *S, gVector *V, int i){ err; } void LinAlg_SetDoubleInVector(double d, gVector *V, int i){ err; } void LinAlg_SetComplexInVector(double d1, double d2, gVector *V, int i, int j){ err; } void LinAlg_SetScalarInMatrix(gScalar *S, gMatrix *M, int i, int j){ err; } void LinAlg_SetDoubleInMatrix(double d, gMatrix *M, int i, int j){ err; } void LinAlg_SetComplexInMatrix(double d1, double d2, gMatrix *M, int i, int j, int k, int l){ err; } void LinAlg_AddScalarScalar(gScalar *S1, gScalar *S2, gScalar *S3){ err; } void LinAlg_DummyVector(gVector *V){ err; } void LinAlg_AddScalarInVector(gScalar *S, gVector *V, int i){ err; } void LinAlg_AddDoubleInVector(double d, gVector *V, int i){ err; } void LinAlg_AddComplexInVector(double d1, double d2, gVector *V, int i, int j){ err; } void LinAlg_AddScalarInMatrix(gScalar *S, gMatrix *M, int i, int j){ err; } void LinAlg_AddDoubleInMatrix(double d, gMatrix *M, int i, int j){ err; } void LinAlg_AddComplexInMatrix(double d1, double d2, gMatrix *M, int i, int j, int k, int l){ err; } void LinAlg_AddVectorVector(gVector *V1, gVector *V2, gVector *V3){ err; } void LinAlg_AddVectorProdVectorDouble(gVector *V1, gVector *V2, double d, gVector *V3){ err; } void LinAlg_AddMatrixMatrix(gMatrix *M1, gMatrix *M2, gMatrix *M3){ err; } void LinAlg_AddMatrixProdMatrixDouble(gMatrix *M1, gMatrix *M2, double d, gMatrix *M3){ err; } void LinAlg_SubScalarScalar(gScalar *S1, gScalar *S2, gScalar *S3){ err; } void LinAlg_SubVectorVector(gVector *V1, gVector *V2, gVector *V3){ err; } void LinAlg_SubMatrixMatrix(gMatrix *M1, gMatrix *M2, gMatrix *M3){ err; } void LinAlg_ProdScalarScalar(gScalar *S1, gScalar *S2, gScalar *S3){ err; } void LinAlg_ProdScalarDouble(gScalar *S1, double d, gScalar *S2){ err; } void LinAlg_ProdScalarComplex(gScalar *S, double d1, double d2, double *d3, double *d4){ err; } void LinAlg_ProdVectorScalar(gVector *V1, gScalar *S, gVector *V2){ err; } void LinAlg_ProdVectorDouble(gVector *V1, double d, gVector *V2){ err; } void LinAlg_ProdVectorComplex(gVector *V1, double d1, double d2, gVector *V2){ err; } void LinAlg_ProdVectorVector(gVector *V1, gVector *V2, double *d){ err; } void LinAlg_ProdMatrixVector(gMatrix *M, gVector *V1, gVector *V2){ err; } void LinAlg_ProdMatrixScalar(gMatrix *M1, gScalar *S, gMatrix *M2){ err; } void LinAlg_ProdMatrixDouble(gMatrix *M1, double d, gMatrix *M2){ err; } void LinAlg_ProdMatrixComplex(gMatrix *M1, double d1, double d2, gMatrix *M2){ err; } void LinAlg_DivScalarScalar(gScalar *S1, gScalar *S2, gScalar *S3){ err; } void LinAlg_DivScalarDouble(gScalar *S1, double d, gScalar *S2){ err; } void LinAlg_VectorNorm2(gVector *V1, double *norm){ err; } void LinAlg_VectorNormInf(gVector *V1, double *norm){ err; } void LinAlg_AssembleMatrix(gMatrix *M){ err; } void LinAlg_AssembleVector(gVector *V){ err; } void LinAlg_Solve(gMatrix *A, gVector *B, gSolver *Solver, gVector *X, int solverIndex){ err; } void LinAlg_SolveAgain(gMatrix *A, gVector *B, gSolver *Solver, gVector *X, int solverIndex){ err; } void LinAlg_SolveNL(gMatrix *A, gVector *B, gMatrix *J, gVector *R, gSolver *Solver, gVector *X, int solverIndex){ err; } #endif getdp-2.4.2-source/Legacy/MovingBand2D.cpp000644 001750 001750 00000032653 12140252171 021726 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Johan Gyselinck // #include #include "ProData.h" #include "ExtendedGroup.h" #include "GeoData.h" #include "ListUtils.h" #include "TreeUtils.h" #include "MallocUtils.h" #include "Message.h" #define SQU(a) ((a)*(a)) extern struct CurrentData Current ; /* ------------------------------------------------------------------------ */ /* M o v i n g B a n d 2 D */ /* ------------------------------------------------------------------------ */ struct ThreeInt { int Int1, Int2, Int3 ; } ; int fcmp_int3(const void * a, const void * b) { return ((struct ThreeInt *)a)->Int1 - ((struct ThreeInt *)b)->Int1 ; } int fcmp_int32(const void * a, const void * b) { return ((struct ThreeInt *)a)->Int2 - ((struct ThreeInt *)b)->Int2 ; } void Contour_MovingBand2D(List_T * InitialList, List_T ** ExtendedList, int * NbrNodes, int ** NumNodes) { Tree_T * Element_Tr ; struct Geo_Element * GeoElement ; struct ThreeInt *ThreeInt, ThreeInt1 ; int *Nodes, LeftNode, RightNode, LeftInt, RightInt, i_El, i ; Element_Tr = Tree_Create(sizeof(struct ThreeInt), fcmp_int3) ; for (i_El = 0 ; i_El < Geo_GetNbrGeoElements() ; i_El++) { GeoElement = Geo_GetGeoElement(i_El) ; if (List_Search(InitialList, &GeoElement->Region, fcmp_int)) { if (GeoElement->Type != LINE) Message::Error("MovingBand2D contour must contain only line elements") ; ThreeInt1.Int1 = i_El; ThreeInt1.Int2 = 0; ThreeInt1.Int3 = 0; Tree_Add(Element_Tr, &ThreeInt1) ; } } *ExtendedList = Tree2List(Element_Tr) ; Tree_Delete(Element_Tr) ; ThreeInt = (struct ThreeInt *)List_Pointer(*ExtendedList, 0) ; Nodes = Geo_GetGeoElement(ThreeInt->Int1)->NumNodes ; RightNode = Nodes[1] ; RightInt = 0 ; LeftNode = Nodes[0] ; LeftInt = 0 ; ThreeInt->Int2 = 0 ; ThreeInt->Int3 = 1 ; for (i = 1 ; i < List_Nbr(*ExtendedList) ; i++) { for (i_El = 1 ; i_El < List_Nbr(*ExtendedList) ; i_El++) { if ( ((ThreeInt = (struct ThreeInt *)List_Pointer(*ExtendedList, i_El))->Int3) == 0) { Nodes = Geo_GetGeoElement(ThreeInt->Int1)->NumNodes; if (Nodes[0] == RightNode) { ThreeInt->Int2 = ++RightInt ; ThreeInt->Int3 = 1 ; RightNode = Nodes[1] ; } else if (Nodes[1] == RightNode) { ThreeInt->Int2 = ++RightInt ; ThreeInt->Int3 = -1 ; RightNode = Nodes[0] ; } else if (Nodes[0] == LeftNode) { ThreeInt->Int2 = --LeftInt ; ThreeInt->Int3 = -1 ; LeftNode = Nodes[1] ; } else if (Nodes[1] == LeftNode) { ThreeInt->Int2 = --LeftInt ; ThreeInt->Int3 = 1 ; LeftNode = Nodes[0] ; } if (ThreeInt->Int3) break; } } if (!ThreeInt->Int3) Message::Error("Moving Band contour is not connected") ; } List_Sort(*ExtendedList, fcmp_int32) ; *NbrNodes = List_Nbr(*ExtendedList)+1 ; *NumNodes = (int *)Malloc(*NbrNodes*sizeof(int)) ; ThreeInt = (struct ThreeInt *)List_Pointer(*ExtendedList, 0) ; if (ThreeInt->Int3 == 1) { (*NumNodes)[0] = (Geo_GetGeoElement(ThreeInt->Int1)->NumNodes)[0]; (*NumNodes)[1] = (Geo_GetGeoElement(ThreeInt->Int1)->NumNodes)[1]; } else { (*NumNodes)[0] = (Geo_GetGeoElement(ThreeInt->Int1)->NumNodes)[1]; (*NumNodes)[1] = (Geo_GetGeoElement(ThreeInt->Int1)->NumNodes)[0]; } for (i_El = 1 ; i_El < List_Nbr(*ExtendedList) ; i_El++) { ThreeInt = (struct ThreeInt *)List_Pointer(*ExtendedList, i_El) ; if (ThreeInt->Int3 == 1) (*NumNodes)[i_El+1] = (Geo_GetGeoElement(ThreeInt->Int1)->NumNodes)[1]; else (*NumNodes)[i_El+1] = (Geo_GetGeoElement(ThreeInt->Int1)->NumNodes)[0]; } } void Init_MovingBand2D (struct Group * Group_P) { struct MovingBand2D * MB ; int i ; int Different_Sense_MB2D(int nth1, int nth2, int ntr1, int ntr2, int closed1, int closed2, double x1[], double y1[], double x2[], double y2[]) ; MB = Group_P->MovingBand2D ; if (MB->ExtendedList1 && MB->ExtendedList2) { Message::Warning("Init_MovingBand has already been done!: Skipping") ; return ; } Contour_MovingBand2D(MB->InitialList1, &MB->ExtendedList1, &MB->NbrNodes1, &MB->NumNodes1) ; Contour_MovingBand2D(MB->InitialList2, &MB->ExtendedList2, &MB->NbrNodes2, &MB->NumNodes2) ; MB->x1 = (double *)Malloc(MB->NbrNodes1*sizeof(double)) ; MB->y1 = (double *)Malloc(MB->NbrNodes1*sizeof(double)) ; MB->z1 = (double *)Malloc(MB->NbrNodes1*sizeof(double)) ; MB->x2 = (double *)Malloc(MB->NbrNodes2*sizeof(double)) ; MB->y2 = (double *)Malloc(MB->NbrNodes2*sizeof(double)) ; MB->z2 = (double *)Malloc(MB->NbrNodes2*sizeof(double)) ; MB->Closed1 = MB->Closed2 = 0 ; if (MB->NumNodes1[0] == MB->NumNodes1[MB->NbrNodes1-1]) MB->Closed1 = 1 ; if (MB->NumNodes2[0] == MB->NumNodes2[MB->NbrNodes2-1]) MB->Closed2 = 1 ; MB->ntr1 = MB->NbrNodes1-1 ; MB->ntr2 = MB->NbrNodes2-1 ; if (MB->Period2 != 1) { if ((MB->NbrNodes2-1)%MB->Period2 != 0.) Message::Warning("Strange periodicity stuff (%d %d)! Do you know what you're doing?", MB->NbrNodes2-1, MB->Period2); MB->ntr2 = (MB->NbrNodes2-1)/MB->Period2; Message::Info("Periodicity data (%d %d %d %d)", MB->ntr1, MB->NbrNodes2-1, MB->Period2, MB->ntr2); } Geo_GetNodesCoordinates (MB->NbrNodes1, MB->NumNodes1, MB->x1, MB->y1, MB->z1) ; Geo_GetNodesCoordinates (MB->NbrNodes2, MB->NumNodes2, MB->x2, MB->y2, MB->z2) ; if (Different_Sense_MB2D(MB->NbrNodes1, MB->NbrNodes2, MB->ntr1, MB->ntr2, MB->Closed1, MB->Closed2, MB->x1, MB->y1, MB->x2, MB->y2) ) { Message::Debug("Contours have a different sense: invertinggggggggggggggggggggggggggggggggggg!"); for (i=0 ; iNbrNodes2/2 ; i++) { int dummy = MB->NumNodes2[i]; MB->NumNodes2[i] = MB->NumNodes2[MB->NbrNodes2-1-i]; MB->NumNodes2[MB->NbrNodes2-1-i] = dummy; } } Message::Debug("Moving Band Contour 1 has %d nodes :", MB->NbrNodes1); for (i=0 ; iNbrNodes1 ; i++) Message::Debug(" %d ", MB->NumNodes1[i]); if (MB->Closed1) Message::Debug(" (closed)"); else Message::Debug(" (open)"); Message::Debug("Moving Band Contour 2 has %d nodes :", MB->NbrNodes2); for (i=0 ; iNbrNodes2 ; i++) Message::Debug(" %d ", MB->NumNodes2[i]); if (MB->Closed2) Message::Debug(" (closed, "); else Message::Debug(" (open, "); Message::Debug("periodicity 1/%d, ", MB->Period2); MB->b1_p1 = (int *)Malloc((MB->NbrNodes1-1)*sizeof(int)) ; MB->b1_p2 = (int *)Malloc((MB->NbrNodes1-1)*sizeof(int)) ; MB->b1_p3 = (int *)Malloc((MB->NbrNodes1-1)*sizeof(int)) ; MB->b2_p1 = (int *)Malloc((MB->NbrNodes2-1)*sizeof(int)) ; MB->b2_p2 = (int *)Malloc((MB->NbrNodes2-1)*sizeof(int)) ; MB->b2_p3 = (int *)Malloc((MB->NbrNodes2-1)*sizeof(int)) ; MB->StartIndexTr = Geo_GetNbrGeoElements() ; MB->StartNumTr = Geo_GetGeoElement(0)->Num ; for (i=1 ; iStartIndexTr ; i++) if (MB->StartNumTr < Geo_GetGeoElement(i)->Num) MB->StartNumTr = Geo_GetGeoElement(i)->Num ; (MB->StartNumTr)++; Message::Debug("StartNumTr %d StartIndexTr %d", MB->StartNumTr, MB->StartIndexTr); } int Different_Sense_MB2D(int nth1, int nth2, int ntr1, int ntr2, int closed1, int closed2, double x1[], double y1[], double x2[], double y2[]){ double xm = (x1[0]+x1[1])/2.; double ym = (y1[0]+y1[1])/2.; int imindist = 0; double mindist2 = SQU(xm-x2[0]) + SQU(ym-y2[0]); for (int i = 1 ; i < nth2 ; i++ ){ double dist2 = SQU(xm-x2[i]) + SQU(ym-y2[i]) ; if (dist2 < mindist2) { imindist = i; mindist2 = dist2; } } int itry2 = (closed2==1) ? ((imindist+1) % (nth2-1)) : std::min(imindist+1, nth2) ; int itry4 = (closed2==1) ? ((imindist-1+nth2-1) % (nth2-1)) : std::max(imindist-1,0) ; double dist1 = SQU(x1[2]-x2[itry2]) + SQU(y1[2]-y2[itry2]); double dist2 = SQU(x1[2]-x2[itry4]) + SQU(y1[2]-y2[itry4]); return( (dist1 < dist2) ? 0. : 1.) ; } void Mesh_MB2D(int nth1, int nth2, int ntr1, int ntr2, int closed1, int closed2, double x1[], double y1[], double x2[], double y2[], double * area_moving_band, int b1_p1[], int b1_p2[], int b1_p3[], int b2_p1[], int b2_p2[], int b2_p3[]) { double area_tr1,area_tr2; int Delauny_1234_MB(double, double, double, double, double, double, double, double, double *, double * ); double xm = (x1[0]+x1[1])/2.; double ym = (y1[0]+y1[1])/2.; int imindist = 0; double mindist2 = SQU(xm-x2[0]) + SQU(ym-y2[0]); for (int i = 1 ; i < nth2 ; i++ ){ double dist2 = SQU(xm-x2[i]) + SQU(ym-y2[i]) ; if (dist2 < mindist2) { imindist = i; mindist2 = dist2; } } int itry2 = (closed2==1) ? ((imindist+1) % (nth2-1)) : std::min(imindist+1, nth2) ; int itry4 = (closed2==1) ? ((imindist-1+nth2-1) % (nth2-1)) : std::max(imindist-1,0) ; double dist1 = SQU(x1[2]-x2[itry2]) + SQU(y1[2]-y2[itry2]); double dist2 = SQU(x1[2]-x2[itry4]) + SQU(y1[2]-y2[itry4]); int d2 = (dist1 < dist2) ? 1 : -1 ; Message::Debug("+++++++++++++++++++++++++++++++++++++++++++++++++ %d \n",d2); *area_moving_band = fabs( (x2[imindist]-x1[0])*(y1[1]-y1[0])-(x1[1]-x1[0])*(y2[imindist]-y1[0]) )/2. ; int itry1 = 1 ; int itry3 = 2 ; itry2 = imindist ; itry4 = (closed2==1) ? ((imindist + d2) % (nth2-1)) : imindist + d2 ; int n1 = 0; int n2 = 0; b1_p1[n1] = 0; b1_p2[n1] = 1; b1_p3[n1] = itry2; n1++; for (int i = 1 ; i < ntr1 + ntr2 ; i++ ){ if ( (Delauny_1234_MB (x1[itry1], y1[itry1], x2[itry2], y2[itry2], x1[itry3], y1[itry3], x2[itry4], y2[itry4], &area_tr1, &area_tr2) == 1) && itry1 < nth1 && itry1 ){ b1_p1[n1] = itry1; b1_p2[n1] = itry3; b1_p3[n1] = itry2; itry1++; itry3++; if (closed1) {itry1 = itry1 % (nth1-1); itry3 = itry3 % (nth1-1) ;} *area_moving_band += area_tr1; n1++; } else{ b2_p1[n2] = itry2; b2_p2[n2] = itry4; b2_p3[n2] = itry1; itry2+=d2; itry4+=d2; if (closed2) { itry2 = (nth2-1+itry2) % (nth2-1); itry4 = (nth2-1+itry4) % (nth2-1) ; } *area_moving_band += area_tr2; n2++; } } if(n1 != ntr1 || n2 != ntr2){ Message::Error("Meshing of 2D Moving Band failed (%d != %d || %d != %d)", n1, ntr1, n2, ntr2); } } void Mesh_MovingBand2D (struct Group * Group_P) { struct MovingBand2D * MB ; struct Geo_Element Geo_Element ; struct GeoData * GeoData ; int *n ; int *NumNodes1, *NumNodes2; int *b1_p1, *b1_p2, *b1_p3, *b2_p1, *b2_p2, *b2_p3; MB = Group_P->MovingBand2D ; if (!MB->ExtendedList1 || !MB->ExtendedList2) Init_MovingBand2D(Group_P) ; NumNodes1 = MB->NumNodes1; NumNodes2 = MB->NumNodes2; b1_p1 = MB->b1_p1; b1_p2 = MB->b1_p2; b1_p3 = MB->b1_p3; b2_p1 = MB->b2_p1; b2_p2 = MB->b2_p2; b2_p3 = MB->b2_p3; Geo_GetNodesCoordinates (MB->NbrNodes1, NumNodes1, MB->x1, MB->y1, MB->z1) ; Geo_GetNodesCoordinates (MB->NbrNodes2, NumNodes2, MB->x2, MB->y2, MB->z2) ; Mesh_MB2D(MB->NbrNodes1, MB->NbrNodes2, MB->ntr1, MB->ntr2, MB->Closed1, MB->Closed2, MB->x1, MB->y1, MB->x2, MB->y2, &MB->Area, b1_p1, b1_p2, b1_p3, b2_p1, b2_p2, b2_p3); GeoData = Current.GeoData ; Geo_Element.NbrEdges = Geo_Element.NbrFacets = 0 ; Geo_Element.NumEdges = Geo_Element.NumFacets = NULL ; Geo_Element.Region = MB->PhysNum ; Geo_Element.NbrNodes = 3 ; Geo_Element.Type = TRIANGLE ; int NbrGeo = Geo_GetNbrGeoElements(); for (int i = 0 ; i < MB->ntr1 ; i++){ int index = MB->StartIndexTr+i ; if (index < NbrGeo) { n = (int *)(((struct Geo_Element *)List_Pointer(GeoData->Elements, index))->NumNodes) ; n[0] = NumNodes1[b1_p1[i]] ; n[1] = NumNodes1[b1_p2[i]] ; n[2] = NumNodes2[b1_p3[i]] ; } else { Geo_Element.Num = MB->StartNumTr + i ; Geo_Element.NumNodes = n = (int *)Malloc(3 * sizeof(int)) ; n[0] = NumNodes1[b1_p1[i]] ; n[1] = NumNodes1[b1_p2[i]] ; n[2] = NumNodes2[b1_p3[i]] ; List_Put(GeoData->Elements, index, &Geo_Element) ; } // printf("Tr1 %d : %d %d %d \n",MB->StartNumTr+i, n[0], n[1], n[2]); } for (int i = 0 ; i < MB->ntr2 ; i++){ Geo_Element.Num = MB->StartNumTr + MB->ntr1 +i ; int index = MB->StartIndexTr+MB->ntr1+i ; if (index < NbrGeo) { n = (int *)(((struct Geo_Element *)List_Pointer(GeoData->Elements, index))->NumNodes) ; n[0] = NumNodes2[b2_p1[i]] ; n[1] = NumNodes2[b2_p2[i]] ; n[2] = NumNodes1[b2_p3[i]] ; } else { Geo_Element.Num = MB->StartNumTr + MB->ntr1 + i ; Geo_Element.NumNodes = n = (int *)Malloc(3 * sizeof(int)) ; n[0] = NumNodes2[b2_p1[i]] ; n[1] = NumNodes2[b2_p2[i]] ; n[2] = NumNodes1[b2_p3[i]] ; List_Put(GeoData->Elements, index, &Geo_Element) ; } Message::Debug("Tr2 %d : %d %d %d \n",MB->StartNumTr+MB->ntr1+i, n[0], n[1], n[2]); } Message::Debug("Moving band meshed (area = %e)", MB->Area); } int Delauny_1234_MB (double x1, double y1, double x2, double y2, double x3, double y3, double x4, double y4, double * area1, double * area2) { double Det1 = (x3-x1)*(y2-y1)-(x2-x1)*(y3-y1); double Det2 = (x4-x1)*(y2-y1)-(x2-x1)*(y4-y1); if( !Det1 || !Det2 ) { Message::Error("Colinear points in Delauny_1234 (" "Det1 %g Det2 %g " "x1 %e y1 %e x2 %e y2 %e x3 %e y3 %e x4 %e y4 %e)", Det1, Det2, x1, y1, x2, y2, x3, y3, x4, y4); } double t1 = ( (x3-x1)*(x3-x2)+(y3-y1)*(y3-y2) ) / Det1 ; double t2 = ( (x4-x1)*(x4-x2)+(y4-y1)*(y4-y2) ) / Det2 ; if ( fabs(t1) < fabs(t2) ){ *area1 = fabs(Det1)/2.; return (1); } else{ *area2 = fabs(Det2)/2.; return (2); } } getdp-2.4.2-source/Legacy/Gauss_Line.cpp000644 001750 001750 00000006746 12116424202 021550 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "Gauss.h" #include "Gauss_Line.h" #include "Message.h" #include "MallocUtils.h" /* Gauss integration over a line */ static int gll[MAX_LINE_POINTS] = {-1}; static double *glxl[MAX_LINE_POINTS], *glpl[MAX_LINE_POINTS]; void Gauss_Line(int Nbr_Points, int Num, double *u, double *v, double *w, double *wght) { int i ; switch (Nbr_Points) { case 1 : *u = lx1 [Num] ; *v = 0. ; *w = 0. ; *wght = lp1 [Num] ; break ; case 2 : *u = lx2 [Num] ; *v = 0. ; *w = 0. ; *wght = lp2 [Num] ; break ; case 3 : *u = lx3 [Num] ; *v = 0. ; *w = 0. ; *wght = lp3 [Num] ; break ; case 4 : *u = lx4 [Num] ; *v = 0. ; *w = 0. ; *wght = lp4 [Num] ; break ; case 5 : *u = lx5 [Num] ; *v = 0. ; *w = 0. ; *wght = lp5 [Num] ; break ; case 6 : *u = lx6 [Num] ; *v = 0. ; *w = 0. ; *wght = lp6 [Num] ; break ; case 7 : *u = lx7 [Num] ; *v = 0. ; *w = 0. ; *wght = lp7 [Num] ; break ; case 8 : *u = lx8 [Num] ; *v = 0. ; *w = 0. ; *wght = lp8 [Num] ; break ; case 9 : *u = lx9 [Num] ; *v = 0. ; *w = 0. ; *wght = lp9 [Num] ; break ; case 10 : *u = lx10[Num] ; *v = 0. ; *w = 0. ; *wght = lp10[Num] ; break ; case 11 : *u = lx11[Num] ; *v = 0. ; *w = 0. ; *wght = lp11[Num] ; break ; case 12 : *u = lx12[Num] ; *v = 0. ; *w = 0. ; *wght = lp12[Num] ; break ; case 13 : *u = lx13[Num] ; *v = 0. ; *w = 0. ; *wght = lp13[Num] ; break ; case 14 : *u = lx14[Num] ; *v = 0. ; *w = 0. ; *wght = lp14[Num] ; break ; case 15 : *u = lx15[Num] ; *v = 0. ; *w = 0. ; *wght = lp15[Num] ; break ; case 16 : *u = lx16[Num] ; *v = 0. ; *w = 0. ; *wght = lp16[Num] ; break ; case 17 : *u = lx17[Num] ; *v = 0. ; *w = 0. ; *wght = lp17[Num] ; break ; case 18 : *u = lx18[Num] ; *v = 0. ; *w = 0. ; *wght = lp18[Num] ; break ; case 19 : *u = lx19[Num] ; *v = 0. ; *w = 0. ; *wght = lp19[Num] ; break ; case 20 : *u = lx20[Num] ; *v = 0. ; *w = 0. ; *wght = lp20[Num] ; break ; default : if(Nbr_Points <= MAX_LINE_POINTS){ if(gll[0] < 0) for(i = 0; i < MAX_LINE_POINTS; i++) gll[i] = 0 ; if(!gll[Nbr_Points - 1]){ Message::Info("Computing GaussLegendre %d for Line", Nbr_Points); glxl[Nbr_Points - 1] = (double*)Malloc(Nbr_Points * sizeof(double)); glpl[Nbr_Points - 1] = (double*)Malloc(Nbr_Points * sizeof(double)); GaussLegendre(-1., 1., glxl[Nbr_Points - 1], glpl[Nbr_Points - 1], Nbr_Points); gll[Nbr_Points - 1] = 1; } *u = glxl[Nbr_Points - 1][Num] ; *v = *w = 0. ; *wght = glpl[Nbr_Points - 1][Num] ; } else Message::Error("Maximum number of integration points exceeded (%d > %d)", Nbr_Points, MAX_LINE_POINTS) ; break ; } } #define EPS 3.0e-11 void GaussLegendre(double x1, double x2, double x[], double w[], int n) { int m, j, i; double z1, z, xm, xl, pp, p3, p2, p1; m = (n + 1) / 2; xm = 0.5 * (x2 + x1); xl = 0.5 * (x2 - x1); for (i = 1; i <= m; i++) { z = cos(3.141592654 * (i - 0.25) / (n + 0.5)); do { p1 = 1.0; p2 = 0.0; for (j = 1; j <= n; j++) { p3 = p2; p2 = p1; p1 = ((2.0 * j - 1.0) * z * p2 - (j - 1.0) * p3) / j; } pp = n * (z * p1 - p2) / (z * z - 1.0); z1 = z; z = z1 - p1 / pp; } while (fabs(z - z1) > EPS); x[i - 1] = xm - xl * z; x[n - i] = xm + xl * z; w[i - 1] = 2.0 * xl/((1.0 - z * z) * pp * pp); w[n - i] = w[i - 1]; } } getdp-2.4.2-source/Legacy/F_Raytracing.cpp000644 001750 001750 00000012774 12116424202 022065 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "GetDPConfig.h" #include "ProData.h" #include "F.h" #include "Message.h" #if !defined(HAVE_GSL) void F_CylinderPhase(F_ARG) { Message::Error("F_CylinderPhase requires the GSL"); } void F_DiamondPhase(F_ARG) { Message::Error("F_DiamondPhase requires the GSL"); } #else #include #include struct f_context { double x1, y1; }; static int f(const gsl_vector *ts, void *param, gsl_vector *f) { struct f_context * c = (struct f_context *)param; double t = gsl_vector_get(ts, 0); double s = gsl_vector_get(ts, 1); double x = c->x1; double y = c->y1; gsl_vector_set(f, 0, cos(t) - s*cos(2*t) - x); gsl_vector_set(f, 1, sin(t) - s*sin(2*t) - y); return GSL_SUCCESS; } static int df(const gsl_vector *ts, void* param, gsl_matrix *j) { double t = gsl_vector_get(ts, 0); double s = gsl_vector_get(ts, 1); double j1dt = -sin(t) + s*2*sin(2*t); double j2dt = cos(t) - 2*s*cos(2*t); double j1ds = -cos(2*t); double j2ds = -sin(2*t); gsl_matrix_set(j, 0, 0, j1dt); gsl_matrix_set(j, 1, 1, j2ds); gsl_matrix_set(j, 1, 0, j2dt); gsl_matrix_set(j, 0, 1, j1ds); return GSL_SUCCESS; } static int fdf(const gsl_vector *uv, void *param, gsl_vector *func, gsl_matrix *jac) { f(uv, param, func); df(uv, param, jac); return GSL_SUCCESS; } static int newton(gsl_multiroot_function_fdf FDF, double *u, double *v) { const int MAX_ITER = 25; const gsl_multiroot_fdfsolver_type* TYPE = gsl_multiroot_fdfsolver_gnewton; int iter = 0, status; gsl_multiroot_fdfsolver* solver = gsl_multiroot_fdfsolver_alloc(TYPE, 2); /* u, v contains initial guess */ gsl_vector *X = gsl_vector_alloc(2); gsl_vector_set(X, 0, *u); gsl_vector_set(X, 1, *v); gsl_multiroot_fdfsolver_set(solver, &FDF, X); do { iter++; status = gsl_multiroot_fdfsolver_iterate(solver); *u = gsl_vector_get(solver->x, 0); *v = gsl_vector_get(solver->x, 1); if(*v < 0 || *v > 15 || fabs(*u) > 7){ status= GSL_FAILURE; break; } status = gsl_multiroot_test_residual(solver->f, 1.e-12); } while(status == GSL_CONTINUE && iter < MAX_ITER); gsl_multiroot_fdfsolver_free(solver); gsl_vector_free(X); if(status == GSL_SUCCESS) return 1; else return 0; } void F_CylinderPhase(F_ARG) { double initGuess, tau[2], phase; double x = A->Val[0], y = A->Val[1]; struct f_context context = {x, y}; gsl_multiroot_function_fdf FDF; if(x > 0 && y < 1 && y > -1) { V->Val[0] = x; V->Type = SCALAR; return; } if(x > 0){ tau[1] = sqrt(x * x + y * y); if(y > 0){ initGuess = (atan2(y, -x) + 3.14 / 2) / 2; } else{ initGuess = (atan2(y, -x) - 3.14 / 2) / 2; } } else{ tau[1] = sqrt(x * x + y * y) - 1; initGuess = atan2(y, x); } if(fabs(x) < 1 && fabs(y) > 6.5){ if(y < 0){ initGuess = initGuess - 3.14 / 8; } else{ initGuess = initGuess + 3.14 / 8; } } tau[0] = initGuess; if(tau[1] == 0){ V->Val[0] = x; V->Type = SCALAR; return; } FDF.f = &f; FDF.df = &df; FDF.fdf = &fdf; FDF.n = 2; FDF.params = &context; if(!newton(FDF, &tau[0], &tau[1])) Message::Error("Newton did not converge: %lf, %lf \n", tau[0], tau[1]); /* now we just go on to calculate the phase from this */ phase = cos(tau[0]) + tau[1]; if(phase > abs(13)){ phase = 13; } V->Val[0] = phase; V->Type = SCALAR; } void F_DiamondPhase(F_ARG) { double x, y, phase, theta, xtrans, ytrans; x = A->Val[0]; y = A->Val[1]; /* if(x < 0 &&){ phase = -x; V-Val[0] = phase; V->Type = SCALAR; return; } */ x = -x; /* just a temp investigation */ /*partition up the space into a couple of pieces*/ if(x >= 0 && (y-.1 <= 1 && y+.1 >= -1)){ V->Val[0] = x; V->Type = SCALAR; return; } /* if( x <= 0 && (y>=-1 && y<=0) ) { phase = -y-1 + (-x+(-y-1)); V->Val[0] = phase; V->Type = SCALAR; return; } */ /*check to see if the point is in the cone made by the x-corner*/ xtrans = x + 1; ytrans = y; theta = atan2(ytrans,xtrans); if( theta >= 3.14/2 || theta <= -3.14/2){ phase = -1 + sqrt( pow(xtrans,2.0) + pow(ytrans,2.0) ); V->Val[0] = phase; V->Type = SCALAR; return; } /*check to see if the point is in the upper corner cone*/ xtrans = x; ytrans = y - 1; theta = atan2(ytrans,xtrans); if( theta <= 3.14/2 && theta >= 0 ){ phase = sqrt( pow(x,2.0) + pow(ytrans,2.0) ); V->Val[0] = phase; V->Type = SCALAR; return; } /*lower corner cone*/ xtrans = x; ytrans = y + 1; theta = atan2(ytrans,xtrans); if( theta >= -3.14/2 && theta <= 0 ){ phase = sqrt( pow(x,2.0) + pow(ytrans,2.0) ); V->Val[0] = phase; V->Type = SCALAR; return; } /*the point must be in one of the two reflections caused by the sides facing the incoming wave*/ /* xtrans = x; ytrans = y; */ if(y<0){ /* xtrans = (x+y+1)/2; ytrans = (xtrans)-1; phase = xtrans + sqrt( pow(x-xtrans,2.0) + pow(y-ytrans,2.0) ); */ phase = -x + ( -y + (x-1) ); } else{ /* xtrans = (1+x-y)/2; ytrans = xtrans-1; phase = xtrans + sqrt( pow(x-xtrans,2.0) + pow(-y-ytrans,2.0) ); */ phase = -x + ( y - (1-x) ); } V->Val[0] = phase; V->Type = SCALAR; } #endif getdp-2.4.2-source/Legacy/SolvingAnalyse.h000644 001750 001750 00000002117 12116424202 022106 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _SOLVING_ANALYSE_H_ #define _SOLVING_ANALYSE_H_ #include "ProData.h" void Init_DofDataInFunctionSpace(int Nbr_DefineSystem, struct DofData *DofData_P0); void Init_DofDataInDefineQuantity(struct DefineSystem *DefineSystem_P, struct DofData *DofData_P0, struct Formulation *Formulation_P); double * Get_TimeFunctionValues(struct DofData * DofData_P); void Init_HarInDofData(struct DefineSystem * DefineSystem_P, struct DofData * DofData_P); void Treatment_PostOperation(struct Resolution * Resolution_P, struct DofData * DofData_P0, struct DefineSystem * DefineSystem_P0, struct GeoData * GeoData_P0, struct PostProcessing * PostProcessing_P, struct PostOperation * PostOperation_P); void SolvingAnalyse(); #endif getdp-2.4.2-source/Legacy/GeoEntity.h000644 001750 001750 00000037020 12116424202 021060 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _GEO_ENTITY_H_ #define _GEO_ENTITY_H_ /* Incidence Matrices : Den (EdgesXNodes), Dfe (FacetsXEdges) */ /* Xp stands for 'expanded' (used in discrete operators) */ /* ------------------------------------------------------------------------ POINT v | | -----1-----u | | ------------------------------------------------------------------------ */ static int NbrNodes_Point = 1 ; static int NbrEdges_Point = 0 ; static int NbrFacets_Point = 0 ; static double Nodes_Point [][3] = { {0., 0., 0.} } ; /* ------------------------------------------------------------------------ LINE edge 1: nodes 1 -> 2 v | | --1-----2--u | | ------------------------------------------------------------------------ */ static int NbrNodes_Line = 2 ; static int NbrEdges_Line = 1 ; static int NbrFacets_Line = 0 ; static double Nodes_Line [][3] = { {-1., 0., 0.} , {1., 0., 0.,} } ; static int Den_Line [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, -2, 0} } ; static int Den_Line_Xp [] = { -1, 1 } ; /* ------------------------------------------------------------------------ LINE_2 edge 1: nodes 1 -> 2 v | | --1--3--2--u | | ------------------------------------------------------------------------ */ static int NbrNodes_Line_2 = 3 ; static int NbrEdges_Line_2 = 1 ; static int NbrFacets_Line_2 = 0 ; static double Nodes_Line_2 [][3] = { {-1., 0., 0.} , {1., 0., 0.,} , {0., 0., 0.,} } ; static int Den_Line_2 [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, -2, 0} } ; static int Den_Line_2_Xp [] = { -1, 1 } ; /* ------------------------------------------------------------------------ TRIANGLE edge 1: nodes 1 -> 2 v 2: 1 -> 3 | 3: 2 -> 3 | 3 facet 1: edges 1 -2 3 nodes 1 2 3 |\ | \ |__\___u 1 2 ------------------------------------------------------------------------ */ static int NbrNodes_Triangle = 3 ; static int NbrEdges_Triangle = 3 ; static int NbrFacets_Triangle = 1 ; static double Nodes_Triangle [][3] = { {0., 0., 0.} , {1., 0., 0.} , {0., 1., 0.} } ; static int Den_Triangle [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, -2, 0}, { 1, -3, 0}, { 2, -3, 0} } ; static int Den_Triangle_Xp [] = { -1, 1, 0, -1, 0, 1, 0,-1, 1 } ; static int Dfe_Triangle [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, 3, -2, 0} } ; static int Dfe_Triangle_Xp [] = { 1,-1, 1 } ; static int Dfn_Triangle [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, 2, 3, 0} } ; /* ------------------------------------------------------------------------ TRIANGLE_2 edge 1: nodes 1 -> 2 v 2: 1 -> 3 | 3: 2 -> 3 | 3 facet 1: edges 1 -2 3 nodes 1 2 3 |\ 6 5 |__\___u 1 4 2 ------------------------------------------------------------------------ */ static int NbrNodes_Triangle_2 = 6 ; static int NbrEdges_Triangle_2 = 3 ; static int NbrFacets_Triangle_2 = 1 ; static double Nodes_Triangle_2 [][3] = { {0., 0., 0.} , {1., 0., 0.} , {0., 1., 0.} , {0.5, 0., 0.} , {0.5, 0.5, 0.} , {0., 0.5, 0.} } ; static int Den_Triangle_2 [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, -2, 0}, { 1, -3, 0}, { 2, -3, 0} } ; static int Den_Triangle_2_Xp [] = { -1, 1, 0, -1, 0, 1, 0,-1, 1 } ; static int Dfe_Triangle_2 [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, 3, -2, 0} } ; static int Dfe_Triangle_2_Xp [] = { 1,-1, 1 } ; static int Dfn_Triangle_2 [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, 2, 3, 0} } ; /* ------------------------------------------------------------------------ QUADRANGLE edge 1: nodes 1 -> 2 v 2: 1 -> 4 | 3: 2 -> 3 4--|--3 4: 3 -> 4 | | | -----------u facet 1: edges 1 -2 3 4 nodes 1 2 3 4 | | | 1--|--2 | ------------------------------------------------------------------------ */ static int NbrNodes_Quadrangle = 4 ; static int NbrEdges_Quadrangle = 4 ; static int NbrFacets_Quadrangle = 1 ; static double Nodes_Quadrangle [][3] = { {-1., -1., 0.} , {1., -1., 0.} , { 1., 1., 0.} , {-1., 1., 0.} } ; static int Den_Quadrangle [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, -2, 0}, { 1, -4, 0}, { 2, -3, 0}, { 3, -4, 0} } ; static int Den_Quadrangle_Xp [] = { -1, 1, 0, 0, -1, 0, 0, 1, 0,-1, 1, 0, 0, 0,-1, 1 } ; static int Dfe_Quadrangle [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, 3, 4, -2, 0} } ; static int Dfe_Quadrangle_Xp [] = { 1,-1, 1, 1 } ; static int Dfn_Quadrangle [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, 2, 3, 4, 0} } ; /* ------------------------------------------------------------------------ QUADRANGLE_2 edge 1: nodes 1 -> 2 v 2: 1 -> 4 | 3: 2 -> 3 4--7--3 4: 3 -> 4 | | | --8--9--6--u facet 1: edges 1 -2 3 4 nodes 1 2 3 4 | | | 1--5--2 | ------------------------------------------------------------------------ */ static int NbrNodes_Quadrangle_2 = 9 ; static int NbrEdges_Quadrangle_2 = 4 ; static int NbrFacets_Quadrangle_2 = 1 ; static double Nodes_Quadrangle_2 [][3] = { {-1., -1., 0.} , { 1.,-1., 0.} , { 1., 1., 0.} , {-1., 1., 0.} , { 0., -1., 0.} , { 1., 0., 0.} , { 0., 1., 0.} , {-1., 0., 0.} , { 0., 0., 0.} } ; static int Den_Quadrangle_2 [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, -2, 0}, { 1, -4, 0}, { 2, -3, 0}, { 3, -4, 0} } ; static int Den_Quadrangle_2_Xp [] = { -1, 1, 0, 0, -1, 0, 0, 1, 0,-1, 1, 0, 0, 0,-1, 1 } ; static int Dfe_Quadrangle_2 [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, 3, 4, -2, 0} } ; static int Dfe_Quadrangle_2_Xp [] = { 1,-1, 1, 1 } ; static int Dfn_Quadrangle_2 [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, 2, 3, 4, 0} } ; /* ------------------------------------------------------------------------ QUADRANGLE_2_8N edge 1: nodes 1 -> 3 v 2: 1 -> 7 | 3: 3 -> 5 7--6--5 4: 5 -> 7 | | | --8-----4--u facet 1: edges 1 -3 5 7 nodes 1 3 5 7 | | | 1--2--3 | ------------------------------------------------------------------------ */ static int NbrNodes_Quadrangle_2_8N = 8 ; static int NbrEdges_Quadrangle_2_8N = 4 ; static int NbrFacets_Quadrangle_2_8N = 1 ; static double Nodes_Quadrangle_2_8N [][3] = { {-1., -1., 0.} , { 1.,-1., 0.} , { 1., 1., 0.} , {-1., 1., 0.} , { 0., -1., 0.} , { 1., 0., 0.} , { 0., 1., 0.} , {-1., 0., 0.} , } ; static int Den_Quadrangle_2_8N [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, -2, 0}, { 1, -4, 0}, { 2, -3, 0}, { 3, -4, 0} } ; static int Den_Quadrangle_2_8N_Xp [] = { -1, 1, 0, 0, -1, 0, 0, 1, 0,-1, 1, 0, 0, 0,-1, 1 } ; static int Dfe_Quadrangle_2_8N [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, 3, 4, -2, 0} } ; static int Dfe_Quadrangle_2_8N_Xp [] = { 1,-1, 1, 1 } ; static int Dfn_Quadrangle_2_8N [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, 2, 3, 4, 0} } ; /* ------------------------------------------------------------------------ TETRAHEDRON edge 1: nodes 1 -> 2 v 2: 1 -> 3 | 3: 1 -> 4 | 4: 2 -> 3 | 5: 2 -> 4 3 6: 3 -> 4 |\ | \ facet 1: edges 1 -3 5 nodes 1 2 4 |__\2_____u 2: -1 2 -4 1 3 2 1\ / 3: -2 3 -6 1 4 3 \4 4: 4 -5 6 2 3 4 \ w ------------------------------------------------------------------------ */ static int NbrNodes_Tetrahedron = 4 ; static int NbrEdges_Tetrahedron = 6 ; static int NbrFacets_Tetrahedron = 4 ; static double Nodes_Tetrahedron [][3] = { {0., 0., 0.} , {1., 0., 0.}, {0., 1., 0.} , {0., 0., 1.} } ; static int Den_Tetrahedron [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, -2, 0}, { 1, -3, 0}, { 1, -4, 0}, { 2, -3, 0}, { 2, -4, 0}, { 3, -4, 0} } ; static int Den_Tetrahedron_Xp [] = { -1, 1, 0, 0, -1, 0, 1, 0, -1, 0, 0, 1, 0,-1, 1, 0, 0,-1, 0, 1, 0, 0,-1, 1 } ; static int Dfe_Tetrahedron [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, -3, 5, 0}, { -1, 2, -4, 0}, { -2, 3, -6, 0}, { 4, -5, 6, 0} } ; static int Dfe_Tetrahedron_Xp [] = { 1, 0,-1, 0, 1, 0, -1, 1, 0,-1, 0, 0, 0,-1, 1, 0, 0,-1, 0, 0, 0, 1,-1, 1 } ; static int Dfn_Tetrahedron [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, 2, 4, 0}, { 1, 3, 2, 0}, { 1, 4, 3, 0}, { 2, 3, 4, 0} } ; /* ------------------------------------------------------------------------ HEXAHEDRON edge 1: nodes 1 -> 2 v 2: 1 -> 4 | 3: 1 -> 5 | 4: 2 -> 3 4----|--3 5: 2 -> 6 |\ | |\ 6: 3 -> 4 | 8-------7 7: 3 -> 7 | | ----|---u 8: 4 -> 8 1-|---\-2 | 9: 5 -> 6 \| \ \| 10: 5 -> 8 5-----\-6 11: 6 -> 7 \ 12: 7 -> 8 w facet 1: edges 1 -3 5 -9 nodes 1 2 6 5 2: -1 2 -4 -6 1 4 3 2 3: -2 3 -8 10 1 5 8 4 4: 4 -5 7 -11 2 3 7 6 5: 6 -7 8 -12 3 4 8 7 6: 9 -10 11 12 5 6 7 8 ------------------------------------------------------------------------ */ static int NbrNodes_Hexahedron = 8 ; static int NbrEdges_Hexahedron = 12 ; static int NbrFacets_Hexahedron = 6 ; static double Nodes_Hexahedron [][3] = { {-1., -1., -1.} , {1., -1., -1.} , { 1., 1., -1.} , {-1., 1., -1.} , {-1., -1., 1.} , {1., -1., 1.} , { 1., 1., 1.} , {-1., 1., 1.} } ; static int Den_Hexahedron [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, -2, 0}, { 1, -4, 0}, { 1, -5, 0}, { 2, -3, 0}, { 2, -6, 0}, { 3, -4, 0}, { 3, -7, 0}, { 4, -8, 0}, { 5, -6, 0}, { 5, -8, 0}, { 6, -7, 0}, { 7, -8, 0} } ; static int Den_Hexahedron_Xp [] = { -1, 1, 0, 0, 0, 0, 0, 0, -1, 0, 0, 1, 0, 0, 0, 0, -1, 0, 0, 0, 1, 0, 0, 0, 0,-1, 1, 0, 0, 0, 0, 0, 0,-1, 0, 0, 0, 1, 0, 0, 0, 0,-1, 1, 0, 0, 0, 0, 0, 0,-1, 0, 0, 0, 1, 0, 0, 0, 0,-1, 0, 0, 0, 1, 0, 0, 0, 0,-1, 1, 0, 0, 0, 0, 0, 0,-1, 0, 0, 1, 0, 0, 0, 0, 0,-1, 1, 0, 0, 0, 0, 0, 0, 0,-1, 1 }; static int Dfe_Hexahedron [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, -3, 5, -9, 0}, {-1, 2, -4, -6, 0}, {-2, 3, -8, 10, 0}, { 4, -5, 7, -11, 0}, { 6, -7, 8, -12, 0}, { 9, -10, 11, 12, 0} } ; static int Dfe_Hexahedron_Xp [] = { 1, 0,-1, 0, 1, 0, 0, 0,-1, 0, 0, 0, -1, 1, 0,-1, 0,-1, 0, 0, 0, 0, 0, 0, 0,-1, 1, 0, 0, 0, 0,-1, 0, 1, 0, 0, 0, 0, 0, 1,-1, 0, 1, 0, 0, 0,-1, 0, 0, 0, 0, 0, 0, 1,-1, 1, 0, 0, 0,-1, 0, 0, 0, 0, 0, 0, 0, 0, 1,-1, 1, 1 }; static int Dfn_Hexahedron [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, 2, 6, 5, 0}, { 1, 4, 3, 2, 0}, { 1, 5, 8, 4, 0}, { 2, 3, 7, 6, 0}, { 3, 4, 8, 7, 0}, { 5, 6, 7, 8, 0} } ; /* ------------------------------------------------------------------------ PRISM edge 1: nodes 1 -> 2 v 2: 1 -> 3 3 | 3: 1 -> 4 |\| 4: 2 -> 3 | | 5: 2 -> 5 1_|2 6: 3 -> 6 \| 6 7: 4 -> 5 |_|_\___u 8: 4 -> 6 \| \ 9: 5 -> 6 4 __5 \ facet 1: edges 1 -3 5 -7 nodes 1 2 5 4 \ 2: -1 2 -4 1 3 2 w 3: -2 3 -6 8 1 4 6 3 4: 4 -5 6 -9 2 3 6 5 5: 7 -8 9 4 5 6 ------------------------------------------------------------------------ */ static int NbrNodes_Prism = 6 ; static int NbrEdges_Prism = 9 ; static int NbrFacets_Prism = 5 ; static double Nodes_Prism [][3] = { {0., 0., -1.} , {1., 0., -1.} , {0., 1., -1.} , {0., 0., 1.} , {1., 0., 1.} , {0., 1., 1.} } ; static int Den_Prism [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, -2, 0}, { 1, -3, 0}, { 1, -4, 0}, { 2, -3, 0}, { 2, -5, 0}, { 3, -6, 0}, { 4, -5, 0}, { 4, -6, 0}, { 5, -6, 0} } ; static int Den_Prism_Xp [] = { -1, 1, 0, 0, 0, 0, -1, 0, 1, 0, 0, 0, -1, 0, 0, 1, 0, 0, 0,-1, 1, 0, 0, 0, 0,-1, 0, 0, 1, 0, 0, 0,-1, 0, 0, 1, 0, 0, 0,-1, 1, 0, 0, 0, 0,-1, 0, 1, 0, 0, 0, 0,-1, 1 }; static int Dfe_Prism [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, -3, 5, -7, 0}, { -1, 2, -4, 0}, { -2, 3, -6, 8, 0}, { 4, -5, 6, -9, 0}, { 7, -8, 9, 0} } ; static int Dfe_Prism_Xp [] = { 1, 0,-1, 0, 1, 0,-1, 0, 0, -1, 1, 0,-1, 0, 0, 0, 0, 0, 0,-1, 1, 0, 0,-1, 0, 1, 0, 0, 0, 0, 1,-1, 1, 0, 0,-1, 0, 0, 0, 0, 0, 0, 1,-1, 1 }; static int Dfn_Prism [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, 2, 5, 4, 0}, { 1, 3, 2, 0}, { 1, 4, 6, 3, 0}, { 2, 3, 6, 5, 0}, { 4, 5, 6, 0} } ; /* ------------------------------------------------------------------------ PYRAMID edge 1: nodes 1 -> 2 v 2: 1 -> 4 | 3: 1 -> 5 | 4: 2 -> 3 4---|---3 5: 2 -> 5 | \ | /| 6: 3 -> 4 | \ -/-|---u 7: 3 -> 5 | / 5\ | 8: 4 -> 5 1/----\-2 \ facet 1: edges 1 5 -3 nodes 1 2 5 \ 2: 2 -6 -4 -1 1 4 3 2 w 3: 3 -8 -2 1 5 4 4: 4 7 -5 2 3 5 5: 6 8 -7 3 4 5 ------------------------------------------------------------------------ */ static int NbrNodes_Pyramid = 5 ; static int NbrEdges_Pyramid = 8 ; static int NbrFacets_Pyramid = 5 ; static double Nodes_Pyramid [][3] = { {-1., -1., 0.} , { 1., -1., 0.} , { 1., 1., 0.} , {-1., 1., 0.} , { 0., 0., 1.} } ; static int Den_Pyramid [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, -2, 0}, { 1, -4, 0}, { 1, -5, 0}, { 2, -3, 0}, { 2, -5, 0}, { 3, -4, 0}, { 3, -5, 0}, { 4, -5, 0} } ; static int Den_Pyramid_Xp [] = { -1, 1, 0, 0, 0, -1, 0, 0, 1, 0, -1, 0, 0, 0, 1, 0,-1, 1, 0, 0, 0,-1, 0, 0, 1, 0, 0,-1, 1, 0, 0, 0,-1, 0, 1, 0, 0, 0,-1, 1 }; static int Dfe_Pyramid [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, 5, -3, 0}, { 2, -6, -4, -1, 0}, { 3, -8, -2, 0}, { 4, 7, -5, 0}, { 6, 8, -7, 0} } ; static int Dfe_Pyramid_Xp [] = { 1, 0,-1, 0, 1, 0, 0, 0, -1, 1, 0,-1, 0,-1, 0, 0, 0,-1, 1, 0, 0, 0, 0,-1, 0, 0, 0, 1,-1, 0, 1, 0, 0, 0, 0, 0, 0, 1,-1, 1 }; static int Dfn_Pyramid [] [NBR_MAX_SUBENTITIES_IN_ELEMENT] = { { 1, 2, 5, 0}, { 1, 4, 3, 2, 0}, { 1, 5, 4, 0}, { 2, 3, 5, 0}, { 3, 4, 5, 0} } ; #endif getdp-2.4.2-source/Legacy/Cal_Quantity.h000644 001750 001750 00000002010 12221300353 021532 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _CAL_QUANTITY_H_ #define _CAL_QUANTITY_H_ #include "ProData.h" #include "ListUtils.h" void Get_ValueOfExpression(struct Expression * Expression_P, struct QuantityStorage * QuantityStorage_P0, double u, double v, double w, struct Value * Value, int NbrArguments=0) ; void Get_ValueOfExpressionByIndex(int Index_Expression, struct QuantityStorage * QuantityStorage_P0, double u, double v, double w, struct Value * Value) ; void Cal_WholeQuantity(struct Element * Element, struct QuantityStorage * QuantityStorage_P0, List_T * WholeQuantity_L, double u, double v, double w, int Index_Dof, int Nbr_Dof, struct Value DofValue[], int NbrArguments=0, char *ExpressionName=NULL) ; void Cal_StoreInRegister(struct Value *Value, int RegisterIndex) ; #endif getdp-2.4.2-source/Legacy/BF_Perpendicular.cpp000644 001750 001750 00000014001 12116424202 022642 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "ProData.h" #include "BF.h" #define ARGS \ struct Element * Element, int NumEntity, \ double u, double v, double w, double *s /* ------------------------------------------------------------------------ */ /* B F _ W i r e */ /* ------------------------------------------------------------------------ */ #define BF(BF_Wire_X,BF_Node_X) \ s[1] = s[2] = 0. ; \ (BF_Node_X)(Element, NumEntity, u, v, w, &s[0]) ; void BF_Wire(ARGS) { BF("BF_Wire",BF_Node) ; } #undef BF /* ------------------------------------------------------------------------ */ /* B F _ D i v W i r e */ /* ------------------------------------------------------------------------ */ #define BF(BF_DivWire_X,BF_GradNode_X) \ (BF_GradNode_X)(Element, NumEntity, u, v, w, &s[0]) ; void BF_DivWire(ARGS) { BF("BF_DivWire",BF_GradNode) ; } #undef BF /* ------------------------------------------------------------------------ */ /* B F _ P e r p e n d i c u l a r E d g e */ /* ------------------------------------------------------------------------ */ #define BF(BF_PerpendicularEdge_X,BF_Node_X) \ s[0] = s[1] = 0. ; \ (BF_Node_X)(Element, NumEntity, u, v, w, &s[2]) ; void BF_PerpendicularEdge(ARGS) { BF("BF_PerpendicularEdge",BF_Node) ; } void BF_PerpendicularEdge_2E(ARGS) { BF("BF_PerpendicularEdge_2E",BF_Node_2E) ; } void BF_PerpendicularEdge_2F(ARGS) { BF("BF_PerpendicularEdge_2F",BF_Node_2F) ; } void BF_PerpendicularEdge_2V(ARGS) { BF("BF_PerpendicularEdge_2V",BF_Node_2V) ; } void BF_PerpendicularEdge_3E(ARGS) { BF("BF_PerpendicularEdge_3E",BF_Node_3E) ; } void BF_PerpendicularEdge_3F(ARGS) { BF("BF_PerpendicularEdge_3F",BF_Node_3F) ; } void BF_PerpendicularEdge_3V(ARGS) { BF("BF_PerpendicularEdge_3V",BF_Node_3V) ; } #undef BF /* ------------------------------------------------------------------------ */ /* B F _ C u r l P e r p e n d i c u l a r E d g e */ /* ------------------------------------------------------------------------ */ #define BF(BF_CurlPerpendicularEdge_X,BF_GradNode_X) \ double ss ; \ (BF_GradNode_X)(Element, NumEntity, u, v, w, s) ; \ ss = s[0] ; s[0] = s[1] ; s[1] = -ss ; void BF_CurlPerpendicularEdge(ARGS) { BF("BF_CurlPerpendicularEdge",BF_GradNode) ; } void BF_CurlPerpendicularEdge_2E(ARGS) { BF("BF_CurlPerpendicularEdge_2E",BF_GradNode_2E) ; } void BF_CurlPerpendicularEdge_2F(ARGS) { BF("BF_CurlPerpendicularEdge_2F",BF_GradNode_2F) ; } void BF_CurlPerpendicularEdge_2V(ARGS) { BF("BF_CurlPerpendicularEdge_2V",BF_GradNode_2V) ; } void BF_CurlPerpendicularEdge_3E(ARGS) { BF("BF_CurlPerpendicularEdge_3E",BF_GradNode_3E) ; } void BF_CurlPerpendicularEdge_3F(ARGS) { BF("BF_CurlPerpendicularEdge_3F",BF_GradNode_3F) ; } void BF_CurlPerpendicularEdge_3V(ARGS) { BF("BF_CurlPerpendicularEdge_3V",BF_GradNode_3V) ; } #undef BF /* ------------------------------------------------------------------------ */ /* B F _ P e r p e n d i c u l a r F a c e t */ /* ------------------------------------------------------------------------ */ #define BF(BF_PerpendicularFacet_X,BF_Edge_X) \ double ss ; \ (BF_Edge_X)(Element, NumEntity, u, v, w, s) ; \ ss = s[0] ; s[0] = -s[1] ; s[1] = ss ; void BF_PerpendicularFacet(ARGS) { BF("BF_PerpendicularFacet",BF_Edge) ; } void BF_PerpendicularFacet_2E(ARGS) { BF("BF_PerpendicularFacet_2E",BF_Edge_2E) ; } void BF_PerpendicularFacet_2F(ARGS) { BF("BF_PerpendicularFacet_2F",BF_Edge_2F) ; } void BF_PerpendicularFacet_2V(ARGS) { BF("BF_PerpendicularFacet_2V",BF_Edge_2V) ; } void BF_PerpendicularFacet_3E(ARGS) { BF("BF_PerpendicularFacet_3E",BF_Edge_3E) ; } void BF_PerpendicularFacet_3F_a(ARGS) { BF("BF_PerpendicularFacet_3F_a",BF_Edge_3F_a) ; } void BF_PerpendicularFacet_3F_b(ARGS) { BF("BF_PerpendicularFacet_3F_b",BF_Edge_3F_b) ; } void BF_PerpendicularFacet_3F_c(ARGS) { BF("BF_PerpendicularFacet_3F_c",BF_Edge_3F_c) ; } void BF_PerpendicularFacet_3V(ARGS) { BF("BF_PerpendicularFacet_3V",BF_Edge_3V) ; } void BF_PerpendicularFacet_4E(ARGS) { BF("BF_PerpendicularFacet_4E",BF_Edge_4E) ; } void BF_PerpendicularFacet_4F(ARGS) { BF("BF_PerpendicularFacet_4F",BF_Edge_4F) ; } void BF_PerpendicularFacet_4V(ARGS) { BF("BF_PerpendicularFacet_4V",BF_Edge_4V) ; } #undef BF /* ------------------------------------------------------------------------ */ /* B F _ D i v P e r p e n d i c u l a r F a c e t */ /* ------------------------------------------------------------------------ */ #define BF(BF_DivPerpendicularFacet_X,BF_CurlEdge_X) \ (BF_CurlEdge_X)(Element, NumEntity, u, v, w, s) ; \ s[0] = -s[2] ; s[2] = 0. ; void BF_DivPerpendicularFacet(ARGS){ BF("BF_DivPerpendicularFacet",BF_CurlEdge) ; } void BF_DivPerpendicularFacet_2E(ARGS){ BF("BF_DivPerpendicularFacet_2E",BF_CurlEdge_2E) ; } void BF_DivPerpendicularFacet_2F(ARGS){ BF("BF_DivPerpendicularFacet_2F",BF_CurlEdge_2F) ; } void BF_DivPerpendicularFacet_2V(ARGS){ BF("BF_DivPerpendicularFacet_2V",BF_CurlEdge_2V) ; } void BF_DivPerpendicularFacet_3E(ARGS){ BF("BF_DivPerpendicularFacet_3E",BF_CurlEdge_3E) ; } void BF_DivPerpendicularFacet_3F_a(ARGS){ BF("BF_DivPerpendicularFacet_3F_a",BF_CurlEdge_3F_a) ; } void BF_DivPerpendicularFacet_3F_b(ARGS){ BF("BF_DivPerpendicularFacet_3F_b",BF_CurlEdge_3F_b) ; } void BF_DivPerpendicularFacet_3F_c(ARGS){ BF("BF_DivPerpendicularFacet_3F_c",BF_CurlEdge_3F_c) ; } void BF_DivPerpendicularFacet_3V(ARGS){ BF("BF_DivPerpendicularFacet_3V",BF_CurlEdge_3V) ; } void BF_DivPerpendicularFacet_4E(ARGS){ BF("BF_DivPerpendicularFacet_4E",BF_CurlEdge_4E) ; } void BF_DivPerpendicularFacet_4F(ARGS){ BF("BF_DivPerpendicularFacet_4F",BF_CurlEdge_4F) ; } void BF_DivPerpendicularFacet_4V(ARGS){ BF("BF_DivPerpendicularFacet_4V",BF_CurlEdge_4V) ; } #undef BF #undef ARGS getdp-2.4.2-source/Legacy/GeoData.cpp000644 001750 001750 00000060420 12166744450 021027 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include "GeoData.h" #include "ProData.h" #include "Pos_Search.h" #include "MallocUtils.h" #include "Message.h" #include "OS.h" #define SQU(a) ((a)*(a)) extern double Flag_ORDER ; FILE * File_GEO ; struct GeoData * CurrentGeoData ; static void swapBytes(char *array, int size, int n) { int i, c; char *x = (char *)Malloc(size * sizeof(char)) ; for(i = 0; i < n; i++) { char *a = &array[i * size]; memcpy(x, a, size); for(c = 0; c < size; c++) a[size - 1 - c] = x[c]; } Free(x); } /* ------------------------------------------------------------------------ */ /* G e o _ A d d G e o D a t a */ /* ------------------------------------------------------------------------ */ int Geo_AddGeoData(List_T * GeoData_L, char * Name_MshFile, char * Name_DefaultMshFile, char * Name_AdaptFile, char * Name_DefaultAdaptFile) { struct GeoData GeoData_S ; int i ; if (!Name_MshFile) Name_MshFile = Name_DefaultMshFile ; if ((i = List_ISearchSeq(GeoData_L, Name_MshFile, fcmp_GeoData_Name)) < 0) { Message::Info("Loading Geometric data '%s'", Name_MshFile) ; i = List_Nbr(GeoData_L) ; Geo_InitGeoData(&GeoData_S, i, Name_MshFile) ; Geo_OpenFile(Name_MshFile, "r") ; Geo_ReadFile(&GeoData_S) ; Geo_CloseFile() ; if (!Name_AdaptFile) Name_AdaptFile = Name_DefaultAdaptFile ; if (Name_AdaptFile) { Message::Info("Loading Adaptation data '%s'", Name_AdaptFile) ; Geo_OpenFile(Name_AdaptFile, "r") ; Geo_SetCurrentGeoData(&GeoData_S) ; Geo_ReadFileAdapt(&GeoData_S) ; Geo_CloseFile() ; } List_Add(GeoData_L, &GeoData_S) ; } return(i) ; } int fcmp_GeoData_Name(const void * a, const void * b) { return ( strcmp((char *)a, ((struct GeoData *)b)->Name ) ) ; } /* ------------------------------------------------------------------------ */ /* G e o _ I n i t G e o D a t a */ /* ------------------------------------------------------------------------ */ void Geo_InitGeoData(struct GeoData * GeoData_P, int Num, char * Name) { GeoData_P->Num = Num ; GeoData_P->Name = Name ; GeoData_P->Nodes = NULL ; GeoData_P->Elements = NULL ; GeoData_P->NbrElementsWithEdges = GeoData_P->NbrElementsWithFacets = 0 ; GeoData_P->NumCurrentEdge = GeoData_P->NumCurrentFacet = 0 ; GeoData_P->EdgesXNodes = Tree_Create(sizeof(struct Entity2XEntity1), fcmp_E2XE1) ; GeoData_P->FacetsXEdges = Tree_Create(sizeof(struct Entity2XEntity1), fcmp_E2XE1) ; GeoData_P->NodesXElements = NULL ; GeoData_P->Normals = Tree_Create(sizeof(struct EntityXVector), fcmp_EXVector) ; GeoData_P->GroupForPRE = NULL ; GeoData_P->Grid.Init = 0 ; GeoData_P->H = GeoData_P->P = NULL ; } /* ------------------------------------------------------------------------ */ /* G e o _ F r e e G e o D a t a */ /* ------------------------------------------------------------------------ */ void Geo_FreeGeoData(struct GeoData * GeoData_P) { Message::Debug("Freeing GeoData %d", GeoData_P->Num); List_Delete(GeoData_P->Nodes); if(GeoData_P->Elements){ for(int i = 0; i < List_Nbr(GeoData_P->Elements); i++){ Geo_Element *e = (Geo_Element*)List_Pointer(GeoData_P->Elements, i); Free(e->NumNodes); Free(e->NumEdges); Free(e->NumFacets); } List_Delete(GeoData_P->Elements); } if(GeoData_P->EdgesXNodes){ Tree_Action(GeoData_P->EdgesXNodes, free_E2XE1); Tree_Delete(GeoData_P->EdgesXNodes); } if(GeoData_P->FacetsXEdges){ Tree_Action(GeoData_P->FacetsXEdges, free_E2XE1); Tree_Delete(GeoData_P->FacetsXEdges); } if(GeoData_P->NodesXElements){ Tree_Action(GeoData_P->NodesXElements, free_E2XE1); Tree_Delete(GeoData_P->NodesXElements); } Tree_Delete(GeoData_P->Normals); List_Delete(GeoData_P->GroupForPRE); Free_SearchGrid(&GeoData_P->Grid); Free(GeoData_P->H); Free(GeoData_P->P); } /* ------------------------------------------------------------------------ */ /* G e o _ S e t C u r r e n t G e o D a t a B a s e */ /* ------------------------------------------------------------------------ */ void Geo_SetCurrentGeoData(struct GeoData * GeoData_P) { CurrentGeoData = GeoData_P ; } /* ------------------------------------------------------------------------ */ /* G e o _ O p e n F i l e */ /* ------------------------------------------------------------------------ */ void Geo_OpenFile(char * Name, const char * Mode) { File_GEO = FOpen(Name, Mode) ; if (!File_GEO) Message::Error("Unable to open file '%s'", Name); } /* ------------------------------------------------------------------------ */ /* G e o _ C l o s e F i l e */ /* ------------------------------------------------------------------------ */ void Geo_CloseFile(void) { fclose(File_GEO) ; } /* ------------------------------------------------------------------------ */ /* G e o _ R e a d F i l e */ /* ------------------------------------------------------------------------ */ int Geo_GetElementType(int Format, int Type) { switch(Format){ case FORMAT_GMSH : switch(Type){ case 15 : return(POINT) ; case 1 : return(LINE) ; case 2 : return(TRIANGLE) ; case 3 : return(QUADRANGLE) ; case 4 : return(TETRAHEDRON) ; case 5 : return(HEXAHEDRON) ; case 6 : return(PRISM) ; case 7 : return(PYRAMID) ; case 8 : return(LINE_2) ; case 9 : return(TRIANGLE_2) ; case 10 : return(QUADRANGLE_2) ; case 11 : return(TETRAHEDRON_2) ; case 12 : return(HEXAHEDRON_2) ; case 13 : return(PRISM_2) ; case 14 : return(PYRAMID_2) ; case 16 : return(QUADRANGLE_2_8N) ; default : Message::Error("Unkown type of Element in Gmsh format (%d)", FORMAT_GMSH) ; return(-1) ; } break ; default : Message::Error("Unkown mesh format (%d)", Format) ; return(-1) ; } } int Geo_GetElementTypeInv(int Format, int Type) { switch(Format){ case FORMAT_GMSH : switch(Type){ case POINT : return(15) ; case LINE : return(1) ; case TRIANGLE : return(2) ; case QUADRANGLE : return(3) ; case TETRAHEDRON : return(4) ; case HEXAHEDRON : return(5) ; case PRISM : return(6) ; case PYRAMID : return(7) ; case LINE_2 : return(8) ; case TRIANGLE_2 : return(9) ; case QUADRANGLE_2 : return(10) ; case TETRAHEDRON_2 : return(11) ; case HEXAHEDRON_2 : return(12) ; case PRISM_2 : return(13) ; case PYRAMID_2 : return(14) ; case QUADRANGLE_2_8N: return(16) ; default : Message::Error("Unkown type of Element in Gmsh format") ; return(-1) ; } break ; default : Message::Error("Unkown mesh format") ; return(-1) ; } } int Geo_GetNbNodesPerElement(int Type) { switch(Type){ case POINT : return(1) ; case LINE : return(2) ; case TRIANGLE : return(3) ; case QUADRANGLE : return(4) ; case TETRAHEDRON : return(4) ; case HEXAHEDRON : return(8) ; case PRISM : return(6) ; case PYRAMID : return(5) ; case LINE_2 : return(3) ; case TRIANGLE_2 : return(6) ; case QUADRANGLE_2 : return(9) ; case TETRAHEDRON_2 : return(10) ; case HEXAHEDRON_2 : return(20) ; case PRISM_2 : return(15) ; case PYRAMID_2 : return(13) ; case QUADRANGLE_2_8N: return(8) ; default : Message::Error("Unkown type of Element") ; return(-1) ; } } void Geo_SaveMesh(struct GeoData * GeoData_P, List_T * InitialList, char * FileName) { FILE * file; struct Geo_Node Geo_Node ; struct Geo_Node * Geo_Node_P ; struct Geo_Element Geo_Element ; struct GeoData GeoData ; int i, j, Type; int fcmp_int(const void * a, const void * b); GeoData.Nodes = List_Create(1000, 1000, sizeof(struct Geo_Node)) ; GeoData.Elements = List_Create(1000, 1000, sizeof(struct Geo_Node)) ; for (i = 0 ; i < List_Nbr(GeoData_P->Elements) ; i++) { List_Read(GeoData_P->Elements, i, &Geo_Element) ; if (List_Search(InitialList, &Geo_Element.Region, fcmp_int) ) { List_Add(GeoData.Elements, &Geo_Element) ; for (j = 0 ; j < Geo_Element.NbrNodes ; j++) if (!List_Search(GeoData.Nodes, Geo_Node_P = Geo_GetGeoNodeOfNum(Geo_Element.NumNodes[j]), fcmp_Nod) ) List_Add(GeoData.Nodes, Geo_Node_P) ; } } file = FOpen(FileName,"w"); Message::Info("Saving mesh in file \"%s\" (%d nodes, %d elements)", FileName, List_Nbr(GeoData.Nodes), List_Nbr(GeoData.Elements)); fprintf(file, "$NOD\n%d\n", List_Nbr(GeoData.Nodes)); for (i = 0 ; i < List_Nbr(GeoData.Nodes) ; i++) { List_Read(GeoData.Nodes, i, &Geo_Node) ; fprintf(file, "%d %.16g %.16g %.16g\n", Geo_Node.Num, Geo_Node.x, Geo_Node.y, Geo_Node.z) ; } fprintf(file, "$ENDNOD\n$ELM\n%d\n", List_Nbr(GeoData.Elements)); for (i = 0 ; i < List_Nbr(GeoData.Elements) ; i++) { List_Read(GeoData.Elements, i, &Geo_Element) ; Type = Geo_GetElementTypeInv(FORMAT_GMSH, Geo_Element.Type) ; fprintf(file, "%d %d %d %d %d ", Geo_Element.Num, Type, Geo_Element.Region, Geo_Element.Region, Geo_Element.NbrNodes) ; for (j = 0 ; j < Geo_Element.NbrNodes ; j++) fprintf(file, "%d ", Geo_Element.NumNodes[j]) ; fprintf(file, "\n") ; } fprintf(file, "$ENDELM\n"); fclose(file); List_Delete(GeoData.Nodes); List_Delete(GeoData.Elements); } void Geo_ReadFile(struct GeoData * GeoData_P) { int Nbr, i, j, Type, iDummy, Format, Size, NbTags ; double Version = 1.0 ; struct Geo_Node Geo_Node ; struct Geo_Element Geo_Element ; char String[256] ; int binary = 0, swap = 0; while (1) { do { fgets(String, sizeof(String), File_GEO) ; if (feof(File_GEO)) break ; } while (String[0] != '$') ; if (feof(File_GEO)) break ; /* F O R M A T */ if(!strncmp(&String[1], "MeshFormat", 10)) { fgets(String, sizeof(String), File_GEO) ; if(sscanf(String, "%lf %d %d", &Version, &Format, &Size) != 3) return; if(Version < 2.0 || Version >= 3.0){ Message::Error("Unknown mesh file version (%g)", Version); return; } if(Format){ binary = 1; Message::Info("Mesh is in binary format"); int one; if(fread(&one, sizeof(int), 1, File_GEO) != 1) return; if(one != 1){ swap = 1; Message::Info("Swapping bytes from binary file"); } } } /* P H Y S I C A L N A M E S */ else if(!strncmp(&String[1], "PhysicalNames", 13)) { // GetDP does not currently use the name information fgets(String, sizeof(String), File_GEO) ; int numNames; if(sscanf(String, "%d", &numNames) != 1) return ; for(int i = 0; i < numNames; i++) { int dim = -1, num; if(Version > 2.0){ if(fscanf(File_GEO, "%d", &dim) != 1) return ; } if(fscanf(File_GEO, "%d", &num) != 1) return ; fgets(String, sizeof(String), File_GEO) ; } } /* N O D E S */ else if (!strncmp(&String[1], "NOE", 3) || !strncmp(&String[1], "NOD", 3) || !strncmp(&String[1], "Nodes", 5)) { fgets(String, sizeof(String), File_GEO) ; if(sscanf(String, "%d", &Nbr) != 1) return; Message::Debug("%d nodes", Nbr); if (GeoData_P->Nodes == NULL) GeoData_P->Nodes = List_Create(Nbr, 1000, sizeof(struct Geo_Node)) ; for (i = 0 ; i < Nbr ; i++) { if (!binary){ fscanf(File_GEO, "%d %lf %lf %lf", &Geo_Node.Num, &Geo_Node.x, &Geo_Node.y, &Geo_Node.z) ; } else { if(fread(&Geo_Node.Num, sizeof(int), 1, File_GEO) != 1) return; if(swap) swapBytes((char*)&Geo_Node.Num, sizeof(int), 1); double xyz[3]; if(fread(xyz, sizeof(double), 3, File_GEO) != 3) return; if(swap) swapBytes((char*)xyz, sizeof(double), 3); Geo_Node.x = xyz[0]; Geo_Node.y = xyz[1]; Geo_Node.z = xyz[2]; } List_Add(GeoData_P->Nodes, &Geo_Node) ; if(!i){ GeoData_P->Xmin = GeoData_P->Xmax = Geo_Node.x; GeoData_P->Ymin = GeoData_P->Ymax = Geo_Node.y; GeoData_P->Zmin = GeoData_P->Zmax = Geo_Node.z; } else{ GeoData_P->Xmin = std::min(GeoData_P->Xmin, Geo_Node.x); GeoData_P->Xmax = std::max(GeoData_P->Xmax, Geo_Node.x); GeoData_P->Ymin = std::min(GeoData_P->Ymin, Geo_Node.y); GeoData_P->Ymax = std::max(GeoData_P->Ymax, Geo_Node.y); GeoData_P->Zmin = std::min(GeoData_P->Zmin, Geo_Node.z); GeoData_P->Zmax = std::max(GeoData_P->Zmax, Geo_Node.z); } } if(GeoData_P->Xmin != GeoData_P->Xmax && GeoData_P->Ymin != GeoData_P->Ymax && GeoData_P->Zmin != GeoData_P->Zmax) GeoData_P->Dimension = _3D; else if(GeoData_P->Xmin != GeoData_P->Xmax && GeoData_P->Ymin != GeoData_P->Ymax) GeoData_P->Dimension = _2D; else if(GeoData_P->Xmin != GeoData_P->Xmax && GeoData_P->Zmin != GeoData_P->Zmax) GeoData_P->Dimension = _2D; else if(GeoData_P->Ymin != GeoData_P->Ymax && GeoData_P->Zmin != GeoData_P->Zmax) GeoData_P->Dimension = _2D; else if(GeoData_P->Xmin != GeoData_P->Xmax) GeoData_P->Dimension = _1D; else if(GeoData_P->Ymin != GeoData_P->Ymax) GeoData_P->Dimension = _1D; else if(GeoData_P->Zmin != GeoData_P->Zmax) GeoData_P->Dimension = _1D; else GeoData_P->Dimension = _0D; GeoData_P->CharacteristicLength = sqrt(SQU(GeoData_P->Xmax - GeoData_P->Xmin) + SQU(GeoData_P->Ymax - GeoData_P->Ymin) + SQU(GeoData_P->Zmax - GeoData_P->Zmin)); if(!GeoData_P->CharacteristicLength) GeoData_P->CharacteristicLength = 1.; } else if (!strncmp(&String[1], "ParametricNodes", 15)) { Message::Error("Cannot read parametric nodes: please save mesh file with standard " "nodes instead!"); } /* E L E M E N T S */ else if (!strncmp(&String[1], "ELM", 3) || !strncmp(&String[1], "Elements", 8)) { fgets(String, sizeof(String), File_GEO) ; if(sscanf(String, "%d", &Nbr) != 1) return; Message::Debug("%d elements", Nbr); if (GeoData_P->Elements == NULL) GeoData_P->Elements = List_Create(Nbr, 1000, sizeof(struct Geo_Element)) ; Geo_Element.NbrEdges = Geo_Element.NbrFacets = 0 ; Geo_Element.NumEdges = Geo_Element.NumFacets = NULL ; if (!binary){ for (i = 0 ; i < Nbr ; i++) { if(Version == 1.0){ fscanf(File_GEO, "%d %d %d %d %d", &Geo_Element.Num, &Type, &Geo_Element.Region, &Geo_Element.ElementaryRegion, &Geo_Element.NbrNodes) ; Geo_Element.Type = Geo_GetElementType(FORMAT_GMSH, Type) ; } else{ fscanf(File_GEO, "%d %d %d", &Geo_Element.Num, &Type, &NbTags); Geo_Element.Region = Geo_Element.ElementaryRegion = 1; for(j = 0; j < NbTags; j++){ fscanf(File_GEO, "%d", &iDummy); if(j == 0) Geo_Element.Region = iDummy; else if(j == 1) Geo_Element.ElementaryRegion = iDummy; /* ignore any other tags for now */ } Geo_Element.Type = Geo_GetElementType(FORMAT_GMSH, Type) ; Geo_Element.NbrNodes = Geo_GetNbNodesPerElement(Geo_Element.Type); } Geo_Element.NumNodes = (int *)Malloc(Geo_Element.NbrNodes * sizeof(int)) ; for (j = 0 ; j < Geo_Element.NbrNodes ; j++) fscanf(File_GEO, "%d", &Geo_Element.NumNodes[j]) ; List_Add(GeoData_P->Elements, &Geo_Element) ; } } else { int numElementsPartial = 0; while(numElementsPartial < Nbr){ int header[3]; if(fread(header, sizeof(int), 3, File_GEO) != 3) return; if(swap) swapBytes((char*)header, sizeof(int), 3); Type = header[0]; int numElms = header[1]; int numTags = header[2]; Geo_Element.Type = Geo_GetElementType(FORMAT_GMSH, Type) ; Geo_Element.NbrNodes = Geo_GetNbNodesPerElement(Geo_Element.Type); unsigned int n = 1 + numTags + Geo_Element.NbrNodes; int *data = (int *)Malloc(n * sizeof(int)) ; for(i = 0; i < numElms; i++) { if(fread(data, sizeof(int), n, File_GEO) != n) return; if(swap) swapBytes((char*)data, sizeof(int), n); Geo_Element.Num = data[0]; Geo_Element.Region = (numTags > 0) ? data[1] : 0; Geo_Element.ElementaryRegion = (numTags > 1) ? data[2] : 0; Geo_Element.NumNodes = (int *)Malloc(Geo_Element.NbrNodes * sizeof(int)) ; for (j = 0 ; j < Geo_Element.NbrNodes ; j++) Geo_Element.NumNodes[j] = data[numTags + 1 + j] ; List_Add(GeoData_P->Elements, &Geo_Element) ; } Free(data); numElementsPartial += numElms; } } List_Sort(GeoData_P->Elements, fcmp_Elm) ; } do { fgets(String, sizeof(String), File_GEO) ; if (feof(File_GEO)){ Message::Error("Prematured end of file"); return; } } while (String[0] != '$') ; } /* while 1 ... */ } void Geo_ReadFileAdapt(struct GeoData * GeoData_P) { struct Geo_Element Geo_Element, * Geo_Element_P ; int Nbr, i, Index_GeoElement ; double E, H, P, Max_Order = -1.0 ; char String[256] ; Nbr = List_Nbr(GeoData_P->Elements) ; if(!GeoData_P->H){ GeoData_P->H = (double*)Malloc((Nbr+2)*sizeof(double)) ; for (i = 0 ; i < Nbr ; i++) GeoData_P->H[i+1] = -1.0 ; } if(!GeoData_P->P){ GeoData_P->P = (double*)Malloc((Nbr+2)*sizeof(double)) ; for (i = 0 ; i < Nbr ; i++) GeoData_P->P[i+1] = -1.0 ; } while (1) { do { fgets(String, sizeof(String), File_GEO) ; if (feof(File_GEO)) break ; } while (String[0] != '$') ; if (feof(File_GEO)) break ; if (!strncmp(&String[1], "Adapt", 5)) { fscanf(File_GEO, "%d", &Nbr) ; for (i = 0 ; i < Nbr ; i++) { fscanf(File_GEO, "%d %lf %lf %lf", &Geo_Element.Num, &E, &H, &P) ; if(!(Geo_Element_P = (struct Geo_Element *) List_PQuery(GeoData_P->Elements, &Geo_Element, fcmp_Elm))){ Message::Error("Element %d not found in database", Geo_Element.Num) ; break; } Index_GeoElement = Geo_GetGeoElementIndex(Geo_Element_P) ; GeoData_P->H[Index_GeoElement+1] = H ; GeoData_P->P[Index_GeoElement+1] = P ; if(P > Max_Order) Max_Order = P ; } } do { fgets(String, sizeof(String), File_GEO) ; if (feof(File_GEO)){ Message::Error("Prematured end of file"); break; } } while (String[0] != '$') ; } /* while 1 ... */ if(Flag_ORDER < 0) Flag_ORDER = Max_Order ; Message::Info("Maximum interpolation order = %g", Flag_ORDER) ; } /* ------------------------------------------------------------------------ */ /* f c m p _ E l m & f c m p _ N o d */ /* ------------------------------------------------------------------------ */ int fcmp_Elm(const void * a, const void * b) { return ((struct Geo_Element *)a)->Num - ((struct Geo_Element *)b)->Num ; } int fcmp_Nod(const void * a, const void * b) { return ((struct Geo_Node *)a)->Num - ((struct Geo_Node *)b)->Num ; } /* ------------------------------------------------------------------------ */ /* G e o _ G e t N b r G e o E l e m e n t s */ /* ------------------------------------------------------------------------ */ int Geo_GetNbrGeoElements(void) { return(List_Nbr(CurrentGeoData->Elements)) ; } /* ------------------------------------------------------------------------ */ /* G e o _ G e t G e o E l e m e n t */ /* ------------------------------------------------------------------------ */ struct Geo_Element *Geo_GetGeoElement(int Index_Element) { return((struct Geo_Element *)List_Pointer(CurrentGeoData->Elements, Index_Element)) ; } /* ------------------------------------------------------------------------ */ /* G e o _ G e t G e o E l e m e n t I n d e x */ /* ------------------------------------------------------------------------ */ int Geo_GetGeoElementIndex(struct Geo_Element * GeoElement) { return(GeoElement - (struct Geo_Element*)List_Pointer(CurrentGeoData->Elements, 0)) ; } /* ------------------------------------------------------------------------ */ /* G e o _ G e t G e o E l e m e n t O f N u m */ /* ------------------------------------------------------------------------ */ struct Geo_Element *Geo_GetGeoElementOfNum(int Num_Element) { struct Geo_Element elm ; elm.Num = Num_Element ; return((struct Geo_Element*)List_PQuery(CurrentGeoData->Elements, &elm, fcmp_Elm)) ; } /* ------------------------------------------------------------------------ */ /* G e o _ G e t N b r G e o N o d e s */ /* ------------------------------------------------------------------------ */ int Geo_GetNbrGeoNodes(void){ return(List_Nbr(CurrentGeoData->Nodes)) ; } /* ------------------------------------------------------------------------ */ /* G e o _ G e t G e o N o d e */ /* ------------------------------------------------------------------------ */ struct Geo_Node *Geo_GetGeoNode(int Index_Node) { return((struct Geo_Node *)List_Pointer(CurrentGeoData->Nodes, Index_Node)) ; } /* ------------------------------------------------------------------------ */ /* G e o _ G e t G e o N o d e O f N u m */ /* ------------------------------------------------------------------------ */ struct Geo_Node *Geo_GetGeoNodeOfNum(int Num_Node) { struct Geo_Node node ; node.Num = Num_Node ; return((struct Geo_Node*)List_PQuery(CurrentGeoData->Nodes, &node, fcmp_Nod)) ; } /* ------------------------------------------------------------------------ */ /* G e o _ G e t N o d e s C o o r d i n a t e s */ /* ------------------------------------------------------------------------ */ void Geo_GetNodesCoordinates(int Nbr_Node, int * Num_Node, double * x, double * y, double * z) { int i ; struct Geo_Node Geo_Node, * Geo_Node_P ; for (i = 0 ; i < Nbr_Node ; i++) { Geo_Node.Num = abs(Num_Node[i]) ; if(!(Geo_Node_P = (struct Geo_Node*) List_PQuery(CurrentGeoData->Nodes, &Geo_Node, fcmp_Nod))){ Message::Error("Node %d does not exist", Geo_Node.Num) ; break; } x[i] = Geo_Node_P->x ; y[i] = Geo_Node_P->y ; z[i] = Geo_Node_P->z ; } } /* ------------------------------------------------------------------------ */ /* G e o _ S e t N o d e s C o o r d i n a t e s */ /* ------------------------------------------------------------------------ */ void Geo_SetNodesCoordinates(int Nbr_Node, int * Num_Node, double * x, double * y, double * z) { int i ; struct Geo_Node Geo_Node, * Geo_Node_P ; for (i = 0 ; i < Nbr_Node ; i++) { Geo_Node.Num = abs(Num_Node[i]) ; if(!(Geo_Node_P = (struct Geo_Node*) List_PQuery(CurrentGeoData->Nodes, &Geo_Node, fcmp_Nod))){ Message::Error("Node %d does not exist", Geo_Node.Num) ; break; } Geo_Node_P->x = x[i] ; Geo_Node_P->y = y[i] ; Geo_Node_P->z = z[i] ; } } void Geo_SetNodesCoordinatesX(int Nbr_Node, int * Num_Node, double *x) { int i ; struct Geo_Node Geo_Node, * Geo_Node_P ; for (i = 0 ; i < Nbr_Node ; i++) { Geo_Node.Num = abs(Num_Node[i]) ; if(!(Geo_Node_P = (struct Geo_Node*) List_PQuery(CurrentGeoData->Nodes, &Geo_Node, fcmp_Nod))){ Message::Error("Node %d does not exist", Geo_Node.Num) ; break; } Geo_Node_P->x = x[i] ; } } void Geo_SetNodesCoordinatesY(int Nbr_Node, int * Num_Node, double *y) { int i ; struct Geo_Node Geo_Node, * Geo_Node_P ; for (i = 0 ; i < Nbr_Node ; i++) { Geo_Node.Num = abs(Num_Node[i]) ; if(!(Geo_Node_P = (struct Geo_Node*) List_PQuery(CurrentGeoData->Nodes, &Geo_Node, fcmp_Nod))){ Message::Error("Node %d does not exist", Geo_Node.Num) ; break; } Geo_Node_P->y = y[i] ; } } void Geo_SetNodesCoordinatesZ(int Nbr_Node, int * Num_Node, double *z) { int i ; struct Geo_Node Geo_Node, * Geo_Node_P ; for (i = 0 ; i < Nbr_Node ; i++) { Geo_Node.Num = abs(Num_Node[i]) ; if(!(Geo_Node_P = (struct Geo_Node*) List_PQuery(CurrentGeoData->Nodes, &Geo_Node, fcmp_Nod))){ Message::Error("Node %d does not exist", Geo_Node.Num) ; break; } Geo_Node_P->z = z[i] ; } } getdp-2.4.2-source/Legacy/Get_Geometry.h000644 001750 001750 00000006045 12166744450 021565 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _GET_GEOMETRY_H_ #define _GET_GEOMETRY_H_ #include "ProData.h" /* Get_Geometry & co */ /* ----------------- */ void Get_NodesCoordinatesOfElement(struct Element * Element) ; void Get_BFGeoElement(struct Element * Element, double u, double v, double w) ; void * Get_JacobianFunction (int Type_Jacobian, int Type_Element, int * Type_Dimension) ; void * Get_JacobianFunctionAuto (int Type_Element, int Dimension) ; void * Get_IntegrationFunctionAuto (int Type_Element, int Order, int *NumPoints) ; /* Jacobian */ /* -------- */ #define JACOBIAN_ARG struct Element * Element, MATRIX3x3 * Jac /* Vol */ double JacobianVol0D (JACOBIAN_ARG); double JacobianVol1D (JACOBIAN_ARG); double JacobianVol2D (JACOBIAN_ARG); double JacobianVolSphShell2D (JACOBIAN_ARG); double JacobianVolRectShell2D (JACOBIAN_ARG); double JacobianVolPlpdX2D (JACOBIAN_ARG); double JacobianVolAxi2D (JACOBIAN_ARG); double JacobianVolAxiSphShell2D (JACOBIAN_ARG); double JacobianVolAxiRectShell2D (JACOBIAN_ARG); double JacobianVolAxiPlpdX2D (JACOBIAN_ARG); double JacobianVolAxiSqu2D (JACOBIAN_ARG); double JacobianVolAxiSquSphShell2D (JACOBIAN_ARG); double JacobianVolAxiSquRectShell2D (JACOBIAN_ARG); double JacobianVol3D (JACOBIAN_ARG); double JacobianVolSphShell3D (JACOBIAN_ARG); double JacobianVolRectShell3D (JACOBIAN_ARG); /* Sur */ double JacobianSur2D (JACOBIAN_ARG); double JacobianSurSphShell2D (JACOBIAN_ARG); double JacobianSurRectShell2D (JACOBIAN_ARG); double JacobianSurAxi2D (JACOBIAN_ARG); double JacobianSur3D (JACOBIAN_ARG); /* Lin */ double JacobianLin3D (JACOBIAN_ARG); #undef JACOBIAN_ARG /* -------- */ void Get_InverseMatrix(int Type_Dimension, int Type_Element, double DetMat, MATRIX3x3 * Mat, MATRIX3x3 * InvMat) ; void Get_ProductMatrix(int Type_Dimension, MATRIX3x3 * A, MATRIX3x3 * B, MATRIX3x3 * AB) ; /* -------- */ void *Get_ChangeOfCoordinates(int Flag_ChangeCoord, int Type_Form) ; void ChangeOfCoord_No1(struct Element * Element, double vBFu[], double vBFx[]) ; void ChangeOfCoord_No123(struct Element * Element, double vBFu[], double vBFx[]) ; void ChangeOfCoord_Form1(struct Element * Element, double vBFu[], double vBFx[]) ; void ChangeOfCoord_Form2(struct Element * Element, double vBFu[], double vBFx[]) ; void ChangeOfCoord_Form3(struct Element * Element, double vBFu[], double vBFx[]) ; void ChangeOfCoord_Form1P(struct Element * Element, double vBFu[], double vBFx[]) ; void ChangeOfCoord_Form2P(struct Element * Element, double vBFu[], double vBFx[]) ; void ChangeOfCoord_Form1S(struct Element * Element, double vBFu[], double vBFx[]) ; /* -------- */ double Cal_Product123 (double v1[], double v2[]) ; double Cal_Product12 (double v1[], double v2[]) ; double Cal_Product3 (double v1[], double v2[]) ; double Cal_Product1 (double v1[], double v2[]) ; #endif getdp-2.4.2-source/Legacy/F_Coord.cpp000644 001750 001750 00000013720 12116424202 021020 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "ProData.h" #include "GeoData.h" #include "F.h" #include "Get_Geometry.h" #include "Message.h" extern struct CurrentData Current ; /* ------------------------------------------------------------------------ */ /* Get a Vector containing the current coordinates */ /* ------------------------------------------------------------------------ */ void F_CoordXYZ(F_ARG) { int i, k ; double X, Y, Z ; if(!Current.Element || Current.Element->Num == NO_ELEMENT){ X = Current.x ; Y = Current.y ; Z = Current.z ; } else{ Get_NodesCoordinatesOfElement(Current.Element) ; Get_BFGeoElement(Current.Element, Current.u, Current.v, Current.w) ; X = Y = Z = 0. ; for (i = 0 ; i < Current.Element->GeoElement->NbrNodes ; i++) { X += Current.Element->x[i] * Current.Element->n[i] ; Y += Current.Element->y[i] * Current.Element->n[i] ; Z += Current.Element->z[i] * Current.Element->n[i] ; } } if (Current.NbrHar == 1){ V->Val[0] = X ; V->Val[1] = Y ; V->Val[2] = Z ; } else { for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM* k ] = X ; V->Val[MAX_DIM* k +1] = Y ; V->Val[MAX_DIM* k +2] = Z ; V->Val[MAX_DIM*(k+1) ] = 0. ; V->Val[MAX_DIM*(k+1)+1] = 0. ; V->Val[MAX_DIM*(k+1)+2] = 0. ; } } V->Type = VECTOR ; } void F_CoordXYZS(F_ARG) { int k ; double X, Y, Z ; X = Current.xs ; Y = Current.ys ; Z = Current.zs ; if (Current.NbrHar == 1){ V->Val[0] = X ; V->Val[1] = Y ; V->Val[2] = Z ; } else { for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM* k ] = X ; V->Val[MAX_DIM* k +1] = Y ; V->Val[MAX_DIM* k +2] = Z ; V->Val[MAX_DIM*(k+1) ] = 0. ; V->Val[MAX_DIM*(k+1)+1] = 0. ; V->Val[MAX_DIM*(k+1)+2] = 0. ; } } V->Type = VECTOR ; } /* ------------------------------------------------------------------------ */ /* Get the X, Y or Z coordinate */ /* ------------------------------------------------------------------------ */ #define get_1_coord(name, coord) \ int i, k; \ double tmp; \ \ if(!Current.Element || Current.Element->Num == NO_ELEMENT){ \ tmp = Current.coord ; \ } \ else{ \ Get_NodesCoordinatesOfElement(Current.Element) ; \ Get_BFGeoElement(Current.Element, Current.u, Current.v, Current.w) ; \ tmp = 0. ; \ for (i = 0 ; i < Current.Element->GeoElement->NbrNodes ; i++) { \ tmp += Current.Element->coord[i] * Current.Element->n[i] ; \ } \ } \ if (Current.NbrHar == 1){ \ V->Val[0] = tmp ; \ } \ else { \ for (k = 0 ; k < Current.NbrHar ; k+=2) { \ V->Val[MAX_DIM* k ] = tmp ; \ V->Val[MAX_DIM*(k+1) ] = 0. ; \ } \ } \ V->Type = SCALAR ; void F_CoordX(F_ARG){ get_1_coord("F_CoordX",x) } void F_CoordY(F_ARG){ get_1_coord("F_CoordY",y) } void F_CoordZ(F_ARG){ get_1_coord("F_CoordZ",z) } #undef get_1_coord #define get_1_coord_source(name, coord) \ int k; \ double tmp; \ \ tmp = Current.coord ; \ if (Current.NbrHar == 1){ \ V->Val[0] = tmp ; \ } \ else { \ for (k = 0 ; k < Current.NbrHar ; k+=2) { \ V->Val[MAX_DIM* k ] = tmp ; \ V->Val[MAX_DIM*(k+1) ] = 0. ; \ } \ } \ V->Type = SCALAR ; void F_CoordXS(F_ARG){ get_1_coord_source("F_CoordXS",xs) } void F_CoordYS(F_ARG){ get_1_coord_source("F_CoordYS",ys) } void F_CoordZS(F_ARG){ get_1_coord_source("F_CoordZS",zs) } #undef get_1_coord_source /* ------------------------------------------------------------------------ */ /* a*X + b*Y + c*Z */ /* ------------------------------------------------------------------------ */ void F_aX_bY_cZ(F_ARG) { int k ; double X, Y, Z, tmp ; Geo_GetNodesCoordinates(1, &Current.NumEntity, &X, &Y, &Z) ; if (Current.NbrHar == 1){ V->Val[0] = Fct->Para[0] * X + Fct->Para[1] * Y + Fct->Para[2] * Z ; } else { tmp = Fct->Para[0] * X + Fct->Para[1] * Y + Fct->Para[2] * Z ; for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM* k ] = tmp ; V->Val[MAX_DIM*(k+1) ] = 0. ; } } V->Type = SCALAR ; } /* ------------------------------------------------------------------------ */ /* a*(X2-X1) + b*(Y2-Y1) + c*(Z2-Z1) */ /* ------------------------------------------------------------------------ */ void F_aX21_bY21_cZ21 (F_ARG) { int k, * NumNodes ; double X1, Y1, Z1, X2, Y2, Z2, tmp ; if(!Current.Element || Current.Element->Num == NO_ELEMENT) Message::Error("No element on which to perform F_aX21_bY21_cZ21"); NumNodes = Geo_GetNodesOfEdgeInElement (Current.Element->GeoElement, Current.NumEntityInElement) ; Get_NodesCoordinatesOfElement(Current.Element) ; X1 = Current.Element->x[abs(NumNodes[0])-1] ; Y1 = Current.Element->y[abs(NumNodes[0])-1] ; Z1 = Current.Element->z[abs(NumNodes[0])-1] ; X2 = Current.Element->x[abs(NumNodes[1])-1] ; Y2 = Current.Element->y[abs(NumNodes[1])-1] ; Z2 = Current.Element->z[abs(NumNodes[1])-1] ; tmp = Fct->Para[0] * (X2-X1) + Fct->Para[1] * (Y2-Y1) + Fct->Para[2] * (Z2-Z1) ; if (Current.Element->GeoElement->NumEdges[Current.NumEntityInElement] < 0) tmp *= -1. ; if (Current.NbrHar == 1){ V->Val[0] = tmp ; } else { for (k = 0 ; k < Current.NbrHar ; k+=2) { V->Val[MAX_DIM* k ] = tmp ; V->Val[MAX_DIM*(k+1) ] = 0. ; } } V->Type = SCALAR ; } getdp-2.4.2-source/Legacy/F_DiffGeom.cpp000644 001750 001750 00000024165 12116424202 021437 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributed by Matti Pellikka . #include #include "GetDPConfig.h" #include "ProData.h" #include "F.h" #include "Cal_Value.h" #include "Message.h" // // Differential geometry operations on 3-dimensional manifold // // The user has the responsibility that the input values are in fact // coefficients of k-vector fields or differential k-forms on // 3-dimensional manifold in appropiate context // // Hodge operator of a k-form: // Arguments: // k-form coefficient vector // metric tensor coefficient matrix // // Parameters: // degree k of the form // // Output: // (3-k)-form coefficient vector // void F_Hodge(F_ARG) { int k; struct Value detS; struct Value *S; k = Fct->Para[0]; S = A+1; if( (A->Type != SCALAR && A->Type != VECTOR) || (S->Type != TENSOR_DIAG && S->Type != TENSOR_SYM && S->Type != TENSOR)) Message::Error("Wrong type of arguments for function 'Hodge'"); Cal_DetValue(S, &detS); detS.Val[0] = sqrt(fabs(detS.Val[0])); switch(k) { case 0: Cal_ProductValue(&detS, A, V); break; case 1: Cal_InvertValue(S, S); Cal_ProductValue(S, A, V); Cal_ProductValue(&detS, V, V); break; case 2: Cal_InvertValue(&detS, &detS); Cal_ProductValue(S, A, V); Cal_ProductValue(&detS, V, V); break; case 3: Cal_InvertValue(&detS, &detS); Cal_ProductValue(&detS, A, V); break; default: Message::Error("Invalid parameter for function 'Hodge'"); break; } } // Inner product of k-forms: // Arguments: // k-form coefficient vector // k-form coefficient vector // metric tensor coefficient matrix // // Parameters: // degree k of the forms // // Output: // scalar // void F_InnerProduct(F_ARG) { int k; struct Value detS; struct Value *S; struct Value *V1; struct Value *V2; k = Fct->Para[0]; V1 = A; V2 = A+1; S = A+2; if( (V1->Type != SCALAR && V1->Type != VECTOR) || (V2->Type != SCALAR && V2->Type != VECTOR) || (V2->Type != V1->Type) || (S->Type != TENSOR_DIAG && S->Type != TENSOR_SYM && S->Type != TENSOR)) Message::Error("Wrong type of arguments for function 'InnerProduct'"); switch(k) { case 0: Cal_CopyValue(V2, V); break; case 1: Cal_InvertValue(S, S); Cal_ProductValue(S, V2, V); break; case 2: Cal_InvertValue(&detS, &detS); Cal_ProductValue(S, V2, V); Cal_ProductValue(&detS, V, V); break; case 3: Cal_InvertValue(&detS, &detS); Cal_ProductValue(&detS, V2, V); break; default: Message::Error("Invalid parameter for function 'InnerProduct'"); break; } Cal_ProductValue(V1, V, V); } // Sharp operator of a k-form: // Arguments: // k-form coefficient vector // metric tensor coefficient matrix // // Parameters: // degree k of the form // // Output: // k-vector coefficient vector // void F_Sharp(F_ARG) { if( (A->Type != SCALAR && A->Type != VECTOR) || ((A+1)->Type != TENSOR_DIAG && (A+1)->Type != TENSOR_SYM && (A+1)->Type != TENSOR)) Message::Error("Wrong type of arguments for function 'Sharp'"); if( Fct->Para[0] > 3 || Fct->Para[0] < 0 ) Message::Error("Invalid parameter for function 'Sharp'"); Cal_InvertValue(A+1, A+1); F_Flat(Fct, A, V); } // Flat operator of a k-vector: // Arguments: // k-vector coefficient vector // metric tensor coefficient matrix // // Parameters: // degree k of the vector // // Output: // k-form coefficient vector // void F_Flat(F_ARG) { int k; struct Value detS; struct Value *S; k = Fct->Para[0]; S = A+1; if( (A->Type != SCALAR && A->Type != VECTOR) || (S->Type != TENSOR_DIAG && S->Type != TENSOR_SYM && S->Type != TENSOR)) Message::Error("Wrong type of arguments for function 'Flat'"); Cal_DetValue(S, &detS); detS.Val[0] = sqrt(fabs(detS.Val[0])); switch(k) { case 0: Cal_CopyValue(A, V); break; case 1: Cal_ProductValue(S, A, V); break; case 2: Cal_InvertValue(S, S); Cal_ProductValue(S, A, V); Cal_ProductValue(&detS, V, V); break; case 3: Cal_ProductValue(&detS, A, V); break; default: Message::Error("Invalid parameter for function 'Flat'"); break; } } // Wedge product of k-forms or k-vectors: // Arguments: // k1-form or k1-vector coefficient vector // k2-form or k2-vector coefficient vector // // Parameters: // degree k1 of the first argument // degree k2 of the second argument // // Output: // (k1+k2)-form or (k1+k2)-vector coefficient vector // void F_WedgeProduct(F_ARG) { int k1,k2; struct Value *V1; struct Value *V2; k1 = Fct->Para[0]; k2 = Fct->Para[0]; V1 = A; V2 = A+1; if( (V1->Type != SCALAR && V1->Type != VECTOR) || (V2->Type != SCALAR && V2->Type != VECTOR) ) Message::Error("Wrong type of arguments for function 'WedgeProduct'"); if(k1 < 0 || k1 > 3 || k2 < 0 || k2 > 3) Message::Error("Invalid parameter for function 'WedgeProduct'"); if( k1 == 0 || k2 == 0 || (k1 == 1 && k2 == 2) || (k1 == 2 && k2 == 1) ) Cal_ProductValue(V1, V2, V); else if( k1 == 1 && k2 == 1 ) Cal_CrossProductValue(V1, V2, V); else if( k1 + k2 > 3 ) Cal_ZeroValue(V); else Message::Error("Missing implementation in 'WedgeProduct'"); } void F_TensorProduct(F_ARG) { Message::Error("'TensorProduct' not implemented"); } // Interior product of a 1-vector and a k-form: // Arguments: // 1-vector coefficient vector // k-form coefficient vector // // Parameters: // degree k of the k-form // // Output: // (k-1)-form coefficient vector // void F_InteriorProduct(F_ARG) { int k; struct Value *V1; struct Value *V2; k = Fct->Para[0]; V1 = A; V2 = A+1; if( V1->Type != VECTOR || (V2->Type != SCALAR && V2->Type != VECTOR) ) Message::Error("Wrong type of arguments for function 'InteriorProduct'"); switch(k) { case 1: case 3: Cal_ProductValue(V1, V2, V); break; case 2: Cal_CrossProductValue(V1, V2, V); break; default: Message::Error("Invalid parameter for function 'InteriorProduct'"); break; } } // Pullback of a k-form: // Arguments: // k-form coefficient vector // Jacobian matrix of the transition map between charts of a manifold // // Parameters: // degree k of the form // // Output: // k-form coefficient vector // void F_PullBack(F_ARG) { if( (A->Type != SCALAR && A->Type != VECTOR) || ((A+1)->Type != TENSOR_DIAG && (A+1)->Type != TENSOR_SYM && (A+1)->Type != TENSOR)) Message::Error("Wrong type of arguments for function 'PullBack'"); if( Fct->Para[0] < 0 || Fct->Para[0] > 3 ) Message::Error("Invalid parameter for function 'PullBack'"); Cal_TransposeValue(A+1, A+1); F_PushForward(Fct, A, V); } // Pullback of a metric tensor: // Arguments: // metric tensor coefficient matrix // Jacobian matrix of the transition map between charts of a manifold // // Parameters: // none // // Output: // metric tensor coefficient matrix // void F_PullBackMetric(F_ARG) { struct Value *S; struct Value *J; J = A+1; S = A; if( (S->Type != TENSOR_DIAG && S->Type != TENSOR_SYM && S->Type != TENSOR) || (J->Type != TENSOR_DIAG && J->Type != TENSOR_SYM && J->Type != TENSOR)) Message::Error("Wrong type of arguments for function 'PullBackMetric'"); Cal_ProductValue(S, J, V); Cal_TransposeValue(J, J); Cal_ProductValue(J, V, V); } // Inverse pullback of a k-form: // Arguments: // k-form coefficient vector // Jacobian matrix of the transition map between charts of a manifold // // Parameters: // degree k of the form // // Output: // k-form coefficient vector // void F_InvPullBack(F_ARG) { if( (A->Type != SCALAR && A->Type != VECTOR) || ((A+1)->Type != TENSOR_DIAG && (A+1)->Type != TENSOR_SYM && (A+1)->Type != TENSOR)) Message::Error("Wrong type of arguments for function 'InvPullBack'"); if( Fct->Para[0] < 0 || Fct->Para[0] > 3 ) Message::Error("Invalid parameter for function 'InvPullBack'"); Cal_InvertValue(A+1, A+1); Cal_TransposeValue(A+1, A+1); F_PushForward(Fct, A, V); } // Pushforward of a k-vector: // Arguments: // k-vector coefficient vector // Jacobian matrix of the transition map between charts of a manifold // // Parameters: // degree k of the k-vector // // Output: // k-vector coefficient vector // void F_PushForward(F_ARG) { int k; struct Value *J; struct Value detJ; k = Fct->Para[0]; J = A+1; if( (A->Type != SCALAR && A->Type != VECTOR) || (J->Type != TENSOR_DIAG && J->Type != TENSOR_SYM && J->Type != TENSOR)) Message::Error("Wrong type of arguments for function 'PushForward'"); switch(k) { case 0: Cal_CopyValue(A, V); break; case 1: Cal_ProductValue(J, A, V); break; case 2: Cal_InvertValue(J, J); Cal_TransposeValue(J, J); Cal_DetValue(J, &detJ); Cal_ProductValue(J, A, V); Cal_ProductValue(&detJ, V, V); break; case 3: Cal_DetValue(J, &detJ); Cal_ProductValue(&detJ, A, V); break; default: Message::Error("Invalid parameter for function 'PushForward'"); break; } } // Inverse pushforward of a k-vector: // Arguments: // k-vector coefficient vector // Jacobian matrix of the transition map between charts of a manifold // // Parameters: // degree k of the k-vector // // Output: // k-vector coefficient vector // void F_InvPushForward(F_ARG) { if( (A->Type != SCALAR && A->Type != VECTOR) || ((A+1)->Type != TENSOR_DIAG && (A+1)->Type != TENSOR_SYM && (A+1)->Type != TENSOR)) Message::Error("Wrong type of arguments for function 'InvPushForward'"); if( Fct->Para[0] < 0 || Fct->Para[0] > 3 ) Message::Error("Invalid parameter for function 'InvPushForward'"); Cal_InvertValue(A+1, A+1); F_PushForward(Fct, A, V); } getdp-2.4.2-source/Legacy/GeoData.h000644 001750 001750 00000011161 12116424202 020453 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _GEODATA_H_ #define _GEODATA_H_ #include "ListUtils.h" #include "TreeUtils.h" struct Grid{ int Init; List_T * Bricks; double Xmin, Xmax, Ymin, Ymax, Zmin, Zmax; int Nx, Ny, Nz; }; struct GeoData { int Num ; char * Name ; List_T * Nodes, * Elements ; int NbrElementsWithEdges, NbrElementsWithFacets ; int NumCurrentEdge, NumCurrentFacet ; Tree_T * EdgesXNodes , * FacetsXEdges ; Tree_T * NodesXElements ; Tree_T * Normals ; List_T * GroupForPRE ; double Xmin, Xmax, Ymin, Ymax, Zmin, Zmax ; double Dimension, CharacteristicLength ; struct Grid Grid; double * H, * P ; } ; int Geo_AddGeoData(List_T * GeoData_L, char * Name_MshFile, char * Name_DefaultMshFile, char * Name_AdaptFile, char * Name_DefaultAdaptFile) ; void Geo_InitGeoData(struct GeoData * GeoData_P, int Num, char * Name) ; void Geo_FreeGeoData(struct GeoData * GeoData_P) ; void Geo_SetCurrentGeoData(struct GeoData * GeoData_P) ; void Geo_OpenFile(char * Name, const char * Mode) ; void Geo_CloseFile(void) ; void Geo_ReadFile(struct GeoData * GeoData_P) ; void Geo_ReadFileAdapt(struct GeoData * GeoData_P) ; void Geo_SaveMesh(struct GeoData * GeoData_P, List_T * InitialList, char * FileName) ; int Geo_GetElementType(int Format, int Type); int Geo_GetElementTypeInv(int Format, int Type); int Geo_GetNbrGeoElements(void) ; struct Geo_Element * Geo_GetGeoElement(int Index_Element) ; int Geo_GetGeoElementIndex(struct Geo_Element * GeoElement) ; struct Geo_Element * Geo_GetGeoElementOfNum(int Num_Element) ; int Geo_GetNbrGeoNodes(void) ; struct Geo_Node * Geo_GetGeoNode(int Index_Node) ; struct Geo_Node * Geo_GetGeoNodeOfNum(int Num_Node) ; void Geo_GetNodesCoordinates(int Nbr_Node, int * Num_Node, double * x, double * y, double * z) ; void Geo_SetNodesCoordinates(int Nbr_Node, int * Num_Node, double * x, double * y, double * z) ; void Geo_SetNodesCoordinatesX(int Nbr_Node, int * Num_Node, double * x) ; void Geo_SetNodesCoordinatesY(int Nbr_Node, int * Num_Node, double * y) ; void Geo_SetNodesCoordinatesZ(int Nbr_Node, int * Num_Node, double * z) ; double * Geo_GetNodes_uvw(int Type, int *nbn) ; double * Geo_GetBarycenter_uvw(int Type) ; void Geo_CreateEdgesOfElement(struct Geo_Element * Geo_Element) ; int * Geo_GetNodesOfEdgeInElement(struct Geo_Element * Geo_Element, int Num_Edge) ; void Geo_CreateFacetsOfElement(struct Geo_Element * Geo_Element) ; int * Geo_GetNodesOfFacetInElement(struct Geo_Element * Geo_Element, int Num_Facet) ; int * Geo_GetIM_Den(int Type_Element, int * Nbe) ; int * Geo_GetIM_Dfe(int Type_Element, int * Nbf) ; int * Geo_GetIM_Dfn(int Type_Element, int * Nbf) ; int * Geo_GetIM_Den_Xp(int Type_Element, int *Nbe, int *Nbn) ; int * Geo_GetIM_Dfe_Xp(int Type_Element, int *Nbf, int *Nbe) ; void Geo_CreateEntitiesOfElement (int Nbr_Entities2, int * D_Element, int Geo_Element_NbrEntities1, int * Geo_Element_NumEntities1, int * Geo_Element_NbrEntities2, int ** Geo_Element_NumEntities2, int * Geo_NbrElementsWithEntities2, int * Geo_NumCurrentEntity2, Tree_T * Geo_Entities2XEntities1) ; void Geo_GenerateEdgesOfTree(List_T * InitialList, List_T * InitialSuppList, List_T ** ExtendedList) ; void Geo_GenerateFacetsOfTree(List_T * InitialList, List_T * InitialSuppList, List_T ** ExtendedList) ; void Geo_GenerateEdgesOfSubTree(List_T * InitialList, List_T * ExtendedList, Tree_T * EntitiesInTree_T) ; void Geo_GenerateFacetsOfSubTree(List_T * InitialList, List_T * ExtendedList, Tree_T * EntitiesInTree_T) ; void Geo_ChangeTreeIndex(void * a, void * b) ; int fcmp_GeoData_Name(const void * a, const void * b) ; int fcmp_Elm(const void * a, const void * b) ; int fcmp_Nod(const void * a, const void * b) ; int fcmp_E2XE1(const void * a, const void * b) ; void free_E2XE1(void * a, void * b) ; int fcmp_EXVector(const void * a, const void * b) ; void Geo_WriteFilePRE(struct GeoData * GeoData_P, List_T * Group_L) ; void Geo_ReadFilePRE(struct GeoData * GeoData_P, int NbrGeoData, List_T * Group_L) ; void Geo_WriteEntities2XEntities1(void * a, void * b) ; void Geo_AddGroupForPRE(int Num) ; void Geo_CreateNodesXElements(int NumNode, int InIndex, int *NbrElements, int **NumElements) ; void Geo_CreateNormal(int Type, double *x, double *y, double *z, double *N) ; void Geo_CreateNormalOfElement(struct Geo_Element *GeoElement, double *Normal) ; #endif getdp-2.4.2-source/Legacy/Get_Geometry.cpp000644 001750 001750 00000116130 12171526422 022106 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Patrick Lefevre // #include #include "GetDPConfig.h" #include "ProData.h" #include "ProDefine.h" #include "Get_Geometry.h" #include "GeoData.h" #include "BF.h" #include "Gauss.h" #include "Message.h" #define THESIGN(a) ((a)>=0 ? 1 : -1) #define SQU(a) ((a)*(a)) #define HYPOT(a,b) (sqrt((a)*(a)+(b)*(b))) /* ------------------------------------------------------------------------ */ /* G e t _ N o d e s C o o r d i n a t e s O f E l e m e n t */ /* ------------------------------------------------------------------------ */ void Get_NodesCoordinatesOfElement(struct Element * Element) { if (Element->NumLastElementForNodesCoordinates != Element->Num) { Element->NumLastElementForNodesCoordinates = Element->Num ; Geo_GetNodesCoordinates (Element->GeoElement->NbrNodes, Element->GeoElement->NumNodes, Element->x, Element->y, Element->z) ; } } /* ------------------------------------------------------------------------ */ /* G e t _ B F G e o E l e m e n t */ /* ------------------------------------------------------------------------ */ void Get_BFGeoElement(struct Element * Element, double u, double v, double w) { int i ; for (i = 0 ; i < Element->GeoElement->NbrNodes ; i++) { BF_Node (Element, i+1, u, v, w, &(Element->n[i])) ; BF_GradNode(Element, i+1, u, v, w, Element->dndu[i]) ; } } /* ------------------------------------------------------------------------ */ /* G e t _ J a c o b i a n F u n c t i o n */ /* ------------------------------------------------------------------------ */ void * Get_JacobianFunction (int Type_Jacobian, int Type_Element, int * Type_Dimension) { switch (Type_Jacobian) { case JACOBIAN_VOL : switch (Type_Element) { case POINT : *Type_Dimension = _0D ; return((void *)JacobianVol0D) ; case LINE : case LINE_2 : *Type_Dimension = _1D ; return((void *)JacobianVol1D) ; case TRIANGLE : case TRIANGLE_2 : case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N : *Type_Dimension = _2D ; return((void *)JacobianVol2D) ; case TETRAHEDRON : case TETRAHEDRON_2 : case HEXAHEDRON : case HEXAHEDRON_2 : case PRISM : case PRISM_2 : case PYRAMID : case PYRAMID_2 : *Type_Dimension = _3D ; return((void *)JacobianVol3D) ; default : Message::Error("Unknown Jacobian Vol for Element Type (%s)", Get_StringForDefine(Element_Type, Type_Element)); } case JACOBIAN_VOL_SPH_SHELL : switch (Type_Element) { case TRIANGLE : case TRIANGLE_2 : case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N : *Type_Dimension = _2D ; return((void *)JacobianVolSphShell2D) ; case TETRAHEDRON : case TETRAHEDRON_2 : case HEXAHEDRON : case HEXAHEDRON_2 : case PRISM : case PRISM_2 : case PYRAMID : case PYRAMID_2 : *Type_Dimension = _3D ; return((void *)JacobianVolSphShell3D) ; default : Message::Error("Unknown Jacobian VolSphShell for Element Type (%s)", Get_StringForDefine(Element_Type, Type_Element)); } case JACOBIAN_VOL_RECT_SHELL : switch (Type_Element) { case TRIANGLE : case TRIANGLE_2 : case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N : *Type_Dimension = _2D ; return((void *)JacobianVolRectShell2D) ; case TETRAHEDRON : case TETRAHEDRON_2 : case HEXAHEDRON : case HEXAHEDRON_2 : case PRISM : case PRISM_2 : case PYRAMID : case PYRAMID_2 : *Type_Dimension = _3D ; return((void *)JacobianVolRectShell3D) ; default : Message::Error("Unknown Jacobian VolRectShell for Element Type (%s)", Get_StringForDefine(Element_Type, Type_Element)); } case JACOBIAN_VOL_PLPD_X : switch (Type_Element) { case TRIANGLE : case TRIANGLE_2 : case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N : *Type_Dimension = _2D ; return((void *)JacobianVolPlpdX2D) ; default : Message::Error("Unknown Jacobian VolPlpdX for Element Type (%s)", Get_StringForDefine(Element_Type, Type_Element)); } case JACOBIAN_VOL_AXI : switch (Type_Element) { case TRIANGLE : case TRIANGLE_2 : case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N : *Type_Dimension = _2D ; return((void *)JacobianVolAxi2D) ; default : Message::Error("Unknown Jacobian VolAxi for Element Type (%s)", Get_StringForDefine(Element_Type, Type_Element)); } case JACOBIAN_VOL_AXI_SPH_SHELL : switch (Type_Element) { case TRIANGLE : case TRIANGLE_2 : case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N : *Type_Dimension = _2D ; return((void *)JacobianVolAxiSphShell2D) ; default : Message::Error("Unknown Jacobian VolAxiSphShell for Element Type (%s)", Get_StringForDefine(Element_Type, Type_Element)); } case JACOBIAN_VOL_AXI_RECT_SHELL : switch (Type_Element) { case TRIANGLE : case TRIANGLE_2 : case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N : *Type_Dimension = _2D ; return((void *)JacobianVolAxiRectShell2D) ; default : Message::Error("Unknown Jacobian VolAxiRectShell for Element Type (%s)", Get_StringForDefine(Element_Type, Type_Element)); } case JACOBIAN_VOL_AXI_PLPD_X : switch (Type_Element) { case TRIANGLE : case TRIANGLE_2 : case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N : *Type_Dimension = _2D ; return((void *)JacobianVolAxiPlpdX2D) ; default : Message::Error("Unknown Jacobian VolAxiPlpdX for Element Type (%s)", Get_StringForDefine(Element_Type, Type_Element)); } case JACOBIAN_VOL_AXI_SQU : switch (Type_Element) { case TRIANGLE : case TRIANGLE_2 : case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N : *Type_Dimension = _2D ; return((void *)JacobianVolAxiSqu2D) ; default : Message::Error("Unknown Jacobian VolAxiSqu for Element Type (%s)", Get_StringForDefine(Element_Type, Type_Element)); } case JACOBIAN_VOL_AXI_SQU_SPH_SHELL : switch (Type_Element) { case TRIANGLE : case TRIANGLE_2 : case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N : *Type_Dimension = _2D ; return((void *)JacobianVolAxiSquSphShell2D) ; default : Message::Error("Unknown Jacobian VolAxiSquSphShell for Element Type (%s)", Get_StringForDefine(Element_Type, Type_Element)); } case JACOBIAN_VOL_AXI_SQU_RECT_SHELL : switch (Type_Element) { case TRIANGLE : case TRIANGLE_2 : case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N : *Type_Dimension = _2D ; return((void *)JacobianVolAxiSquRectShell2D) ; default : Message::Error("Unknown Jacobian VolAxiSquRectShell for Element Type (%s)", Get_StringForDefine(Element_Type, Type_Element)); } case JACOBIAN_SUR : switch (Type_Element) { case POINT : *Type_Dimension = _1D ; return((void *)JacobianVol0D) ; case LINE : case LINE_2 : *Type_Dimension = _2D ; return((void *)JacobianSur2D) ; case TRIANGLE : case TRIANGLE_2 : case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N : *Type_Dimension = _3D ; return((void *)JacobianSur3D) ; default : Message::Error("Unknown Jacobian Sur for element Type (%s)", Get_StringForDefine(Element_Type, Type_Element)); } case JACOBIAN_SUR_SPH_SHELL : switch (Type_Element) { case LINE : case LINE_2 : *Type_Dimension = _2D ; return((void *)JacobianSurSphShell2D) ; default : Message::Error("Unknown Jacobian SurSphShell for element Type (%s)", Get_StringForDefine(Element_Type, Type_Element)); } case JACOBIAN_SUR_AXI : switch (Type_Element) { case LINE : case LINE_2 : *Type_Dimension = _2D ; return((void *)JacobianSurAxi2D) ; default : Message::Error("Unknown Jacobian SurAxi for Element Type (%s)", Get_StringForDefine(Element_Type, Type_Element)); } case JACOBIAN_LIN : switch (Type_Element) { case POINT : *Type_Dimension = _2D ; return((void *)JacobianVol0D) ; case LINE : case LINE_2 : *Type_Dimension = _3D ; return((void *)JacobianLin3D) ; default : Message::Error("Unknown Jacobian Lin for Element Type (%s)", Get_StringForDefine(Element_Type, Type_Element)); } default : Message::Error("Unknown Jacobian"); return(NULL) ; } } /* ------------------------------------------------------------------------ */ /* G e t _ J a c o b i a n F u n c t i o n A u t o */ /* ------------------------------------------------------------------------ */ void * Get_JacobianFunctionAuto (int Type_Element, int Dimension) { switch(Type_Element){ case POINT : return((void *)JacobianVol0D) ; case LINE : case LINE_2 : switch(Dimension){ case _3D : return((void *)JacobianLin3D) ; case _2D : return((void *)JacobianSur2D) ; default : return((void *)JacobianVol1D) ; } case TRIANGLE : case TRIANGLE_2 : case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N : switch(Dimension){ case _3D : return((void *)JacobianSur3D) ; default : return((void *)JacobianVol2D) ; } case TETRAHEDRON : case TETRAHEDRON_2 : case HEXAHEDRON : case HEXAHEDRON_2 : case PRISM : case PRISM_2 : case PYRAMID : case PYRAMID_2 : default: return((void *)JacobianVol3D) ; } } /* ------------------------------------------------------------------------ */ /* G e t _ I n t e g r a t i o n F u n c t i o n A u t o */ /* ------------------------------------------------------------------------ */ void * Get_IntegrationFunctionAuto (int Type_Element, int Order, int *NumPoints) { // TODO : compute correct number of points switch(Type_Element){ case POINT : *NumPoints = 1; return ((void *)Gauss_Point) ; case LINE : case LINE_2 : *NumPoints = 3; return ((void *)Gauss_Line) ; case TRIANGLE : case TRIANGLE_2 : *NumPoints = 6; return ((void*)Gauss_Triangle) ; case QUADRANGLE : case QUADRANGLE_2 : case QUADRANGLE_2_8N : *NumPoints = 7; return ((void*)Gauss_Quadrangle) ; case TETRAHEDRON : case TETRAHEDRON_2 : *NumPoints = 15; return ((void*)Gauss_Tetrahedron) ; case HEXAHEDRON : case HEXAHEDRON_2 : *NumPoints = 34; return ((void*)Gauss_Hexahedron) ; case PRISM : case PRISM_2 : *NumPoints = 21; return ((void*)Gauss_Prism) ; case PYRAMID : case PYRAMID_2 : *NumPoints = 8; return ((void*)Gauss_Pyramid) ; default: Message::Error("Unknown type of element for integration function"); return 0; } } /* ------------------------------------------------------------------------ */ /* G e o m e t r i c a l T r a n s f o r m a t i o n s */ /* ------------------------------------------------------------------------ */ double PlpdX2D (struct Element * Element, MATRIX3x3 * Jac) { int i ; double CoorX, CoorY, A, B, R, theta, f ; double DetJac ; CoorX = CoorY = 0. ; for (i = 0 ; i < Element->GeoElement->NbrNodes ; i++) { CoorX += Element->x[i] * Element->n[i] ; CoorY += Element->y[i] * Element->n[i] ; } A = Element->JacobianCase->Para[0] ; B = Element->JacobianCase->Para[1] ; R = CoorX ; if ( (R > B+1.e-12*B) || (R < A-1.e-12*A) ) Message::Error("Bad parameters for unidirectional transformation Jacobian: " "Rint=%g, Rext=%g, R=%g", A, B, R) ; if (B == R) { Jac->c11 = 1. ; Jac->c12 = 0. ; Jac->c21 = 0. ; Jac->c22 = 1. ; return(1.) ; } f = (A*(B-A)) / (R*(B-R)) ; theta = (B-2.*R) / (B-R) ; Jac->c11 = f * (1.- theta) ; Jac->c12 = 0. ; Jac->c21 = 0. ; Jac->c22 = 1. ; DetJac = f*( 1.-theta) ; return(DetJac) ; } double power(double x, double y) { if (y == 1.0) return (x); else if (y == 2.0) return (x*x); else if (y == 0.5) return (sqrt(x)); else return (pow(x,y)); } double Transformation (int Dim, int Type, struct Element * Element, MATRIX3x3 * Jac) { int i, Axis = 0 ; double X = 0., Y = 0., Z = 0. ; double p = 1., L= 0. ; double Cx = 0., Cy = 0., Cz = 0., A = 0., B = 0., R = 0. ; double theta, XR, YR, ZR, f, dRdx = 0., dRdy = 0., dRdz = 0. ; double DetJac ; /* A = interior radius B = exterior radius Cx, Cy, Cz = coord of centre Axis = direction of the transformation p = exponant 1/L = f(B) */ for (i = 0 ; i < Element->GeoElement->NbrNodes ; i++) { X += Element->x[i] * Element->n[i] ; Y += Element->y[i] * Element->n[i] ; Z += Element->z[i] * Element->n[i] ; } if(Element->JacobianCase->NbrParameters >= 2){ A = Element->JacobianCase->Para[0] ; B = Element->JacobianCase->Para[1] ; } else Message::Error("Missing interior and/or exterior radius for transformation Jacobian"); if(Type == JACOBIAN_RECT){ if(Element->JacobianCase->NbrParameters >= 3) Axis = (int)Element->JacobianCase->Para[2] ; if(Element->JacobianCase->NbrParameters >= 6){ Cx = Element->JacobianCase->Para[3] ; Cy = Element->JacobianCase->Para[4] ; Cz = Element->JacobianCase->Para[5] ; } if(Element->JacobianCase->NbrParameters >= 7) p = Element->JacobianCase->Para[6] ; if(Element->JacobianCase->NbrParameters >= 8) L = Element->JacobianCase->Para[7] ; if(Element->JacobianCase->NbrParameters >= 9){ Message::Error("Too many parameters for rectangular transformation Jacobian. " "Vvalid parameters: Radius1 Radius2 Axis CenterX CenterY CenterZ Power 1/Infinity"); } } else if(Type == JACOBIAN_SPH){ if(Element->JacobianCase->NbrParameters >= 5){ Cx = Element->JacobianCase->Para[2] ; Cy = Element->JacobianCase->Para[3] ; Cz = Element->JacobianCase->Para[4] ; } if(Element->JacobianCase->NbrParameters >= 6) p = Element->JacobianCase->Para[5] ; if(Element->JacobianCase->NbrParameters >= 7) L = Element->JacobianCase->Para[6] ; if(Element->JacobianCase->NbrParameters >= 8){ Message::Error("Too many parameters for spherical transformation Jacobian. " "Valid parameters: Radius1 Radius2 CenterX CenterY CenterZ Power 1/Infinity"); } } else Message::Error("Unknown type of transformation Jacobian"); if(L) B = (B*B-A*A*L)/(B-A*L); if(Type == JACOBIAN_SPH){ R = sqrt( SQU(X-Cx) + SQU(Y-Cy) + SQU(Z-Cz) ) ; dRdx = (X-Cx)/R ; dRdy = (Y-Cy)/R ; dRdz = (Z-Cz)/R ; } else{ switch(Axis) { case 1: R = fabs(X-Cx) ; dRdx =THESIGN(X-Cx) ; dRdy =0.0 ; dRdz =0.0 ; break; case 2: R = fabs(Y-Cy) ; dRdx =0.0 ; dRdy =THESIGN(Y-Cy) ; dRdz =0.0 ; break; case 3: R = fabs(Z-Cz) ; dRdx =0.0 ; dRdy =0.0 ; dRdz =THESIGN(Z-Cz) ; break; default: Message::Error("Bad axis specification: 1 for X, 2 for Y and 3 for Z"); } } if ( (fabs(R) > fabs(B) + 1.e-2*fabs(B)) || (fabs(R) < fabs(A) - 1.e-2*fabs(A)) ) Message::Error("Bad parameters for transformation Jacobian: %g not in [%g,%g]", R, A, B) ; if (B == R) { Jac->c11 = 1. ; Jac->c12 = 0. ; Jac->c13 = 0. ; Jac->c21 = 0. ; Jac->c22 = 1. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = 1. ; return(1.) ; } f = power((A*(B-A))/(R*(B-R)), p) ; theta = p * (B-2.*R) / (B-R) ; XR = (X-Cx)/R ; YR = (Y-Cy)/R ; ZR = (Z-Cz)/R ; Jac->c11 = f * (1.0 - theta * XR * dRdx) ; Jac->c12 = f * ( - theta * XR * dRdy) ; Jac->c13 = f * ( - theta * XR * dRdz) ; Jac->c21 = f * ( - theta * YR * dRdx) ; Jac->c22 = f * (1.0 - theta * YR * dRdy) ; Jac->c23 = f * ( - theta * YR * dRdz) ; Jac->c31 = f * ( - theta * ZR * dRdx) ; Jac->c32 = f * ( - theta * ZR * dRdy) ; Jac->c33 = f * (1.0 - theta * ZR * dRdz) ; switch (Dim) { case _2D : Jac->c33 = 1. ; DetJac = f * f * (1.0 - theta) ; /* DetJac = Jac->c11 * Jac->c22 - Jac->c12 * Jac->c21; */ break; case _AXI : DetJac = f * f * f * (1.0 - theta) ; break; default : DetJac = f * f * f * (1.0 - theta); /* DetJac = Jac->c11 * (Jac->c22 * Jac->c33 - Jac->c23*Jac->c32) - Jac->c12 * (Jac->c21 * Jac->c33 - Jac->c23*Jac->c31) + Jac->c13 * (Jac->c21 * Jac->c32 - Jac->c22*Jac->c31); */ break ; } return(DetJac) ; } /* ------------------------------------------------------------------------ */ /* J a c o b i a n V o l */ /* ------------------------------------------------------------------------ */ /* 0D */ double JacobianVol0D (struct Element * Element, MATRIX3x3 * Jac) { Jac->c11 = 1. ; Jac->c12 = 0. ; Jac->c13 = 0. ; Jac->c21 = 0. ; Jac->c22 = 1. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = 1. ; return(1.) ; } /* 1D */ double JacobianVol1D (struct Element * Element, MATRIX3x3 * Jac) { int i ; double DetJac ; Jac->c11 = 0. ; Jac->c12 = 0. ; Jac->c13 = 0. ; Jac->c21 = 0. ; Jac->c22 = 1. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = 1. ; for ( i = 0 ; i < Element->GeoElement->NbrNodes ; i++ ) { Jac->c11 += Element->x[i] * Element->dndu[i][0] ; } DetJac = Jac->c11 ; return(DetJac) ; } /* 2D */ double JacobianVol2D (struct Element * Element, MATRIX3x3 * Jac) { int i ; double DetJac ; Jac->c11 = 0. ; Jac->c12 = 0. ; Jac->c13 = 0. ; Jac->c21 = 0. ; Jac->c22 = 0. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = 1. ; for ( i = 0 ; i < Element->GeoElement->NbrNodes ; i++ ) { Jac->c11 += Element->x[i] * Element->dndu[i][0] ; Jac->c21 += Element->x[i] * Element->dndu[i][1] ; Jac->c12 += Element->y[i] * Element->dndu[i][0] ; Jac->c22 += Element->y[i] * Element->dndu[i][1] ; } DetJac = Jac->c11 * Jac->c22 - Jac->c12 * Jac->c21 ; return(DetJac) ; } double JacobianVolSphShell2D (struct Element * Element, MATRIX3x3 * Jac) { MATRIX3x3 Jac1, Jac2 ; double DetJac1, DetJac2 ; DetJac1 = JacobianVol2D (Element, &Jac1) ; DetJac2 = Transformation(_2D, JACOBIAN_SPH, Element, &Jac2) ; Get_ProductMatrix( _2D, &Jac1, &Jac2, Jac) ; Jac->c13 = 0. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = 1. ; return(DetJac1 * DetJac2) ; } double JacobianVolRectShell2D (struct Element * Element, MATRIX3x3 * Jac) { MATRIX3x3 Jac1, Jac2 ; double DetJac1, DetJac2 ; DetJac1 = JacobianVol2D (Element, &Jac1) ; DetJac2 = Transformation (_2D, JACOBIAN_RECT, Element, &Jac2) ; Get_ProductMatrix( _2D, &Jac1, &Jac2, Jac) ; Jac->c13 = 0. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = 1. ; return(DetJac1 * DetJac2) ; } double JacobianVolPlpdX2D (struct Element * Element, MATRIX3x3 * Jac) { MATRIX3x3 Jac1, Jac2 ; double DetJac1, DetJac2 ; DetJac1 = JacobianVol2D (Element, &Jac1) ; DetJac2 = PlpdX2D (Element, &Jac2) ; Get_ProductMatrix( _2D, &Jac1, &Jac2, Jac) ; Jac->c13 = 0. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = 1. ; return(DetJac1 * DetJac2) ; } /* 2D Axi (Attention, l'axe doit etre x=z=0) */ double JacobianVolAxi2D (struct Element * Element, MATRIX3x3 * Jac) { int i ; double s = 0., DetJac ; DetJac = JacobianVol2D(Element, Jac) ; for (i = 0 ; i < Element->GeoElement->NbrNodes ; i++) s += Element->x[i] * Element->n[i] ; /* Warning! For evaluations on the symmetry axis */ if (s==0.0) { for (i = 0 ; i < Element->GeoElement->NbrNodes ; i++) s += Element->x[i] ; s /= (double)Element->GeoElement->NbrNodes ; } Jac->c33 = s ; return(DetJac * Jac->c33) ; } double JacobianVolAxiSphShell2D (struct Element * Element, MATRIX3x3 * Jac) { MATRIX3x3 Jac1, Jac2 ; double DetJac1, DetJac2 ; DetJac1 = JacobianVolAxi2D (Element, &Jac1) ; DetJac2 = Transformation (_AXI, JACOBIAN_SPH, Element, &Jac2) ; Get_ProductMatrix( _2D, &Jac1, &Jac2, Jac) ; Jac->c13 = 0. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = Jac1.c33 * Jac2.c33 ; return(DetJac1 * DetJac2) ; } double JacobianVolAxiRectShell2D (struct Element * Element, MATRIX3x3 * Jac) { MATRIX3x3 Jac1, Jac2 ; double DetJac1, DetJac2 ; DetJac1 = JacobianVolAxi2D (Element, &Jac1) ; DetJac2 = Transformation (_AXI, JACOBIAN_RECT, Element, &Jac2) ; Get_ProductMatrix( _2D, &Jac1, &Jac2, Jac) ; Jac->c13 = 0. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = Jac1.c33 * Jac2.c33 ; return(DetJac1 * DetJac2) ; } double JacobianVolAxiPlpdX2D (struct Element * Element, MATRIX3x3 * Jac) { MATRIX3x3 Jac1, Jac2 ; double DetJac1, DetJac2 ; DetJac1 = JacobianVolAxi2D (Element, &Jac1) ; DetJac2 = PlpdX2D (Element, &Jac2) ; Get_ProductMatrix( _2D, &Jac1, &Jac2, Jac) ; Jac->c13 = 0. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = Jac1.c33 ; return(DetJac1 * DetJac2) ; } /* 2D Axi avec transformation quadratique (Attention, l'axe doit etre x=z=0) */ double JacobianVolAxiSqu2D (struct Element * Element, MATRIX3x3 * Jac) { int i ; double s = 0., r, DetJac ; Jac->c11 = 0. ; Jac->c12 = 0. ; Jac->c13 = 0. ; Jac->c21 = 0. ; Jac->c22 = 0. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = 1. ; for (i = 0 ; i < Element->GeoElement->NbrNodes ; i++) s += SQU(Element->x[i]) * Element->n[i] ; /* Warning! For evaluations on the symmetry axis */ if (s==0.0) { for (i = 0 ; i < Element->GeoElement->NbrNodes ; i++) s += Element->x[i] * Element->x[i] ; s /= (double)Element->GeoElement->NbrNodes ; } r = sqrt(s); for ( i = 0 ; i < Element->GeoElement->NbrNodes ; i++ ) { Jac->c11 += 0.5/r * SQU(Element->x[i]) * Element->dndu[i][0] ; Jac->c21 += 0.5/r * SQU(Element->x[i]) * Element->dndu[i][1] ; Jac->c12 += Element->y[i] * Element->dndu[i][0] ; Jac->c22 += Element->y[i] * Element->dndu[i][1] ; } Jac->c33 = r ; DetJac = (Jac->c11 * Jac->c22 - Jac->c12 * Jac->c21) * Jac->c33 ; return(DetJac) ; } double JacobianVolAxiSquSphShell2D (struct Element * Element, MATRIX3x3 * Jac) { MATRIX3x3 Jac1, Jac2 ; double DetJac1, DetJac2 ; DetJac1 = JacobianVolAxiSqu2D(Element, &Jac1) ; DetJac2 = Transformation (_AXI, JACOBIAN_SPH, Element, &Jac2) ; Get_ProductMatrix( _2D, &Jac1, &Jac2, Jac) ; Jac->c13 = 0. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = Jac1.c33 * Jac2.c33 ; return(DetJac1 * DetJac2) ; } double JacobianVolAxiSquRectShell2D (struct Element * Element, MATRIX3x3 * Jac) { MATRIX3x3 Jac1, Jac2 ; double DetJac1, DetJac2 ; DetJac1 = JacobianVolAxiSqu2D(Element, &Jac1) ; DetJac2 = Transformation (_AXI, JACOBIAN_RECT, Element, &Jac2) ; Get_ProductMatrix( _2D, &Jac1, &Jac2, Jac) ; Jac->c13 = 0. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = Jac1.c33 * Jac2.c33 ; return(DetJac1 * DetJac2) ; } /* 3D */ double JacobianVol3D (struct Element * Element, MATRIX3x3 * Jac) { int i ; double DetJac ; Jac->c11 = 0. ; Jac->c12 = 0. ; Jac->c13 = 0. ; Jac->c21 = 0. ; Jac->c22 = 0. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = 0. ; for ( i = 0 ; i < Element->GeoElement->NbrNodes ; i++ ) { Jac->c11 += Element->x[i] * Element->dndu[i][0] ; Jac->c21 += Element->x[i] * Element->dndu[i][1] ; Jac->c31 += Element->x[i] * Element->dndu[i][2] ; Jac->c12 += Element->y[i] * Element->dndu[i][0] ; Jac->c22 += Element->y[i] * Element->dndu[i][1] ; Jac->c32 += Element->y[i] * Element->dndu[i][2] ; Jac->c13 += Element->z[i] * Element->dndu[i][0] ; Jac->c23 += Element->z[i] * Element->dndu[i][1] ; Jac->c33 += Element->z[i] * Element->dndu[i][2] ; } DetJac = Jac->c11 * Jac->c22 * Jac->c33 + Jac->c13 * Jac->c21 * Jac->c32 + Jac->c12 * Jac->c23 * Jac->c31 - Jac->c13 * Jac->c22 * Jac->c31 - Jac->c11 * Jac->c23 * Jac->c32 - Jac->c12 * Jac->c21 * Jac->c33 ; return(DetJac) ; } double JacobianVolSphShell3D (struct Element * Element, MATRIX3x3 * Jac) { MATRIX3x3 Jac1, Jac2 ; double DetJac1, DetJac2 ; DetJac1 = JacobianVol3D (Element, &Jac1) ; DetJac2 = Transformation(_3D, JACOBIAN_SPH, Element, &Jac2) ; Get_ProductMatrix( _3D, &Jac1, &Jac2, Jac) ; return(DetJac1 * DetJac2) ; } double JacobianVolRectShell3D (struct Element * Element, MATRIX3x3 * Jac) { MATRIX3x3 Jac1, Jac2 ; double DetJac1, DetJac2 ; DetJac1 = JacobianVol3D (Element, &Jac1) ; DetJac2 = Transformation (_3D, JACOBIAN_RECT, Element, &Jac2) ; Get_ProductMatrix( _3D, &Jac1, &Jac2, Jac) ; return(DetJac1 * DetJac2) ; } /* ------------------------------------------------------------------------ */ /* J a c o b i a n S u r */ /* ------------------------------------------------------------------------ */ void prodve(double a[3], double b[3], double c[3]) { c[2] = a[0] * b[1] - a[1] * b[0]; c[1] = -a[0] * b[2] + a[2] * b[0]; c[0] = a[1] * b[2] - a[2] * b[1]; } void prosca(double a[3], double b[3], double *c) { *c = a[0] * b[0] + a[1] * b[1] + a[2] * b[2]; } double norm3(double a[3]) { return sqrt(a[0] * a[0] + a[1] * a[1] + a[2] * a[2]); } double norme(double a[3]) { const double mod = norm3(a); if(mod != 0.0){ const double one_over_mod = 1./mod; a[0] *= one_over_mod; a[1] *= one_over_mod; a[2] *= one_over_mod; } return mod; } double JacobianSur2D (struct Element * Element, MATRIX3x3 * Jac) { int i ; double DetJac ; Jac->c11 = 0. ; Jac->c12 = 0. ; Jac->c13 = 0. ; Jac->c21 = 0. ; Jac->c22 = 0. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = 1. ; for ( i = 0 ; i < Element->GeoElement->NbrNodes ; i++ ) { Jac->c11 += Element->x[i] * Element->dndu[i][0] ; Jac->c12 += Element->y[i] * Element->dndu[i][0] ; } DetJac = HYPOT(Jac->c11, Jac->c12) ; // regularize matrix double b[3] = {Jac->c12, -Jac->c11, 0.}; norme(b); Jac->c21 = b[0]; Jac->c22 = b[1]; // make sure DetJac > 0: this is not necessary in theory, but it is // required here because we use DetJac when we invert the matrix double realDetJac = Jac->c11 * Jac->c22 - Jac->c12 * Jac->c21; if(realDetJac < 0.){ Jac->c21 = - Jac->c21; Jac->c22 = - Jac->c22; } return(DetJac) ; } double JacobianSurSphShell2D (struct Element * Element, MATRIX3x3 * Jac) { MATRIX3x3 Jac1, Jac2 ; double DetJac1, DetJac2 ; DetJac1 = JacobianSur2D(Element, &Jac1) ; DetJac2 = Transformation(_2D, JACOBIAN_SPH, Element, &Jac2) ; Get_ProductMatrix(_3D, &Jac1, &Jac2, Jac) ; return(DetJac1 * DetJac2) ; } double JacobianSurRectShell2D (struct Element * Element, MATRIX3x3 * Jac) { MATRIX3x3 Jac1, Jac2 ; double DetJac1, DetJac2 ; DetJac1 = JacobianSur2D(Element, &Jac1) ; DetJac2 = Transformation(_2D, JACOBIAN_RECT, Element, &Jac2) ; Get_ProductMatrix( _3D, &Jac1, &Jac2, Jac) ; return(DetJac1 * DetJac2) ; } double JacobianSurAxi2D (struct Element * Element, MATRIX3x3 * Jac) { int i ; double DetJac ; DetJac = JacobianSur2D(Element, Jac) ; Jac->c33 = 0. ; for (i = 0 ; i < Element->GeoElement->NbrNodes ; i++) Jac->c33 += Element->x[i] * Element->n[i] ; return(DetJac * Jac->c33) ; } double JacobianSur3D (struct Element * Element, MATRIX3x3 * Jac) { int i ; double DetJac ; Jac->c11 = 0. ; Jac->c12 = 0. ; Jac->c13 = 0. ; Jac->c21 = 0. ; Jac->c22 = 0. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = 0. ; for ( i = 0 ; i < Element->GeoElement->NbrNodes ; i++ ) { Jac->c11 += Element->x[i] * Element->dndu[i][0] ; Jac->c21 += Element->x[i] * Element->dndu[i][1] ; Jac->c12 += Element->y[i] * Element->dndu[i][0] ; Jac->c22 += Element->y[i] * Element->dndu[i][1] ; Jac->c13 += Element->z[i] * Element->dndu[i][0] ; Jac->c23 += Element->z[i] * Element->dndu[i][1] ; } DetJac = sqrt( SQU(Jac->c11 * Jac->c22 - Jac->c12 * Jac->c21) + SQU(Jac->c13 * Jac->c21 - Jac->c11 * Jac->c23) + SQU(Jac->c12 * Jac->c23 - Jac->c13 * Jac->c22) ) ; // regularize matrix double a[3] = {Jac->c11, Jac->c12, Jac->c13}; double b[3] = {Jac->c21, Jac->c22, Jac->c23}; double c[3]; prodve(a, b, c); norme(c); Jac->c31 = c[0]; Jac->c32 = c[1]; Jac->c33 = c[2]; // make sure DetJac > 0: this is not necessary in theory, but it is // required here because we use DetJac when we invert the matrix double realDetJac = Jac->c11 * Jac->c22 * Jac->c33 + Jac->c13 * Jac->c21 * Jac->c32 + Jac->c12 * Jac->c23 * Jac->c31 - Jac->c13 * Jac->c22 * Jac->c31 - Jac->c11 * Jac->c23 * Jac->c32 - Jac->c12 * Jac->c21 * Jac->c33; if(realDetJac < 0.){ Jac->c31 = - Jac->c31; Jac->c32 = - Jac->c32; Jac->c33 = - Jac->c33; } return(DetJac) ; } /* ------------------------------------------------------------------------ */ /* J a c o b i a n L i n */ /* ------------------------------------------------------------------------ */ double JacobianLin3D (struct Element * Element, MATRIX3x3 * Jac) { int i ; double DetJac ; Jac->c11 = 0. ; Jac->c12 = 0. ; Jac->c13 = 0. ; Jac->c21 = 0. ; Jac->c22 = 0. ; Jac->c23 = 0. ; Jac->c31 = 0. ; Jac->c32 = 0. ; Jac->c33 = 0. ; for ( i = 0 ; i < Element->GeoElement->NbrNodes ; i++ ) { Jac->c11 += Element->x[i] * Element->dndu[i][0] ; Jac->c12 += Element->y[i] * Element->dndu[i][0] ; Jac->c13 += Element->z[i] * Element->dndu[i][0] ; } DetJac = sqrt(SQU(Jac->c11)+SQU(Jac->c12)+SQU(Jac->c13)) ; // regularize matrix double a[3] = {Jac->c11, Jac->c12, Jac->c13}; double b[3]; if((fabs(a[0]) >= fabs(a[1]) && fabs(a[0]) >= fabs(a[2])) || (fabs(a[1]) >= fabs(a[0]) && fabs(a[1]) >= fabs(a[2]))) { b[0] = a[1]; b[1] = -a[0]; b[2] = 0.; } else { b[0] = 0.; b[1] = a[2]; b[2] = -a[1]; } norme(b); double c[3]; prodve(a, b, c); norme(c); Jac->c21 = b[0]; Jac->c22 = b[1]; Jac->c23 = b[2]; Jac->c31 = c[0]; Jac->c32 = c[1]; Jac->c33 = c[2]; // make sure DetJac > 0: this is not necessary in theory, but it is // required here because we use DetJac when we invert the matrix double realDetJac = Jac->c11 * Jac->c22 * Jac->c33 + Jac->c13 * Jac->c21 * Jac->c32 + Jac->c12 * Jac->c23 * Jac->c31 - Jac->c13 * Jac->c22 * Jac->c31 - Jac->c11 * Jac->c23 * Jac->c32 - Jac->c12 * Jac->c21 * Jac->c33; if(realDetJac < 0.){ Jac->c31 = - Jac->c31; Jac->c32 = - Jac->c32; Jac->c33 = - Jac->c33; } return(DetJac) ; } /* ------------------------------------------------------------------------ */ /* G e t _ I n v e r s e M a t r i x */ /* ------------------------------------------------------------------------ */ void Get_InverseMatrix(int Type_Dimension, int Type_Element, double DetMat, MATRIX3x3 * Mat, MATRIX3x3 * InvMat) { switch (Type_Dimension) { case _0D : InvMat->c11 = InvMat->c22 = InvMat->c33 = 1. ; InvMat->c12 = InvMat->c21 = 0. ; InvMat->c13 = InvMat->c31 = 0. ; InvMat->c23 = InvMat->c32 = 0. ; break ; case _1D : InvMat->c11 = 1. / Mat->c11 ; InvMat->c22 = 1. / Mat->c22 ; InvMat->c33 = 1. / Mat->c33 ; InvMat->c12 = InvMat->c21 = 0. ; InvMat->c13 = InvMat->c31 = 0. ; InvMat->c23 = InvMat->c32 = 0. ; break ; case _2D : if(!DetMat) Message::Error("Null determinant in 'Get_InverseMatrix' (%d)", Type_Dimension); InvMat->c11 = Mat->c22 * Mat->c33 / DetMat ; InvMat->c21 = - Mat->c21 * Mat->c33 / DetMat ; InvMat->c12 = - Mat->c12 * Mat->c33 / DetMat ; InvMat->c22 = Mat->c11 * Mat->c33 / DetMat ; InvMat->c13 = InvMat->c23 = InvMat->c31 = InvMat->c32 = 0. ; InvMat->c33 = 1. / Mat->c33 ; break; case _3D : if(!DetMat) Message::Error("Null determinant in 'Get_InverseMatrix' (%d)", Type_Dimension); InvMat->c11 = ( Mat->c22 * Mat->c33 - Mat->c23 * Mat->c32 ) / DetMat ; InvMat->c21 = -( Mat->c21 * Mat->c33 - Mat->c23 * Mat->c31 ) / DetMat ; InvMat->c31 = ( Mat->c21 * Mat->c32 - Mat->c22 * Mat->c31 ) / DetMat ; InvMat->c12 = -( Mat->c12 * Mat->c33 - Mat->c13 * Mat->c32 ) / DetMat ; InvMat->c22 = ( Mat->c11 * Mat->c33 - Mat->c13 * Mat->c31 ) / DetMat ; InvMat->c32 = -( Mat->c11 * Mat->c32 - Mat->c12 * Mat->c31 ) / DetMat ; InvMat->c13 = ( Mat->c12 * Mat->c23 - Mat->c13 * Mat->c22 ) / DetMat ; InvMat->c23 = -( Mat->c11 * Mat->c23 - Mat->c13 * Mat->c21 ) / DetMat ; InvMat->c33 = ( Mat->c11 * Mat->c22 - Mat->c12 * Mat->c21 ) / DetMat ; break; default : Message::Error("Wrong dimension in 'Get_InverseMatrix'"); break ; } } /* ------------------------------------------------------------------------ */ /* G e t _ P r o d u c t M a t r i x */ /* ------------------------------------------------------------------------ */ void Get_ProductMatrix(int Type_Dimension, MATRIX3x3 * A, MATRIX3x3 * B, MATRIX3x3 * AB) { switch (Type_Dimension) { case _2D : AB->c11 = A->c11 * B->c11 + A->c12 * B->c21 ; AB->c12 = A->c11 * B->c12 + A->c12 * B->c22 ; AB->c21 = A->c21 * B->c11 + A->c22 * B->c21 ; AB->c22 = A->c21 * B->c12 + A->c22 * B->c22 ; break ; case _3D : AB->c11 = A->c11 * B->c11 + A->c12 * B->c21 + A->c13 * B->c31 ; AB->c12 = A->c11 * B->c12 + A->c12 * B->c22 + A->c13 * B->c32 ; AB->c13 = A->c11 * B->c13 + A->c12 * B->c23 + A->c13 * B->c33 ; AB->c21 = A->c21 * B->c11 + A->c22 * B->c21 + A->c23 * B->c31 ; AB->c22 = A->c21 * B->c12 + A->c22 * B->c22 + A->c23 * B->c32 ; AB->c23 = A->c21 * B->c13 + A->c22 * B->c23 + A->c23 * B->c33 ; AB->c31 = A->c31 * B->c11 + A->c32 * B->c21 + A->c33 * B->c31 ; AB->c32 = A->c31 * B->c12 + A->c32 * B->c22 + A->c33 * B->c32 ; AB->c33 = A->c31 * B->c13 + A->c32 * B->c23 + A->c33 * B->c33 ; break ; } } /* ------------------------------------------------------------------------ */ /* G e t _ C h a n g e O f C o o r d i n a t e s */ /* ------------------------------------------------------------------------ */ void *Get_ChangeOfCoordinates(int Flag_ChangeCoord, int Type_Form) { switch (Type_Form) { case SCALAR : case FORM0 : return((void *)ChangeOfCoord_No1) ; case FORM1 : return((Flag_ChangeCoord) ? (void *)ChangeOfCoord_Form1 : (void *)ChangeOfCoord_No123) ; case FORM2 : return((Flag_ChangeCoord) ? (void *)ChangeOfCoord_Form2 : (void *)ChangeOfCoord_No123) ; case FORM3 : case FORM3P : return((Flag_ChangeCoord) ? (void *)ChangeOfCoord_Form3 : (void *)ChangeOfCoord_No1) ; case FORM1P : return((Flag_ChangeCoord) ? (void *)ChangeOfCoord_Form1P : (void *)ChangeOfCoord_No123) ; case FORM2P : return((Flag_ChangeCoord) ? (void *)ChangeOfCoord_Form2P : (void *)ChangeOfCoord_No123) ; case VECTOR : return((void *)ChangeOfCoord_No123) ; case FORM1S : return((Flag_ChangeCoord) ? (void *)ChangeOfCoord_Form1S : (void *)ChangeOfCoord_No123) ; default : Message::Error("Unknown type of field (%s)", Get_StringForDefine(Field_Type, Type_Form)) ; return(NULL) ; } } /* ------------------------------------------------------------------------ */ /* C h a n g e O f C o o r d _ X X X */ /* ------------------------------------------------------------------------ */ void ChangeOfCoord_No1(struct Element * Element, double vBFu[], double vBFx[]) { vBFx[0] = vBFu[0] ; } void ChangeOfCoord_No123(struct Element * Element, double vBFu[], double vBFx[]) { vBFx[0] = vBFu[0] ; vBFx[1] = vBFu[1] ; vBFx[2] = vBFu[2] ; } void ChangeOfCoord_Form1(struct Element * Element, double vBFu[], double vBFx[]) { vBFx[0] = vBFu[0] * Element->InvJac.c11 + vBFu[1] * Element->InvJac.c12 + vBFu[2] * Element->InvJac.c13 ; vBFx[1] = vBFu[0] * Element->InvJac.c21 + vBFu[1] * Element->InvJac.c22 + vBFu[2] * Element->InvJac.c23 ; vBFx[2] = vBFu[0] * Element->InvJac.c31 + vBFu[1] * Element->InvJac.c32 + vBFu[2] * Element->InvJac.c33 ; } void ChangeOfCoord_Form2(struct Element * Element, double vBFu[], double vBFx[]) { if(!Element->DetJac) Message::Error("Null determinant in 'ChangeOfCoord_Form2'"); vBFx[0] = (vBFu[0] * Element->Jac.c11 + vBFu[1] * Element->Jac.c21 + vBFu[2] * Element->Jac.c31) / Element->DetJac ; vBFx[1] = (vBFu[0] * Element->Jac.c12 + vBFu[1] * Element->Jac.c22 + vBFu[2] * Element->Jac.c32) / Element->DetJac ; vBFx[2] = (vBFu[0] * Element->Jac.c13 + vBFu[1] * Element->Jac.c23 + vBFu[2] * Element->Jac.c33) / Element->DetJac ; } void ChangeOfCoord_Form3(struct Element * Element, double vBFu[], double vBFx[]) { if(!Element->DetJac) Message::Error("Null determinant in 'ChangeOfCoord_Form3'"); vBFx[0] = vBFu[0] / Element->DetJac ; } /* Form1P, 2P, 1S : valid in 2D only ! */ void ChangeOfCoord_Form1P(struct Element * Element, double vBFu[], double vBFx[]) { vBFx[0] = 0. ; vBFx[1] = 0. ; vBFx[2] = vBFu[2] / Element->Jac.c33 ; /* ... * Element->InvJac.c33 */ } void ChangeOfCoord_Form2P(struct Element * Element, double vBFu[], double vBFx[]) { if(!Element->DetJac) Message::Error("Null determinant in 'ChangeOfCoord_Form2P'"); vBFx[0] = (vBFu[0] * Element->Jac.c11 + vBFu[1] * Element->Jac.c21) / Element->DetJac ; vBFx[1] = (vBFu[0] * Element->Jac.c12 + vBFu[1] * Element->Jac.c22) / Element->DetJac ; vBFx[2] = 0. ; } void ChangeOfCoord_Form1S(struct Element * Element, double vBFu[], double vBFx[]) { if(!Element->DetJac) Message::Error("Null determinant in 'ChangeOfCoord_Form1S'"); vBFx[0] = 0. ; vBFx[1] = 0. ; vBFx[2] = vBFu[0] / Element->DetJac ; } /* ------------------------------------------------------------------------ */ /* C a l _ P r o d u c t X X X */ /* ------------------------------------------------------------------------ */ double Cal_Product123(double v1[], double v2[]) { return v1[0]*v2[0] + v1[1]*v2[1] + v1[2]*v2[2] ; } double Cal_Product12 (double v1[], double v2[]) { return v1[0]*v2[0] + v1[1]*v2[1] ; } double Cal_Product3 (double v1[], double v2[]) { return v1[2]*v2[2] ; } double Cal_Product1 (double v1[], double v2[]) { return v1[0]*v2[0] ; } getdp-2.4.2-source/Legacy/BF.h000644 001750 001750 00000020714 12116424202 017442 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _BF_H_ #define _BF_H_ #include "ProData.h" #define BF_ARG struct Element * Element, int NumEntity, \ double u, double v, double w, double Value[] /* H^1 Basis Functions and their gradients */ void BF_Node(BF_ARG) ; void BF_Node_2E(BF_ARG) ; void BF_Node_2F(BF_ARG) ; void BF_Node_2V(BF_ARG) ; void BF_Node_3E(BF_ARG) ; void BF_Node_3F(BF_ARG) ; void BF_Node_3V(BF_ARG) ; void BF_GradNode(BF_ARG) ; void BF_GradNode_2E(BF_ARG) ; void BF_GradNode_2F(BF_ARG) ; void BF_GradNode_2V(BF_ARG) ; void BF_GradNode_3E(BF_ARG) ; void BF_GradNode_3F(BF_ARG) ; void BF_GradNode_3V(BF_ARG) ; void BF_GroupOfNodes(BF_ARG) ; void BF_GroupOfNodes_2E(BF_ARG) ; void BF_GroupOfNodes_2F(BF_ARG) ; void BF_GroupOfNodes_2V(BF_ARG) ; void BF_GroupOfNodes_3E(BF_ARG) ; void BF_GroupOfNodes_3F(BF_ARG) ; void BF_GroupOfNodes_3V(BF_ARG) ; void BF_GradGroupOfNodes(BF_ARG) ; void BF_GradGroupOfNodes_2E(BF_ARG) ; void BF_GradGroupOfNodes_2F(BF_ARG) ; void BF_GradGroupOfNodes_2V(BF_ARG) ; void BF_GradGroupOfNodes_3E(BF_ARG) ; void BF_GradGroupOfNodes_3F(BF_ARG) ; void BF_GradGroupOfNodes_3V(BF_ARG) ; /* H(curl) basis Functions and their curls */ void BF_Edge(BF_ARG) ; void BF_Edge_2E(BF_ARG) ; void BF_Edge_2F(BF_ARG) ; void BF_Edge_2V(BF_ARG) ; void BF_Edge_3E(BF_ARG) ; void BF_Edge_3F_a(BF_ARG) ; void BF_Edge_3F_b(BF_ARG) ; void BF_Edge_3F_c(BF_ARG) ; void BF_Edge_3V(BF_ARG) ; void BF_Edge_4E(BF_ARG) ; void BF_Edge_4F(BF_ARG) ; void BF_Edge_4V(BF_ARG) ; void BF_CurlEdge(BF_ARG) ; void BF_CurlEdge_2E(BF_ARG) ; void BF_CurlEdge_2F(BF_ARG) ; void BF_CurlEdge_2V(BF_ARG) ; void BF_CurlEdge_3E(BF_ARG) ; void BF_CurlEdge_3F_a(BF_ARG) ; void BF_CurlEdge_3F_b(BF_ARG) ; void BF_CurlEdge_3F_c(BF_ARG) ; void BF_CurlEdge_3V(BF_ARG) ; void BF_CurlEdge_4E(BF_ARG) ; void BF_CurlEdge_4F(BF_ARG) ; void BF_CurlEdge_4V(BF_ARG) ; void BF_GroupOfEdges(BF_ARG) ; void BF_GroupOfEdges_2E(BF_ARG) ; void BF_GroupOfEdges_2F(BF_ARG) ; void BF_GroupOfEdges_2V(BF_ARG) ; void BF_GroupOfEdges_3E(BF_ARG) ; void BF_GroupOfEdges_3F_a(BF_ARG) ; void BF_GroupOfEdges_3F_b(BF_ARG) ; void BF_GroupOfEdges_3F_c(BF_ARG) ; void BF_GroupOfEdges_3V(BF_ARG) ; void BF_GroupOfEdges_4E(BF_ARG) ; void BF_GroupOfEdges_4F(BF_ARG) ; void BF_GroupOfEdges_4V(BF_ARG) ; void BF_CurlGroupOfEdges(BF_ARG) ; void BF_CurlGroupOfEdges_2E(BF_ARG) ; void BF_CurlGroupOfEdges_2F(BF_ARG) ; void BF_CurlGroupOfEdges_2V(BF_ARG) ; void BF_CurlGroupOfEdges_3E(BF_ARG) ; void BF_CurlGroupOfEdges_3F_a(BF_ARG) ; void BF_CurlGroupOfEdges_3F_b(BF_ARG) ; void BF_CurlGroupOfEdges_3F_c(BF_ARG) ; void BF_CurlGroupOfEdges_3V(BF_ARG) ; void BF_CurlGroupOfEdges_4E(BF_ARG) ; void BF_CurlGroupOfEdges_4F(BF_ARG) ; void BF_CurlGroupOfEdges_4V(BF_ARG) ; /* H(curl, perp) basis Functions and their curls */ void BF_PerpendicularEdge(BF_ARG) ; void BF_PerpendicularEdge_2E(BF_ARG) ; void BF_PerpendicularEdge_2F(BF_ARG) ; void BF_PerpendicularEdge_2V(BF_ARG) ; void BF_PerpendicularEdge_3E(BF_ARG) ; void BF_PerpendicularEdge_3F(BF_ARG) ; void BF_PerpendicularEdge_3V(BF_ARG) ; void BF_CurlPerpendicularEdge(BF_ARG) ; void BF_CurlPerpendicularEdge_2E(BF_ARG) ; void BF_CurlPerpendicularEdge_2F(BF_ARG) ; void BF_CurlPerpendicularEdge_2V(BF_ARG) ; void BF_CurlPerpendicularEdge_3E(BF_ARG) ; void BF_CurlPerpendicularEdge_3F(BF_ARG) ; void BF_CurlPerpendicularEdge_3V(BF_ARG) ; void BF_GroupOfPerpendicularEdges(BF_ARG) ; void BF_GroupOfPerpendicularEdges_2E(BF_ARG) ; void BF_GroupOfPerpendicularEdges_2F(BF_ARG) ; void BF_GroupOfPerpendicularEdges_2V(BF_ARG) ; void BF_GroupOfPerpendicularEdges_3E(BF_ARG) ; void BF_GroupOfPerpendicularEdges_3F(BF_ARG) ; void BF_GroupOfPerpendicularEdges_3V(BF_ARG) ; void BF_CurlGroupOfPerpendicularEdges(BF_ARG) ; void BF_CurlGroupOfPerpendicularEdges_2E(BF_ARG) ; void BF_CurlGroupOfPerpendicularEdges_2F(BF_ARG) ; void BF_CurlGroupOfPerpendicularEdges_2V(BF_ARG) ; void BF_CurlGroupOfPerpendicularEdges_3E(BF_ARG) ; void BF_CurlGroupOfPerpendicularEdges_3F(BF_ARG) ; void BF_CurlGroupOfPerpendicularEdges_3V(BF_ARG) ; /* H(div) basis Functions and their divergences */ void BF_Facet(BF_ARG) ; void BF_DivFacet(BF_ARG) ; void BF_GroupOfFacets(BF_ARG) ; void BF_DivGroupOfFacets(BF_ARG) ; /* H(div, perp) basis Functions and their divergences */ void BF_PerpendicularFacet(BF_ARG) ; void BF_PerpendicularFacet_2E(BF_ARG) ; void BF_PerpendicularFacet_2F(BF_ARG) ; void BF_PerpendicularFacet_2V(BF_ARG) ; void BF_PerpendicularFacet_3E(BF_ARG) ; void BF_PerpendicularFacet_3F_a(BF_ARG) ; void BF_PerpendicularFacet_3F_b(BF_ARG) ; void BF_PerpendicularFacet_3F_c(BF_ARG) ; void BF_PerpendicularFacet_3V(BF_ARG) ; void BF_PerpendicularFacet_4E(BF_ARG) ; void BF_PerpendicularFacet_4F(BF_ARG) ; void BF_PerpendicularFacet_4V(BF_ARG) ; void BF_DivPerpendicularFacet(BF_ARG) ; void BF_DivPerpendicularFacet_2E(BF_ARG) ; void BF_DivPerpendicularFacet_2F(BF_ARG) ; void BF_DivPerpendicularFacet_2V(BF_ARG) ; void BF_DivPerpendicularFacet_3E(BF_ARG) ; void BF_DivPerpendicularFacet_3F_a(BF_ARG) ; void BF_DivPerpendicularFacet_3F_b(BF_ARG) ; void BF_DivPerpendicularFacet_3F_c(BF_ARG) ; void BF_DivPerpendicularFacet_3V(BF_ARG) ; void BF_DivPerpendicularFacet_4E(BF_ARG) ; void BF_DivPerpendicularFacet_4F(BF_ARG) ; void BF_DivPerpendicularFacet_4V(BF_ARG) ; /* L^2 basis Functions */ void BF_Volume(BF_ARG) ; void BF_VolumeX(BF_ARG) ; void BF_VolumeY(BF_ARG) ; void BF_VolumeZ(BF_ARG) ; /* (H^1)^3 Basis Functions */ void BF_NodeX(BF_ARG) ; void BF_NodeY(BF_ARG) ; void BF_NodeZ(BF_ARG) ; void BF_NodeX_2E(BF_ARG) ; void BF_NodeY_2E(BF_ARG) ; void BF_NodeZ_2E(BF_ARG) ; void BF_NodeX_2F(BF_ARG) ; void BF_NodeY_2F(BF_ARG) ; void BF_NodeZ_2F(BF_ARG) ; void BF_NodeX_2V(BF_ARG) ; void BF_NodeY_2V(BF_ARG) ; void BF_NodeZ_2V(BF_ARG) ; void BF_NodeX_3E(BF_ARG) ; void BF_NodeY_3E(BF_ARG) ; void BF_NodeZ_3E(BF_ARG) ; void BF_NodeX_3F(BF_ARG) ; void BF_NodeY_3F(BF_ARG) ; void BF_NodeZ_3F(BF_ARG) ; void BF_NodeX_3V(BF_ARG) ; void BF_NodeY_3V(BF_ARG) ; void BF_NodeZ_3V(BF_ARG) ; void BF_NodeX_D1(BF_ARG) ; void BF_NodeY_D1(BF_ARG) ; void BF_NodeZ_D1(BF_ARG) ; void BF_NodeX_D1_2E(BF_ARG) ; void BF_NodeY_D1_2E(BF_ARG) ; void BF_NodeZ_D1_2E(BF_ARG) ; void BF_NodeX_D1_2F(BF_ARG) ; void BF_NodeY_D1_2F(BF_ARG) ; void BF_NodeZ_D1_2F(BF_ARG) ; void BF_NodeX_D1_2V(BF_ARG) ; void BF_NodeY_D1_2V(BF_ARG) ; void BF_NodeZ_D1_2V(BF_ARG) ; void BF_NodeX_D1_3E(BF_ARG) ; void BF_NodeY_D1_3E(BF_ARG) ; void BF_NodeZ_D1_3E(BF_ARG) ; void BF_NodeX_D1_3F(BF_ARG) ; void BF_NodeY_D1_3F(BF_ARG) ; void BF_NodeZ_D1_3F(BF_ARG) ; void BF_NodeX_D1_3V(BF_ARG) ; void BF_NodeY_D1_3V(BF_ARG) ; void BF_NodeZ_D1_3V(BF_ARG) ; void BF_NodeX_D2(BF_ARG) ; void BF_NodeY_D2(BF_ARG) ; void BF_NodeZ_D2(BF_ARG) ; void BF_NodeX_D2_2E(BF_ARG) ; void BF_NodeY_D2_2E(BF_ARG) ; void BF_NodeZ_D2_2E(BF_ARG) ; void BF_NodeX_D2_2F(BF_ARG) ; void BF_NodeY_D2_2F(BF_ARG) ; void BF_NodeZ_D2_2F(BF_ARG) ; void BF_NodeX_D2_2V(BF_ARG) ; void BF_NodeY_D2_2V(BF_ARG) ; void BF_NodeZ_D2_2V(BF_ARG) ; void BF_NodeX_D2_3E(BF_ARG) ; void BF_NodeY_D2_3E(BF_ARG) ; void BF_NodeZ_D2_3E(BF_ARG) ; void BF_NodeX_D2_3F(BF_ARG) ; void BF_NodeY_D2_3F(BF_ARG) ; void BF_NodeZ_D2_3F(BF_ARG) ; void BF_NodeX_D2_3V(BF_ARG) ; void BF_NodeY_D2_3V(BF_ARG) ; void BF_NodeZ_D2_3V(BF_ARG) ; void BF_NodeX_D12(BF_ARG) ; void BF_NodeY_D12(BF_ARG) ; void BF_NodeZ_D12(BF_ARG) ; void BF_NodeX_D12_2E(BF_ARG) ; void BF_NodeY_D12_2E(BF_ARG) ; void BF_NodeZ_D12_2E(BF_ARG) ; void BF_GroupOfNodesX(BF_ARG) ; void BF_GroupOfNodesY(BF_ARG) ; void BF_GroupOfNodesZ(BF_ARG) ; void BF_GroupOfNodesX_D1(BF_ARG) ; void BF_GroupOfNodesY_D1(BF_ARG) ; void BF_GroupOfNodesZ_D1(BF_ARG) ; void BF_GroupOfNodesX_D2(BF_ARG) ; void BF_GroupOfNodesY_D2(BF_ARG) ; void BF_GroupOfNodesZ_D2(BF_ARG) ; void BF_GroupOfNodesX_D12(BF_ARG) ; void BF_GroupOfNodesY_D12(BF_ARG) ; void BF_GroupOfNodesZ_D12(BF_ARG) ; /* Special basis Functions */ void BF_Zero(BF_ARG) ; void BF_One(BF_ARG) ; void BF_Region(BF_ARG) ; void BF_RegionX(BF_ARG) ; void BF_RegionY(BF_ARG) ; void BF_RegionZ(BF_ARG) ; void BF_dRegion(BF_ARG) ; void BF_dRegionX(BF_ARG) ; void BF_dRegionY(BF_ARG) ; void BF_dRegionZ(BF_ARG) ; void BF_Global(BF_ARG) ; void BF_dGlobal(BF_ARG) ; void BF_Wire(BF_ARG) ; void BF_DivWire(BF_ARG) ; #undef BF_ARG #endif getdp-2.4.2-source/Legacy/GeoNormal.cpp000644 001750 001750 00000010503 12116424202 021364 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include #include "ProData.h" #include "GeoData.h" #include "MallocUtils.h" #include "Message.h" #define SQU(a) ((a)*(a)) extern struct Problem Problem_S ; extern struct GeoData * CurrentGeoData ; int fcmp_NXE(const void * a, const void * b) { return ((struct Entity2XEntity1 *)a)->Num - ((struct Entity2XEntity1 *)b)->Num ; } int fcmp_EXVector(const void * a, const void * b) { return ((struct EntityXVector *)a)->Num - ((struct EntityXVector *)b)->Num ; } /* C'est une maniere un peu naive de creer cette BD. Mais elle a l'avantage de permettre une allocation simple (et minimum). L'autre possibilite (boucler sur les elemnts) est plus rapide, mais je ne vois pas bien comment obtenir un cout memoire minimum simplement, sans faire de nombreux realloc. */ #define MAX_NBR_NXE_INCIDENCE 20 static int RegionIndexForNXE = -1; void Geo_CreateNodesXElements(int NumNode, int InIndex, int *NbrElements, int **NumElements) { struct Entity2XEntity1 NXE, *NXE_P ; struct Geo_Element *GeoElement ; struct Group *Group_P ; int i, j, tmp[MAX_NBR_NXE_INCIDENCE] ; Group_P = (struct Group*)List_Pointer(Problem_S.Group, InIndex); if(InIndex != RegionIndexForNXE){ RegionIndexForNXE = InIndex ; Message::Info(" Generate NodesXElements information for Region '%s'", Group_P->Name); if(CurrentGeoData->NodesXElements) Tree_Delete(CurrentGeoData->NodesXElements); CurrentGeoData->NodesXElements = Tree_Create(sizeof(struct Entity2XEntity1), fcmp_NXE) ; } NXE.Num = NumNode ; if((NXE_P = (struct Entity2XEntity1*) Tree_PQuery(CurrentGeoData->NodesXElements, &NXE))) { *NbrElements = NXE_P->NbrEntities ; *NumElements = NXE_P->NumEntities ; } else{ NXE.NbrEntities = 0 ; for (i = 0 ; i < Geo_GetNbrGeoElements(); i++) { GeoElement = Geo_GetGeoElement(i) ; if (List_Search(Group_P->InitialList, &GeoElement->Region, fcmp_int)){ for(j=0 ; jNbrNodes ; j++){ if(GeoElement->NumNodes[j] == NumNode){ /* printf("Adding elm %d to node %d\n", GeoElement->Num, NumNode); */ /* this is to have orientation of elements adjacent to the node Only valid for line elemnts !!!!!!! */ tmp[NXE.NbrEntities] = ((!j)?-1:1) * GeoElement->Num ; NXE.NbrEntities++ ; } } } } NXE.NumEntities = (int*)Malloc(NXE.NbrEntities * sizeof(int)) ; memcpy(NXE.NumEntities, tmp, NXE.NbrEntities * sizeof(int)); Tree_Add(CurrentGeoData->NodesXElements, &NXE); *NbrElements = NXE.NbrEntities ; *NumElements = NXE.NumEntities ; } } void Geo_CreateNormal(int Type, double *x, double *y, double *z, double *N) { double x1x0, x2x0, y1y0, y2y0, z1z0, z2z0 ; double nx, ny, nz, norm ; switch (Type) { case LINE : nx = y[1] - y[0] ; ny = x[0] - x[1] ; norm = sqrt(SQU(nx)+SQU(ny)) ; N[0] = nx / norm ; N[1] = ny / norm ; N[2] = 0. ; break ; case TRIANGLE : case QUADRANGLE : x1x0 = x[1] - x[0] ; y1y0 = y[1] - y[0] ; z1z0 = z[1] - z[0] ; x2x0 = x[2] - x[0] ; y2y0 = y[2] - y[0] ; z2z0 = z[2] - z[0] ; nx = y1y0 * z2z0 - z1z0 * y2y0 ; ny = z1z0 * x2x0 - x1x0 * z2z0 ; nz = x1x0 * y2y0 - y1y0 * x2x0 ; norm = sqrt(SQU(nx)+SQU(ny)+SQU(nz)) ; N[0] = nx/norm ; N[1] = ny/norm ; N[2] = nz/norm ; break ; default : Message::Error("Normal computation not done (yet) for Element Type %d", Type); } } void Geo_CreateNormalOfElement(struct Geo_Element *GeoElement, double *Normal) { struct EntityXVector EXV, *EXV_P ; double x [NBR_MAX_NODES_IN_ELEMENT] ; double y [NBR_MAX_NODES_IN_ELEMENT] ; double z [NBR_MAX_NODES_IN_ELEMENT] ; EXV.Num = GeoElement->Num ; if((EXV_P = (struct EntityXVector*)Tree_PQuery(CurrentGeoData->Normals, &EXV))) { memcpy(Normal, EXV_P->Vector, 3*sizeof(double)); } else{ Geo_GetNodesCoordinates(GeoElement->NbrNodes, GeoElement->NumNodes, x, y, z) ; Geo_CreateNormal(GeoElement->Type, x, y, z, Normal); memcpy(EXV.Vector, Normal, 3*sizeof(double)); Tree_Add(CurrentGeoData->Normals, &EXV); } } getdp-2.4.2-source/Legacy/Pos_Element.h000644 001750 001750 00000003105 12116424202 021360 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _POS_ELEMENT_H_ #define _POS_ELEMENT_H_ #include "ProData.h" #include "ListUtils.h" /* ------------------------------------------------------------------------ */ /* P o s t E l e m e n t */ /* ------------------------------------------------------------------------ */ struct PostElement { int Index, Type, Depth; int NbrNodes, * NumNodes; double * u, * v, * w, * x, * y, * z; struct Value * Value; } ; struct PostElement * Create_PostElement(int Index, int Type, int NbrNodes, int Depth); void Destroy_PostElement(struct PostElement * PostElement) ; struct PostElement * NodeCopy_PostElement(struct PostElement *PostElement); struct PostElement * PartialCopy_PostElement(struct PostElement *PostElement); void Fill_PostElement(struct Geo_Element *GE, List_T *PostElement_L, int Index, int Depth, int Skin, List_T * EvaluationPoints_L, int DecomposeInSimplex) ; void Cut_PostElement(struct PostElement * PE, struct Geo_Element * GE, List_T * PE_L, int Index, int Depth, int Skin, int DecomposeInSimplex) ; void Sort_PostElement_Connectivity(List_T *PostElement_L); int fcmp_PostElement (const void *a, const void *b); int fcmp_PostElement_v0(const void *a, const void *b); int fcmp_PostElement_absu0(const void *a, const void *b); #endif getdp-2.4.2-source/Legacy/Cal_IntegralQuantity.h000644 001750 001750 00000002232 12116424202 023231 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _CAL_INTEGRAL_QUANTITY_H_ #define _CAL_INTEGRAL_QUANTITY_H_ #include "ProData.h" void Cal_InitIntegralQuantity(struct Element *Element, struct IntegralQuantityActive *IQA, struct QuantityStorage *QuantityStorage_P); void Cal_NumericalIntegralQuantity(struct Element *Element, struct IntegralQuantityActive *IQA, struct QuantityStorage *QuantityStorage_P0, struct QuantityStorage *QuantityStorage_P, int Type_DefineQuantity, int Nbr_Dof, void (*xFunctionBF[])(), struct Value vBFxDof[]); void Cal_AnalyticIntegralQuantity(struct Element *Element, struct QuantityStorage *QuantityStorage_P, int Nbr_Dof, void (*xFunctionBF[])(), struct Value vBFxDof[]); #endif getdp-2.4.2-source/Legacy/Gauss.h000644 001750 001750 00000002161 12116424202 020231 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _GAUSS_H_ #define _GAUSS_H_ #define GAUSS_ARGS int Nbr_Points, int Num_Point, \ double *u, double *v, double *w, double *wght void Gauss_Point (GAUSS_ARGS) ; void Gauss_Line (GAUSS_ARGS) ; void Gauss_Triangle (GAUSS_ARGS) ; void GaussLegendre_Triangle (GAUSS_ARGS) ; void GaussSingularR_Triangle (GAUSS_ARGS) ; void Gauss_Quadrangle (GAUSS_ARGS) ; void GaussLegendre_Quadrangle (GAUSS_ARGS) ; void GaussSingularR_Quadrangle(GAUSS_ARGS) ; void Gauss_Tetrahedron (GAUSS_ARGS) ; void GaussLegendre_Tetrahedron(GAUSS_ARGS) ; void Gauss_Hexahedron (GAUSS_ARGS) ; void GaussLegendre_Hexahedron (GAUSS_ARGS) ; void Gauss_Prism (GAUSS_ARGS) ; void Gauss_Pyramid (GAUSS_ARGS) ; #undef GAUSS_ARGS #define MAX_LINE_POINTS 100 void GaussLegendre(double x1, double x2, double x[], double w[], int n) ; #endif getdp-2.4.2-source/Legacy/BF_Region.cpp000644 001750 001750 00000021062 12116424202 021275 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "ProData.h" #include "BF.h" #include "Get_DofOfElement.h" #include "Pos_FemInterpolation.h" #include "Cal_Quantity.h" #include "MallocUtils.h" #include "Message.h" extern struct Problem Problem_S ; extern struct CurrentData Current ; /* ------------------------------------------------------------------------ */ /* B F _ S u b F u n c t i o n */ /* ------------------------------------------------------------------------ */ void BF_SubFunction(struct Element * Element, int NumExpression, int Dim, double s[]) { struct Value Value ; Get_ValueOfExpressionByIndex(NumExpression, NULL, 0., 0., 0., &Value) ; switch (Dim) { case 1 : *s *= Value.Val[0] ; break ; case 3 : s[0] *= Value.Val[0] ; s[1] *= Value.Val[0] ; s[2] *= Value.Val[0] ; break ; } } /* ------------------------------------------------------------------------ */ /* B F _ R e g i o n */ /* ------------------------------------------------------------------------ */ void BF_Region(struct Element * Element, int NumRegion, double u, double v, double w, double *s) { *s = 1. ; if (Element->NumSubFunction[0][NumRegion-1] >= 0) BF_SubFunction(Element, Element->NumSubFunction[0][NumRegion-1], 1, s) ; } void BF_dRegion(struct Element * Element, int NumRegion, double u, double v, double w, double *s) { *s = 1. ; if (Element->NumSubFunction[0][NumRegion-1] >= 0) BF_SubFunction(Element, Element->NumSubFunction[2][NumRegion-1], 1, s) ; else *s = 0. ; } /* ------------------------------------------------------------------------ */ /* B F _ R e g i o n X , Y , Z */ /* ------------------------------------------------------------------------ */ void BF_RegionX(struct Element * Element, int NumRegion, double u, double v, double w, double s[]) { s[1] = s[2] = 0. ; s[0] = 1. ; if (Element->NumSubFunction[0][NumRegion-1] >= 0) BF_SubFunction(Element, Element->NumSubFunction[0][NumRegion-1], 3, s) ; } void BF_RegionY(struct Element * Element, int NumRegion, double u, double v, double w, double s[]) { s[0] = s[2] = 0. ; s[1] = 1. ; if (Element->NumSubFunction[0][NumRegion-1] >= 0) BF_SubFunction(Element, Element->NumSubFunction[0][NumRegion-1], 3, s) ; } void BF_RegionZ(struct Element * Element, int NumRegion, double u, double v, double w, double s[]) { s[0] = s[1] = 0. ; s[2] = 1. ; if (Element->NumSubFunction[0][NumRegion-1] >= 0) BF_SubFunction(Element, Element->NumSubFunction[0][NumRegion-1], 3, s) ; } void BF_dRegionX(struct Element * Element, int NumRegion, double u, double v, double w, double s[]) { s[1] = s[2] = 0. ; s[0] = 1. ; /* Patrick (a finaliser) */ if (Element->NumSubFunction[0][NumRegion-1] >= 0) BF_SubFunction(Element, Element->NumSubFunction[2][NumRegion-1], 3, s) ; else s[0] = 0. ; } void BF_dRegionY(struct Element * Element, int NumRegion, double u, double v, double w, double s[]) { s[0] = s[2] = 0. ; s[1] = 1. ; /* Patrick (a finaliser) */ if (Element->NumSubFunction[0][NumRegion-1] >= 0) BF_SubFunction(Element, Element->NumSubFunction[2][NumRegion-1], 3, s) ; else s[1] = 0. ; } void BF_dRegionZ(struct Element * Element, int NumRegion, double u, double v, double w, double s[]) { /* Patrick (a finaliser) s[0] = s[1] = 0. ; s[2] = 1. ; */ s[0] = s[2] = 0. ; s[1] = -1. ; if (Element->NumSubFunction[0][NumRegion-1] >= 0) BF_SubFunction(Element, Element->NumSubFunction[2][NumRegion-1], 3, s) ; else s[1] = 0. ; } /* ------------------------------------------------------------------------ */ /* B F _ Z e r o */ /* ------------------------------------------------------------------------ */ void BF_Zero(struct Element * Element, int Num, double u, double v, double w, double *s) { s[0] = s[1] = s[2] = 0. ; } void BF_One(struct Element * Element, int Num, double u, double v, double w, double *s) { s[0] = 1. ; s[1] = s[2] = 0. ; } /* ------------------------------------------------------------------------ */ /* B F _ I n i t G l o b a l */ /* ------------------------------------------------------------------------ */ void BF_InitGlobal(struct GlobalBasisFunction * GlobalBasisFunction_P) { struct QuantityStorage * QuantityStorage_P ; struct Formulation * Formulation_P ; QuantityStorage_P = GlobalBasisFunction_P->QuantityStorage = (struct QuantityStorage *)Malloc(sizeof(struct QuantityStorage)) ; QuantityStorage_P->NumLastElementForFunctionSpace = 0 ; Formulation_P = (struct Formulation*) List_Pointer(Problem_S.Formulation, GlobalBasisFunction_P->FormulationIndex) ; QuantityStorage_P->DefineQuantity = (struct DefineQuantity*) List_Pointer(Formulation_P->DefineQuantity, GlobalBasisFunction_P->DefineQuantityIndex) ; QuantityStorage_P->FunctionSpace = (struct FunctionSpace*) List_Pointer(Problem_S.FunctionSpace, QuantityStorage_P->DefineQuantity->FunctionSpaceIndex) ; QuantityStorage_P->TypeQuantity = QuantityStorage_P->FunctionSpace->Type ; } /* ------------------------------------------------------------------------ */ /* B F _ G l o b a l */ /* ------------------------------------------------------------------------ */ void BF_Global(struct Element * Element, int NumGlobal, double u, double v, double w, double *s) { struct Value Value ; struct GlobalBasisFunction * GlobalBasisFunction_P ; struct QuantityStorage * QuantityStorage_P ; int Save_NbrHar; GlobalBasisFunction_P = Element->GlobalBasisFunction[NumGlobal-1] ; if (!GlobalBasisFunction_P->QuantityStorage) BF_InitGlobal(GlobalBasisFunction_P) ; /* Init QuantityStorage */ QuantityStorage_P = GlobalBasisFunction_P->QuantityStorage ; if (QuantityStorage_P->NumLastElementForFunctionSpace != Element->Num) { QuantityStorage_P->NumLastElementForFunctionSpace = Element->Num ; Get_DofOfElement (Element, QuantityStorage_P->FunctionSpace, QuantityStorage_P, QuantityStorage_P->DefineQuantity->IndexInFunctionSpace) ; } Save_NbrHar = Current.NbrHar; Current.NbrHar = 1; /* for real basis function */ Pos_FemInterpolation (Element, NULL, GlobalBasisFunction_P->QuantityStorage, QUANTITY_SIMPLE, NOOP, -1, 0, u, v, w, 0., 0., 0., Value.Val, &Value.Type, 0) ; Current.NbrHar = Save_NbrHar; switch (Value.Type) { case SCALAR : s[0] = Value.Val[0] ; break ; case VECTOR : s[0] = Value.Val[0] ; s[1] = Value.Val[1] ; s[2] = Value.Val[2] ; break ; default : Message::Error("Bad type of value for Global BasisFunction") ; } } /* ------------------------------------------------------------------------ */ /* B F _ d G l o b a l */ /* ------------------------------------------------------------------------ */ void BF_dGlobal(struct Element * Element, int NumGlobal, double u, double v, double w, double *s ) { struct Value Value ; struct GlobalBasisFunction * GlobalBasisFunction_P ; struct QuantityStorage * QuantityStorage_P ; int Save_NbrHar; GlobalBasisFunction_P = Element->GlobalBasisFunction[NumGlobal-1] ; if (!GlobalBasisFunction_P->QuantityStorage) BF_InitGlobal(GlobalBasisFunction_P) ; /* Init QuantityStorage */ QuantityStorage_P = GlobalBasisFunction_P->QuantityStorage ; if (QuantityStorage_P->NumLastElementForFunctionSpace != Element->Num) { QuantityStorage_P->NumLastElementForFunctionSpace = Element->Num ; Get_DofOfElement (Element, QuantityStorage_P->FunctionSpace, QuantityStorage_P, QuantityStorage_P->DefineQuantity->IndexInFunctionSpace) ; } Save_NbrHar = Current.NbrHar; Current.NbrHar = 1; /* for real basis function */ Pos_FemInterpolation (Element, NULL, GlobalBasisFunction_P->QuantityStorage, QUANTITY_SIMPLE, EXTDER, -1, 0, u, v, w, 0., 0., 0., Value.Val, &Value.Type, 0) ; Current.NbrHar = Save_NbrHar; switch (Value.Type) { case SCALAR : s[0] = Value.Val[0] ; break ; case VECTOR : s[0] = Value.Val[0] ; s[1] = Value.Val[1] ; s[2] = Value.Val[2] ; break ; default : Message::Error("Bad type of value for Global BasisFunction") ; } } getdp-2.4.2-source/Legacy/Gauss_Prism.cpp000644 001750 001750 00000001732 12116424202 021741 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "Gauss_Prism.h" #include "Message.h" /* Gauss integration over a prism */ void Gauss_Prism(int Nbr_Points, int Num, double *u, double *v, double *w, double *wght) { switch (Nbr_Points) { case 6 : *u = upri6 [Num] ; *v = vpri6 [Num] ; *w = wpri6 [Num] ; *wght = ppri6 [Num] ; break ; case 9 : *u = upri9 [Num] ; *v = vpri9 [Num] ; *w = wpri9 [Num] ; *wght = ppri9 [Num] ; break ; case 21 : *u = upri21[Num] ; *v = vpri21[Num] ; *w = wpri21[Num] ; *wght = ppri21[Num] ; break ; case 42 : *u = upri42[Num] ; *v = vpri42[Num] ; *w = wpri42[Num] ; *wght = ppri42[Num] ; break ; default : Message::Error("Wrong number of Gauss points for Prism: " "valid choices: 6, 9, 21, 42"); break; } } getdp-2.4.2-source/Legacy/CMakeLists.txt000644 001750 001750 00000004405 12166744450 021560 0ustar00geuzainegeuzaine000000 000000 # GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine # # See the LICENSE.txt file for license information. Please report all # bugs and problems to the public mailing list . set(SRC MainLegacy.cpp F_Analytic.cpp F_BiotSavart.cpp F_Coord.cpp F_ExtMath.cpp F_Geometry.cpp F_Interpolation.cpp F_Hysteresis.cpp F_Math.cpp F_Misc.cpp F_MultiHar.cpp F_Raytracing.cpp F_Gmsh.cpp F_DiffGeom.cpp BF_Node.cpp BF_NodeXYZ.cpp BF_Node_2.cpp BF_Node_3.cpp BF_Edge.cpp BF_Edge_2.cpp BF_Edge_3.cpp BF_Edge_4.cpp BF_Facet.cpp BF_Volume.cpp BF_Region.cpp BF_Perpendicular.cpp BF_GroupOfEntities.cpp GF_Helmholtz.cpp GF_HelmholtzxForm.cpp GF_Laplace.cpp GF_LaplacexForm.cpp Gauss_Point.cpp Gauss_Line.cpp Gauss_Triangle.cpp Gauss_Quadrangle.cpp Gauss_Tetrahedron.cpp Gauss_Hexahedron.cpp Gauss_Prism.cpp Gauss_Pyramid.cpp GeoData.cpp GeoEntity.cpp GeoNormal.cpp GeoTree.cpp DofData.cpp LinAlg.cpp LinAlg_PETSC.cpp LinAlg_SPARSKIT.cpp SolvingAnalyse.cpp SolvingOperations.cpp Cal_SolutionErrorRatio.cpp Operation_TimeLoopAdaptive.cpp Operation_IterativeLoopN.cpp Operation_IterativeLinearSolver.cpp Operation_IterativeTimeReduction.cpp Operation_Update.cpp Operation_ChangeOfCoordinates.cpp Operation_PostOperation.cpp Treatment_Formulation.cpp Get_DofOfElement.cpp Get_ConstraintOfElement.cpp Treatment_ConstraintByLocalProjection.cpp Get_FunctionValue.cpp Get_Geometry.cpp Get_ElementSource.cpp ExtendedGroup.cpp Pre_TermOfFemEquation.cpp Generate_Network.cpp Cal_GalerkinTermOfFemEquation.cpp Cal_GlobalTermOfFemEquation.cpp Cal_IntegralQuantity.cpp Cal_AnalyticIntegration.cpp Cal_Quantity.cpp Cal_Value.cpp Cal_AssembleTerm.cpp Cal_PostQuantity.cpp MovingBand2D.cpp EigenSolve.cpp EigenSolve_ARPACK.cpp EigenSolve_SLEPC.cpp Pos_FemInterpolation.cpp Pos_Formulation.cpp Pos_Print.cpp Pos_Element.cpp Pos_Format.cpp Pos_Iso.cpp Pos_Search.cpp ) file(GLOB HDR RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} *.h) append_getdp_src(Legacy "${SRC};${HDR}") getdp-2.4.2-source/Legacy/Gauss_Hexahedron.cpp000644 001750 001750 00000005161 12116424202 022734 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "Gauss.h" #include "Gauss_Hexahedron.h" #include "Message.h" #include "MallocUtils.h" /* Gauss integration over a hexahedron */ void Gauss_Hexahedron(int Nbr_Points, int Num, double *u, double *v, double *w, double *wght) { switch (Nbr_Points) { case 6 : *u = xhex6 [Num] ; *v = yhex6 [Num] ; *w = zhex6 [Num] ; *wght = phex6 [Num] ; break ; case 14 : *u = xhex14 [Num] ; *v = yhex14 [Num] ; *w = zhex14 [Num] ; *wght = phex14 [Num] ; break ; case 34 : *u = xhex34[Num] ; *v = yhex34[Num] ; *w = zhex34[Num] ; *wght = phex34[Num] ; break ; case 77 : *u = xhex77[Num] ; *v = yhex77[Num] ; *w = zhex77[Num] ; *wght = phex77[Num] ; break ; default : Message::Error("Wrong number of Gauss points for Hexahedron: " "valid choices: 6, 14, 34, 77"); break; } } /* Gauss-Legendre scheme to integrate over a hexahedron */ static int glhex[MAX_LINE_POINTS] = {-1}; static double *glxhex[MAX_LINE_POINTS], *glyhex[MAX_LINE_POINTS]; static double *glzhex[MAX_LINE_POINTS], *glphex[MAX_LINE_POINTS]; void GaussLegendre_Hexahedron(int Nbr_Points, int Num, double *u, double *v, double *w, double *wght) { int i, j, k, index = 0, nb; double pt1, pt2, pt3, wt1, wt2, wt3, dum; nb = (int)cbrt((double)Nbr_Points); if(nb * nb * nb != Nbr_Points || nb > MAX_LINE_POINTS){ Message::Error("Number of points should be n^3 with n in [1,%d]", MAX_LINE_POINTS) ; return; } if(glhex[0] < 0) for(i = 0; i < MAX_LINE_POINTS; i++) glhex[i] = 0 ; if(!glhex[nb - 1]){ Message::Info("Computing GaussLegendre %dx%dx%d for Hexahedron", nb, nb, nb); glxhex[nb - 1] = (double*)Malloc(Nbr_Points * sizeof(double)); glyhex[nb - 1] = (double*)Malloc(Nbr_Points * sizeof(double)); glzhex[nb - 1] = (double*)Malloc(Nbr_Points * sizeof(double)); glphex[nb - 1] = (double*)Malloc(Nbr_Points * sizeof(double)); for(i = 0; i < nb; i++) { Gauss_Line(nb, i, &pt1, &dum, &dum, &wt1); for(j = 0; j < nb; j++) { Gauss_Line(nb, j, &pt2, &dum, &dum, &wt2); for(k = 0; k < nb; k++) { Gauss_Line(nb, k, &pt3, &dum, &dum, &wt3); glxhex[nb - 1][index] = pt1; glyhex[nb - 1][index] = pt2; glzhex[nb - 1][index] = pt3; glphex[nb - 1][index++] = wt1 * wt2 * wt3; } } } glhex[nb - 1] = 1; } *u = glxhex[nb - 1][Num] ; *v = glyhex[nb - 1][Num] ; *w = glzhex[nb - 1][Num] ; *wght = glphex[nb - 1][Num] ; } getdp-2.4.2-source/Legacy/Gauss_Hexahedron.h000644 001750 001750 00000016255 12116424202 022407 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . /* 6 integration points (DHATT ET TOUZOT, page 299) */ #define a1 0.40824826 #define a2 0.81649658 #define b1 0.70710678 #define c1 0.57735027 #define w1 1.3333333333 static double xhex6[6] = { a1, a1, -a1, -a1, -a2, a2}; static double yhex6[6] = { b1, -b1, b1, -b1, 0., 0.}; static double zhex6[6] = {-c1, -c1, c1, c1, -c1, c1}; static double phex6[6] = { w1, w1, w1, w1, w1, w1}; #undef a1 #undef a2 #undef b1 #undef c1 #undef w1 #define b 0.795822426 #define c 0.758786911 #define wb 0.886426593 #define wc 0.335180055 static double xhex14[14] = { b, -b, 0, 0, 0, 0, c, c, c, c, -c, -c, -c, -c }; static double yhex14[14] = { 0, 0, b, -b, 0, 0, c, c, -c, -c, c, c, -c, -c }; static double zhex14[14] = { 0, 0, 0, 0, b, -b, c, -c, c, -c, c, -c, c, -c }; static double phex14[14] = { wb, wb, wb, wb, wb, wb, wc, wc, wc, wc, wc, wc, wc, wc }; #undef b #undef c #undef wb #undef wc /* 34 integration points (DHATT ET TOUZOT, page 299) */ static double xhex34[34] = {0.9317380000,-0.9317380000,0., 0.,0.,0., 0.9167441779,-0.9167441779,0.9167441779, -0.9167441779,0.,0., 0.,0.,0.9167441779, -0.9167441779,0.9167441779,-0.9167441779, 0.4086003800,0.4086003800, 0.4086003800,0.4086003800, -0.4086003800,-0.4086003800, -0.4086003800,-0.4086003800, 0.7398529500,0.7398529500, 0.7398529500,0.7398529500, -0.7398529500,-0.7398529500, -0.7398529500,-0.7398529500}; static double yhex34[34] = {0.,0.,0.9317380000, -0.9317380000,0.,0., 0.9167441779,0.9167441779,-0.9167441779, -0.9167441779,0.9167441779,-0.9167441779, 0.9167441779,-0.9167441779,0., 0.,0.,0., 0.4086003800,0.4086003800, -0.4086003800,-0.4086003800, 0.4086003800,0.4086003800, -0.4086003800,-0.4086003800, 0.7398529500,0.7398529500, -0.7398529500,-0.7398529500, 0.7398529500,0.7398529500, -0.7398529500,-0.7398529500}; static double zhex34[34] = {0.,0.,0., 0.,0.9317380000,-0.9317380000, 0.,0.,0., 0.,0.9167441779,0.9167441779, -0.9167441779,-0.9167441779,0.9167441779, 0.9167441779,-0.9167441779,-0.9167441779, 0.4086003800,-0.4086003800, 0.4086003800,-0.4086003800, 0.4086003800,-0.4086003800, 0.4086003800,-0.4086003800, 0.7398529500,-0.7398529500, 0.7398529500,-0.7398529500, 0.7398529500,-0.7398529500, 0.7398529500,-0.7398529500}; static double phex34[34] = {0.28465447168,0.28465447168, 0.28465447168,0.28465447168, 0.28465447168,0.28465447168, 0.09983142160,0.09983142160, 0.09983142160,0.09983142160, 0.09983142160,0.09983142160, 0.09983142160,0.09983142160, 0.09983142160,0.09983142160, 0.09983142160,0.09983142160, 0.42294183928,0.42294183928, 0.42294183928,0.42294183928, 0.42294183928,0.42294183928, 0.42294183928,0.42294183928, 0.21382017456,0.21382017456, 0.21382017456,0.21382017456, 0.21382017456,0.21382017456, 0.21382017456,0.21382017456}; /* 77 integration points (STROUD, page 238) */ static double xhex77[77] = {0., 0.5384693101,-0.5384693101,0.,0.,0.,0., 0.9061798459,-0.9061798459,0.,0.,0.,0., 0.5384693101,0.5384693101,-0.5384693101,-0.5384693101, 0.5384693101,0.5384693101,-0.5384693101,-0.5384693101, 0.,0.,0.,0., 0.9061798459,0.9061798459,-0.9061798459,-0.9061798459, 0.9061798459,0.9061798459,-0.9061798459,-0.9061798459, 0.,0.,0.,0., 0.5384693101,0.5384693101,-0.5384693101,-0.5384693101, 0.9061798459,0.9061798459,-0.9061798459,-0.9061798459, 0.5384693101,0.5384693101,-0.5384693101,-0.5384693101, 0.9061798459,0.9061798459,-0.9061798459,-0.9061798459, 0.,0.,0.,0., 0.,0.,0.,0., 0.5384693101, 0.5384693101, 0.5384693101, 0.5384693101, -0.5384693101,-0.5384693101,-0.5384693101,-0.5384693101, 0.9061798459, 0.9061798459, 0.9061798459, 0.9061798459, -0.9061798459,-0.9061798459,-0.9061798459,-0.9061798459}; static double yhex77[77] = {0., 0.,0.,0.5384693101,-0.5384693101,0.,0., 0.,0.,0.9061798459,-0.9061798459,0.,0., 0.5384693101,-0.5384693101,0.5384693101,-0.5384693101, 0.,0.,0.,0., 0.5384693101, 0.5384693101,-0.5384693101,-0.5384693101, 0.9061798459,-0.9061798459,0.9061798459,-0.9061798459, 0.,0.,0.,0., 0.9061798459,0.9061798459,-0.9061798459,-0.9061798459, 0.9061798459,-0.9061798459,0.9061798459,-0.9061798459, 0.5384693101,-0.5384693101,0.5384693101,-0.5384693101, 0.,0.,0.,0., 0.,0.,0.,0., 0.5384693101,0.5384693101,-0.5384693101,-0.5384693101, 0.9061798459,0.9061798459,-0.9061798459,-0.9061798459, 0.5384693101,0.5384693101,-0.5384693101,-0.5384693101, 0.5384693101,0.5384693101,-0.5384693101,-0.5384693101, 0.9061798459,0.9061798459,-0.9061798459,-0.9061798459, 0.9061798459,0.9061798459,-0.9061798459,-0.9061798459}; static double zhex77[77] = {0., 0.,0.,0.,0.,0.5384693101,-0.5384693101, 0.,0.,0.,0.,0.9061798459,-0.9061798459, 0.,0.,0.,0., 0.5384693101,-0.5384693101,0.5384693101,-0.5384693101, 0.5384693101,-0.5384693101,0.5384693101,-0.5384693101, 0.,0.,0.,0., 0.9061798459,-0.9061798459,0.9061798459,-0.9061798459, 0.9061798459,-0.9061798459,0.9061798459,-0.9061798459, 0.,0.,0.,0., 0.,0.,0.,0., 0.9061798459,-0.9061798459,0.9061798459,-0.9061798459, 0.5384693101,-0.5384693101,0.5384693101,-0.5384693101, 0.9061798459,-0.9061798459,0.9061798459,-0.9061798459, 0.5384693101,-0.5384693101,0.5384693101,-0.5384693101, 0.5384693101,-0.5384693101,0.5384693101,-0.5384693101, 0.5384693101,-0.5384693101,0.5384693101,-0.5384693101, 0.9061798459,-0.9061798459,0.9061798459,-0.9061798459, 0.9061798459,-0.9061798459,0.9061798459,-0.9061798459}; static double phex77[77] = {-2.2577865569E+00, 1.704933503,1.704933503,1.704933503,1.704933503, 1.704933503,1.704933503, -0.2524056575,-0.2524056575,-0.2524056575,-0.2524056575, -0.2524056575,-0.2524056575, -0.8069802194,-0.8069802194,-0.8069802194,-0.8069802194, -0.8069802194,-0.8069802194,-0.8069802194,-0.8069802194, -0.8069802194,-0.8069802194,-0.8069802194,-0.8069802194, 3.4187901E-02,3.4187901E-02,3.4187901E-02,3.4187901E-02, 3.4187901E-02,3.4187901E-02,3.4187901E-02,3.4187901E-02, 3.4187901E-02,3.4187901E-02,3.4187901E-02,3.4187901E-02, 0.2268,0.2268,0.2268,0.2268,0.2268,0.2268,0.2268,0.2268, 0.2268,0.2268,0.2268,0.2268,0.2268,0.2268,0.2268,0.2268, 0.2268,0.2268,0.2268,0.2268,0.2268,0.2268,0.2268,0.2268, 0.6325755140,0.6325755140,0.6325755140,0.6325755140, 0.6325755140,0.6325755140,0.6325755140,0.6325755140, 3.9040398E-02,3.9040398E-02,3.9040398E-02,3.9040398E-02, 3.9040398E-02,3.9040398E-02,3.9040398E-02,3.9040398E-02}; getdp-2.4.2-source/Legacy/EigenSolve.cpp000644 001750 001750 00000002332 12116424202 021542 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "GetDPConfig.h" #include "Message.h" #include "EigenSolve.h" #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) #define PetscTruth PetscBool #define PetscOptionsGetTruth PetscOptionsGetBool #endif void EigenSolve(struct DofData * DofData_P, int NumEigenvalues, double shift_r, double shift_i) { #if defined(HAVE_ARPACK) && defined(HAVE_SLEPC) // if both Arpack and SLEPC are available, use Arpack by default // (set "-slepc" on the command line to force SLEPC) PetscTruth slepc = PETSC_FALSE, set; PetscOptionsGetTruth(PETSC_NULL, "-slepc", &slepc, &set); if(slepc) EigenSolve_SLEPC(DofData_P, NumEigenvalues, shift_r, shift_i); else EigenSolve_ARPACK(DofData_P, NumEigenvalues, shift_r, shift_i); #elif defined(HAVE_ARPACK) EigenSolve_ARPACK(DofData_P, NumEigenvalues, shift_r, shift_i); #elif defined(HAVE_SLEPC) EigenSolve_SLEPC(DofData_P, NumEigenvalues, shift_r, shift_i); #else Message::Error("EigenSolve not available without SLEPC or ARPACK"); #endif } getdp-2.4.2-source/Legacy/Cal_GalerkinTermOfFemEquation.cpp000644 001750 001750 00000076724 12116424202 025310 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Johan Gyselinck // Ruth Sabariego // #include #include "ProData.h" #include "ProDefine.h" #include "GeoData.h" #include "DofData.h" #include "Cal_Quantity.h" #include "Cal_Value.h" #include "Cal_IntegralQuantity.h" #include "Cal_AnalyticIntegration.h" #include "Cal_AssembleTerm.h" #include "Cal_GalerkinTermOfFemEquation.h" #include "Get_DofOfElement.h" #include "Get_ElementSource.h" #include "Get_Geometry.h" #include "Get_FunctionValue.h" #include "Pos_Search.h" #include "Message.h" extern struct Problem Problem_S ; extern struct CurrentData Current ; /* ------------------------------------------------------------------------ */ /* C a l _ I n i t G a l e r k i n T e r m O f F e m E q u a t i o n */ /* ------------------------------------------------------------------------ */ void Cal_InitGalerkinTermOfFemEquation(struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0, struct QuantityStorage * QuantityStorageNoDof, struct Dof * DofForNoDof_P) { struct FemLocalTermActive * FI ; extern int MH_Moving_Matrix_simple, MH_Moving_Matrix_probe, MH_Moving_Matrix_separate; FI = EquationTerm_P->Case.LocalTerm.Active ; FI->QuantityStorageEqu_P = QuantityStorage_P0 + EquationTerm_P->Case.LocalTerm.Term.DefineQuantityIndexEqu ; Get_InitFunctionValue(EquationTerm_P->Case.LocalTerm.Term.TypeOperatorEqu, FI->QuantityStorageEqu_P, &FI->Type_FormEqu) ; if (EquationTerm_P->Case.LocalTerm.Term.DefineQuantityIndexDof >= 0) { FI->QuantityStorageDof_P = QuantityStorage_P0 + EquationTerm_P->Case.LocalTerm.Term.DefineQuantityIndexDof ; FI->Type_DefineQuantityDof = FI->QuantityStorageDof_P->DefineQuantity->Type ; } else { FI->QuantityStorageDof_P = QuantityStorageNoDof ; FI->Type_DefineQuantityDof = NODOF ; FI->DofForNoDof_P = DofForNoDof_P ; Dof_InitDofForNoDof(DofForNoDof_P, Current.NbrHar) ; QuantityStorageNoDof->BasisFunction[0].Dof = DofForNoDof_P ; } /* Warning: not correct if nonsymmetrical tensor in expression */ FI->SymmetricalMatrix = (EquationTerm_P->Case.LocalTerm.Term.DefineQuantityIndexEqu == EquationTerm_P->Case.LocalTerm.Term.DefineQuantityIndexDof) && (EquationTerm_P->Case.LocalTerm.Term.TypeOperatorEqu == EquationTerm_P->Case.LocalTerm.Term.TypeOperatorDof) ; if(EquationTerm_P->Case.LocalTerm.Term.CanonicalWholeQuantity_Equ != CWQ_NONE) FI->SymmetricalMatrix = 0 ; if (FI->SymmetricalMatrix) { FI->Type_FormDof = FI->Type_FormEqu ; } else { switch (FI->Type_DefineQuantityDof) { case LOCALQUANTITY : Get_InitFunctionValue(EquationTerm_P->Case.LocalTerm.Term.TypeOperatorDof, FI->QuantityStorageDof_P, &FI->Type_FormDof) ; break ; case INTEGRALQUANTITY : if(EquationTerm_P->Case.LocalTerm.Term.TypeOperatorDof != NOOP){ Message::Error("No operator can act on an Integral Quantity"); } FI->Type_FormDof = VECTOR ; /* we don't know the type a priori */ FI->IntegralQuantityActive.IntegrationCase_L = ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, FI->QuantityStorageDof_P->DefineQuantity-> IntegralQuantity.IntegrationMethodIndex)) ->IntegrationCase ; FI->IntegralQuantityActive.CriterionIndex = ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, FI->QuantityStorageDof_P->DefineQuantity-> IntegralQuantity.IntegrationMethodIndex)) ->CriterionIndex ; FI->IntegralQuantityActive.JacobianCase_L = ((struct JacobianMethod *) List_Pointer(Problem_S.JacobianMethod, FI->QuantityStorageDof_P->DefineQuantity-> IntegralQuantity.JacobianMethodIndex)) ->JacobianCase ; break ; case NODOF : FI->Type_FormDof = SCALAR ; break ; } } FI->Type_ValueDof = Get_ValueFromForm(FI->Type_FormDof); /* G e t I n t e g r a t i o n M e t h o d */ /* -------------------------------------------- */ if(EquationTerm_P->Case.LocalTerm.IntegrationMethodIndex < 0){ Message::Error("Integration method missing in equation term"); FI->IntegrationCase_L = 0; } else{ FI->IntegrationCase_L = ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, EquationTerm_P->Case.LocalTerm.IntegrationMethodIndex)) ->IntegrationCase ; FI->CriterionIndex = ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, EquationTerm_P->Case.LocalTerm.IntegrationMethodIndex)) ->CriterionIndex ; } /* G e t J a c o b i a n M e t h o d */ /* -------------------------------------- */ if(EquationTerm_P->Case.LocalTerm.JacobianMethodIndex < 0){ Message::Error("Jacobian method missing in equation term"); FI->JacobianCase_L = 0; } else{ FI->JacobianCase_L = ((struct JacobianMethod *) List_Pointer(Problem_S.JacobianMethod, EquationTerm_P->Case.LocalTerm.JacobianMethodIndex)) ->JacobianCase ; FI->JacobianCase_P0 = (FI->NbrJacobianCase = List_Nbr(FI->JacobianCase_L)) ? (struct JacobianCase*)List_Pointer(FI->JacobianCase_L, 0) : NULL ; } FI->Flag_ChangeCoord = ( FI->SymmetricalMatrix || !( ( (FI->Type_FormEqu == FORM0 || FI->Type_FormEqu == FORM0P) && (FI->Type_FormDof == FORM3 || FI->Type_FormDof == FORM3P) ) || /* ( (FI->Type_FormEqu == FORM1 || FI->Type_FormEqu == FORM1P) && (FI->Type_FormDof == FORM2 || FI->Type_FormDof == FORM2P) ) || ( (FI->Type_FormEqu == FORM2 || FI->Type_FormEqu == FORM2P) && (FI->Type_FormDof == FORM1 || FI->Type_FormDof == FORM1P) ) || */ ( (FI->Type_FormEqu == FORM3 || FI->Type_FormEqu == FORM3P) && (FI->Type_FormDof == FORM0 || FI->Type_FormDof == FORM0P) ) ) ) || /* For operators on VECTOR's (To be extended) */ (FI->Type_FormEqu == VECTOR || FI->Type_FormDof == VECTOR) || (FI->Type_DefineQuantityDof == INTEGRALQUANTITY) ; if (FI->Flag_ChangeCoord){ FI->Flag_InvJac = ( (FI->Type_FormEqu == FORM1) || (!FI->SymmetricalMatrix && (FI->Type_FormDof == FORM1)) || /* For operators on VECTOR's (To be extended) */ (FI->Type_FormEqu == VECTOR || FI->Type_FormDof == VECTOR) || (EquationTerm_P->Case.LocalTerm.Term.QuantityIndexPost == 1) ) ; } /* G e t C h a n g e O f C o o r d i n a t e s */ /* ---------------------------------------------- */ FI->xChangeOfCoordinatesEqu = (void (*)())Get_ChangeOfCoordinates(FI->Flag_ChangeCoord, FI->Type_FormEqu) ; if (!FI->SymmetricalMatrix) FI->xChangeOfCoordinatesDof = (void (*)())Get_ChangeOfCoordinates(FI->Flag_ChangeCoord, FI->Type_FormDof) ; else FI->xChangeOfCoordinatesDof = (void (*)())Get_ChangeOfCoordinates(0, FI->Type_FormDof) ; /* Used only for transfer */ /* G e t C a l _ P r o d u c t x */ /* -------------------------------- */ switch (FI->Type_FormEqu) { case FORM1 : case FORM1S : case FORM2 : case FORM2P : case FORM2S : case VECTOR : FI->Cal_Productx = (double (*)())Cal_Product123 ; break ; case FORM1P : case VECTORP : FI->Cal_Productx = (double (*)())Cal_Product3 ; break ; case FORM0 : case FORM3 : case FORM3P : case SCALAR : FI->Cal_Productx = (double (*)())Cal_Product1 ; break ; default : Message::Error("Unknown type of Form (%d)", FI->Type_FormEqu); FI->Cal_Productx = (double (*)())Cal_Product123 ; break ; } /* G e t F u n c t i o n _ A s s e m b l e T e r m */ /* ------------------------------------------------- */ switch (EquationTerm_P->Case.LocalTerm.Term.TypeTimeDerivative) { case NODT_ : FI->Function_AssembleTerm = (void (*)())Cal_AssembleTerm_NoDt ; break; case DT_ : FI->Function_AssembleTerm = (void (*)())Cal_AssembleTerm_Dt ; break; case DTDOF_ : FI->Function_AssembleTerm = (void (*)())Cal_AssembleTerm_DtDof ; break; case DTDT_ : FI->Function_AssembleTerm = (void (*)())Cal_AssembleTerm_DtDt ; break; case DTDTDOF_ : FI->Function_AssembleTerm = (void (*)())Cal_AssembleTerm_DtDtDof; break; case JACNL_ : FI->Function_AssembleTerm = (void (*)())Cal_AssembleTerm_JacNL ; break; case DTDOFJACNL_ : FI->Function_AssembleTerm = (void (*)())Cal_AssembleTerm_DtDofJacNL; break; case NEVERDT_ : FI->Function_AssembleTerm = (void (*)())Cal_AssembleTerm_NeverDt; break; case DTNL_ : FI->Function_AssembleTerm = (void (*)())Cal_AssembleTerm_DtNL ; break; default : Message::Error("Unknown type of Operator for Galerkin term (%d)", EquationTerm_P->Case.LocalTerm.Term.TypeTimeDerivative); FI->Function_AssembleTerm = (void (*)())Cal_AssembleTerm_NoDt ; break; } if (MH_Moving_Matrix_simple) { /* Message::Info("AssembleTerm_MH_Moving") ; */ FI->Function_AssembleTerm = (void (*)())Cal_AssembleTerm_MH_Moving_simple ; } if (MH_Moving_Matrix_probe) { /* Message::Info("AssembleTerm_MH_Moving") ; */ FI->Function_AssembleTerm = (void (*)())Cal_AssembleTerm_MH_Moving_probe ; } if (MH_Moving_Matrix_separate) { /* Message::Info("AssembleTerm_MH_Moving") ; */ FI->Function_AssembleTerm = (void (*)())Cal_AssembleTerm_MH_Moving_separate ; } /* initialisation of MHJacNL-term (nonlinear multi-harmonics) if necessary */ Cal_InitGalerkinTermOfFemEquation_MHJacNL(EquationTerm_P); /* Full_Matrix */ if (EquationTerm_P->Case.LocalTerm.Full_Matrix) { FI->Full_Matrix = 1; FI->FirstElements = List_Create(20, 10, sizeof(struct FirstElement)) ; } } /* ------------------------------------------------------------------------ */ /* C a l _ a p p l y M e t r i c T e n s o r */ /* ------------------------------------------------------------------------ */ void Cal_applyMetricTensor(struct EquationTerm * EquationTerm_P, struct FemLocalTermActive * FI, struct QuantityStorage * QuantityStorage_P0, int Nbr_Dof, struct Value vBFxDof[]) { int j; int mi; struct Value S; struct Value detS; mi = EquationTerm_P->Case.LocalTerm.ExpressionIndexForMetricTensor; if(mi == -1) return; Get_ValueOfExpression ((struct Expression*)List_Pointer(Problem_S.Expression, mi), QuantityStorage_P0, Current.u, Current.v, Current.w, &S) ; if(S.Type == SCALAR) { S.Type = TENSOR_DIAG; S.Val[1] = S.Val[0]; S.Val[2] = S.Val[0]; } if(S.Type != TENSOR_SYM && S.Type != TENSOR && S.Type != TENSOR_DIAG) { Message::Error("Cannot interpret field type %s as metric tensor", Get_StringForDefine(Field_Type, S.Type)); return; } Cal_DetValue(&S, &detS); detS.Val[0] = sqrt(fabs(detS.Val[0])); switch (FI->Type_FormDof) { case FORM1 : case FORM1S : case FORM1P : Cal_InvertValue(&S, &S); for (j = 0 ; j < Nbr_Dof ; j++) { Cal_ProductValue(&S, &vBFxDof[j], &vBFxDof[j]); Cal_ProductValue(&detS, &vBFxDof[j], &vBFxDof[j]); } break; case FORM2 : case FORM2S : case FORM2P : Cal_InvertValue(&detS, &detS); for (j = 0 ; j < Nbr_Dof ; j++) { Cal_ProductValue(&S, &vBFxDof[j], &vBFxDof[j]); Cal_ProductValue(&detS, &vBFxDof[j], &vBFxDof[j]); } break; case FORM3 : case FORM3S : case FORM3P : Cal_InvertValue(&detS, &detS); for (j = 0 ; j < Nbr_Dof ; j++) { Cal_ProductValue(&detS, &vBFxDof[j], &vBFxDof[j]); } break; case FORM0 : case FORM0S : case FORM0P : for (j = 0 ; j < Nbr_Dof ; j++) { Cal_ProductValue(&detS, &vBFxDof[j], &vBFxDof[j]); } break; default: Message::Error("Cannot use metric tensor with field type %s", Get_StringForDefine(Field_Type, FI->Type_FormDof)); break; } } /* ------------------------------------------------------------------------ */ /* C a l _ v B F x D o f */ /* ------------------------------------------------------------------------ */ void Cal_vBFxDof(struct EquationTerm * EquationTerm_P, struct FemLocalTermActive * FI, struct QuantityStorage * QuantityStorage_P0, struct QuantityStorage * QuantityStorageDof_P, int Nbr_Dof, void (*xFunctionBFDof[NBR_MAX_BASISFUNCTIONS]) (struct Element * Element, int NumEntity, double u, double v, double w, double Value[]), double vBFxEqu[][MAX_DIM], struct Value vBFxDof[]) { double vBFuDof[NBR_MAX_BASISFUNCTIONS] [MAX_DIM] ; double u, v, w ; struct Value CoefPhys ; struct Element *E ; int i, j ; if(EquationTerm_P->Case.LocalTerm.Term.DofInTrace){ E = Current.Element->ElementTrace ; Current.x = Current.y = Current.z = 0. ; for (i = 0 ; i < Current.Element->GeoElement->NbrNodes ; i++) { Current.x += Current.Element->x[i] * Current.Element->n[i] ; Current.y += Current.Element->y[i] * Current.Element->n[i] ; Current.z += Current.Element->z[i] * Current.Element->n[i] ; } xyz2uvwInAnElement(E, Current.x, Current.y, Current.z, &Current.ut, &Current.vt, &Current.wt) ; u = Current.ut ; v = Current.vt ; w = Current.wt ; } else{ E = Current.Element ; u = Current.u ; v = Current.v ; w = Current.w ; } /* shape functions, integral quantity or dummy */ if (!FI->SymmetricalMatrix) { switch (FI->Type_DefineQuantityDof) { case LOCALQUANTITY : for (j = 0 ; j < Nbr_Dof ; j++) { xFunctionBFDof[j] (E, QuantityStorageDof_P->BasisFunction[j].NumEntityInElement+1, u, v, w, vBFuDof[j]) ; ((void (*)(struct Element*, double*, double*)) FI->xChangeOfCoordinatesDof) (E, vBFuDof[j], vBFxDof[j].Val) ; vBFxDof[j].Type = FI->Type_ValueDof ; if(Current.NbrHar > 1) Cal_SetHarmonicValue(&vBFxDof[j]) ; /* temp (rather add QuantityStorage_P to CurrentData) */ Current.NumEntities[j] = QuantityStorageDof_P->BasisFunction[j].CodeEntity; } break ; case INTEGRALQUANTITY : if (FI->IntegralQuantityActive.IntegrationCase_P->Type == ANALYTIC) Cal_AnalyticIntegralQuantity (Current.Element, QuantityStorageDof_P, Nbr_Dof, (void (**)())xFunctionBFDof, vBFxDof) ; else Cal_NumericalIntegralQuantity (Current.Element, &FI->IntegralQuantityActive, QuantityStorage_P0, QuantityStorageDof_P, FI->Type_DefineQuantityDof, Nbr_Dof, (void (**)())xFunctionBFDof, vBFxDof) ; FI->Type_ValueDof = FI->Type_FormDof = vBFxDof[0].Type; /* now this type is correct */ break ; case NODOF : /* Supprimer le DofForNoDof_P de la structure dans Data_Active.h */ /* QuantityStorageDof_P->BasisFunction[0].Dof = FI->DofForNoDof_P ; */ break ; } } else { for (j = 0 ; j < Nbr_Dof ; j++){ ((void (*)(struct Element*, double*, double*)) FI->xChangeOfCoordinatesDof) (Current.Element, vBFxEqu[j], vBFxDof[j].Val) ; vBFxDof[j].Type = FI->Type_ValueDof ; if(Current.NbrHar > 1) Cal_SetHarmonicValue(&vBFxDof[j]) ; } } /* Compute remaining factors in the term */ if (EquationTerm_P->Case.LocalTerm.Term.CanonicalWholeQuantity == CWQ_DOF) { } else if (EquationTerm_P->Case.LocalTerm.Term.CanonicalWholeQuantity == CWQ_EXP_TIME_DOF) { Get_ValueOfExpression ((struct Expression*)List_Pointer (Problem_S.Expression, EquationTerm_P->Case.LocalTerm.Term.ExpressionIndexForCanonical), QuantityStorage_P0, Current.u, Current.v, Current.w, &CoefPhys) ; for (j = 0 ; j < Nbr_Dof ; j++) Cal_ProductValue(&CoefPhys, &vBFxDof[j], &vBFxDof[j]) ; } else Cal_WholeQuantity (Current.Element, QuantityStorage_P0, EquationTerm_P->Case.LocalTerm.Term.WholeQuantity, Current.u, Current.v, Current.w, EquationTerm_P->Case.LocalTerm.Term.DofIndexInWholeQuantity, Nbr_Dof, vBFxDof) ; /* Compute using metric tensor if defined */ Cal_applyMetricTensor(EquationTerm_P, FI, QuantityStorage_P0, Nbr_Dof, vBFxDof); } /* ------------------------------------------------------------------------ */ /* C a l _ T e r m O f F e m E q u a t i o n */ /* ------------------------------------------------------------------------ */ void Cal_GalerkinTermOfFemEquation(struct Element * Element, struct EquationTerm * EquationTerm_P, struct QuantityStorage * QuantityStorage_P0) { struct FemLocalTermActive * FI ; struct QuantityStorage * QuantityStorageEqu_P, * QuantityStorageDof_P ; struct IntegrationCase * IntegrationCase_P ; struct Quadrature * Quadrature_P ; struct Value vBFxDof [NBR_MAX_BASISFUNCTIONS], CoefPhys ; struct Value CanonicExpression_Equ, V1, V2; int Nbr_Equ, Nbr_Dof = 0; int i, j, k, Type_Dimension, Nbr_IntPoints, i_IntPoint ; int NextElement ; double weight, Factor = 1. ; double vBFuEqu [NBR_MAX_BASISFUNCTIONS] [MAX_DIM] ; double vBFxEqu [NBR_MAX_BASISFUNCTIONS] [MAX_DIM] ; double Ek [NBR_MAX_BASISFUNCTIONS] [NBR_MAX_BASISFUNCTIONS] [NBR_MAX_HARMONIC] ; void (*xFunctionBFEqu[NBR_MAX_BASISFUNCTIONS]) (struct Element * Element, int NumEntity, double u, double v, double w, double Value[] ) ; void (*xFunctionBFDof[NBR_MAX_BASISFUNCTIONS]) (struct Element * Element, int NumEntity, double u, double v, double w, double Value[] ) ; double (*Get_Jacobian)(struct Element*, MATRIX3x3*) ; void (*Get_IntPoint)(int,int,double*,double*,double*,double*); extern int Flag_RHS; Current.flagAssDiag = 0; /*+++prov*/ FI = EquationTerm_P->Case.LocalTerm.Active ; /* treatment of MHJacNL-term in separate routine */ if (FI->MHJacNL) { /* if only the RHS of the system is to be calculated (in case of adaptive relaxation of the Newton-Raphson scheme) the (expensive and redundant) calculation of this term can be skipped */ if (!Flag_RHS) Cal_GalerkinTermOfFemEquation_MHJacNL(Element, EquationTerm_P, QuantityStorage_P0) ; return; } QuantityStorageEqu_P = FI->QuantityStorageEqu_P ; QuantityStorageDof_P = FI->QuantityStorageDof_P ; /* skip computation completely if term does not contribute to RHS. This is OK, but the speed-up is not the best, due to the time-consuming--but necessary-- initializations that still need to be done before arriving at this point in the assembly process. For best performance use GenerateRHSGroup instead of GenerateRHS, and include any RHS-contributions (elements containing fixed dofs or non-dof expressions) in the given groups */ if(Current.DofData->Flag_RHS){ if(FI->Type_DefineQuantityDof == LOCALQUANTITY){ bool skip = true; int Nbr_Dof = FI->SymmetricalMatrix ? QuantityStorageEqu_P->NbrElementaryBasisFunction : QuantityStorageDof_P->NbrElementaryBasisFunction; for (int j = 0 ; j < Nbr_Dof ; j++){ Dof *Dof_P = QuantityStorageDof_P->BasisFunction[j].Dof; if(Dof_P->Type != DOF_UNKNOWN){ skip = false; break; } } if(skip) return; } } /* ---------------------------------------------------------------------- */ /* G e t F u n c t i o n V a l u e f o r t e s t f u n c t i o n s */ /* ---------------------------------------------------------------------- */ if (!(Nbr_Equ = QuantityStorageEqu_P->NbrElementaryBasisFunction)) { return ; } if(Nbr_Equ > NBR_MAX_BASISFUNCTIONS) Message::Fatal("Number of basis functions (%d) exceeds NBR_MAX_BASISFUNCTIONS: " "please recompile after changing Interface/ProData.h", Nbr_Equ); Get_FunctionValue(Nbr_Equ, (void (**)())xFunctionBFEqu, EquationTerm_P->Case.LocalTerm.Term.TypeOperatorEqu, QuantityStorageEqu_P, &FI->Type_FormEqu) ; /* ---------------------------------------------------------------------- */ /* G e t F u n c t i o n V a l u e f o r s h a p e f u n c t i o n s */ /* ---------------------------------------------------------------------- */ if (FI->SymmetricalMatrix){ Nbr_Dof = Nbr_Equ ; } else{ switch (FI->Type_DefineQuantityDof) { case LOCALQUANTITY : Nbr_Dof = QuantityStorageDof_P->NbrElementaryBasisFunction ; Get_FunctionValue(Nbr_Dof, (void (**)())xFunctionBFDof, EquationTerm_P->Case.LocalTerm.Term.TypeOperatorDof, QuantityStorageDof_P, &FI->Type_FormDof) ; break ; case INTEGRALQUANTITY : Get_InitElementSource(Element, QuantityStorageDof_P->DefineQuantity->IntegralQuantity.InIndex) ; break ; case NODOF : Nbr_Dof = 1 ; break ; } } /* ------------------------------------------------------------------- */ /* G e t I n t e g r a t i o n M e t h o d */ /* ------------------------------------------------------------------- */ IntegrationCase_P = Get_IntegrationCase(Element, FI->IntegrationCase_L, FI->CriterionIndex); /* ------------------------------------------------------------------- */ /* G e t J a c o b i a n M e t h o d */ /* ------------------------------------------------------------------- */ i = 0 ; while ((i < FI->NbrJacobianCase) && ((j = (FI->JacobianCase_P0 + i)->RegionIndex) >= 0) && !List_Search (((struct Group *)List_Pointer(Problem_S.Group, j)) ->InitialList, &Element->Region, fcmp_int) ) i++ ; if (i == FI->NbrJacobianCase){ Message::Error("Undefined Jacobian in Region %d", Element->Region); return; } Element->JacobianCase = FI->JacobianCase_P0 + i ; Get_Jacobian = (double (*)(struct Element*, MATRIX3x3*)) Get_JacobianFunction(Element->JacobianCase->TypeJacobian, Element->Type, &Type_Dimension) ; if (FI->Flag_ChangeCoord) Get_NodesCoordinatesOfElement(Element) ; /* ------------------------------------------------------------------------ */ /* ------------------------------------------------------------------------ */ /* C o m p u t a t i o n o f E l e m e n t a r y m a t r i x */ /* ------------------------------------------------------------------------ */ /* ------------------------------------------------------------------------ */ /* Loop on source elements (> 1 only if integral quantity) */ while (1) { if (FI->Type_DefineQuantityDof == INTEGRALQUANTITY) { NextElement = Get_NextElementSource(Element->ElementSource) ; if (NextElement) { /* Get DOF of source element */ Get_DofOfElement(Element->ElementSource, QuantityStorageDof_P->FunctionSpace, QuantityStorageDof_P, NULL) ; /* Get function value for shape function */ Get_NodesCoordinatesOfElement(Element->ElementSource) ; Nbr_Dof = QuantityStorageDof_P->NbrElementaryBasisFunction ; Get_FunctionValue (Nbr_Dof, (void (**)())xFunctionBFDof, QuantityStorageDof_P->DefineQuantity->IntegralQuantity.TypeOperatorDof, QuantityStorageDof_P, &FI->IntegralQuantityActive.Type_FormDof) ; /* Initialize Integral Quantity (integration & jacobian) */ Cal_InitIntegralQuantity(Element, &FI->IntegralQuantityActive, QuantityStorageDof_P); } else { break ; } /* if NextElement */ } /* if INTEGRALQUANTITY */ if (FI->SymmetricalMatrix) for (i = 0 ; i < Nbr_Equ ; i++) for (j = 0 ; j <= i ; j++) for (k = 0 ; k < Current.NbrHar ; k++) Ek[i][j][k] = 0. ; else for (i = 0 ; i < Nbr_Equ ; i++) for (j = 0 ; j < Nbr_Dof ; j++) for (k = 0 ; k < Current.NbrHar ; k++) Ek[i][j][k] = 0. ; switch (IntegrationCase_P->Type) { /* ------------------------------------- */ /* Q U A D R A T U R E */ /* ------------------------------------- */ case GAUSS : case GAUSSLEGENDRE : Quadrature_P = (struct Quadrature*) List_PQuery(IntegrationCase_P->Case, &Element->Type, fcmp_int); if(!Quadrature_P) Message::Error ("Unknown type of Element (%s) for Integration method (%s)", Get_StringForDefine(Element_Type, Element->Type), ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, EquationTerm_P->Case.LocalTerm.IntegrationMethodIndex))->Name); Nbr_IntPoints = Quadrature_P->NumberOfPoints ; Get_IntPoint = (void(*)(int,int,double*,double*,double*,double*)) Quadrature_P->Function ; for (i_IntPoint = 0 ; i_IntPoint < Nbr_IntPoints ; i_IntPoint++) { Get_IntPoint(Nbr_IntPoints, i_IntPoint, &Current.u, &Current.v, &Current.w, &weight) ; if (FI->Flag_ChangeCoord) { Get_BFGeoElement(Element, Current.u, Current.v, Current.w) ; Element->DetJac = Get_Jacobian(Element, &Element->Jac) ; if (FI->Flag_InvJac) Get_InverseMatrix(Type_Dimension, Element->Type, Element->DetJac, &Element->Jac, &Element->InvJac) ; } /* Test Functions */ if(EquationTerm_P->Case.LocalTerm.Term.CanonicalWholeQuantity_Equ == CWQ_EXP_TIME_DOF) Get_ValueOfExpressionByIndex (EquationTerm_P->Case.LocalTerm.Term.ExpressionIndexForCanonical_Equ, QuantityStorage_P0, Current.u, Current.v, Current.w, &CanonicExpression_Equ) ; for (i = 0 ; i < Nbr_Equ ; i++) { xFunctionBFEqu[i] (Element, QuantityStorageEqu_P->BasisFunction[i].NumEntityInElement+1, Current.u, Current.v, Current.w, vBFuEqu[i]) ; ((void (*)(struct Element*, double*, double*)) FI->xChangeOfCoordinatesEqu) (Element, vBFuEqu[i], vBFxEqu[i]) ; if(EquationTerm_P->Case.LocalTerm.Term.CanonicalWholeQuantity_Equ != CWQ_NONE){ V1.Type = Get_ValueFromForm(FI->Type_FormEqu); V1.Val[0] = vBFxEqu[i][0] ; V1.Val[1] = vBFxEqu[i][1] ; V1.Val[2] = vBFxEqu[i][2] ; V1.Val[MAX_DIM] = 0; V1.Val[MAX_DIM+1] = 0; V1.Val[MAX_DIM+2] = 0; if(EquationTerm_P->Case.LocalTerm.Term.CanonicalWholeQuantity_Equ == CWQ_EXP_TIME_DOF){ switch(EquationTerm_P->Case.LocalTerm.Term.OperatorTypeForCanonical_Equ){ case OP_TIME : Cal_ProductValue (&CanonicExpression_Equ,&V1,&V2); break; case OP_CROSSPRODUCT : Cal_CrossProductValue (&CanonicExpression_Equ,&V1,&V2); break; default : Message::Error("Unknown operation in Equation"); break; } } else if(EquationTerm_P->Case.LocalTerm.Term.CanonicalWholeQuantity_Equ == CWQ_FCT_DOF){ ((void(*)(struct Function*, struct Value*, struct Value*)) EquationTerm_P->Case.LocalTerm.Term.BuiltInFunction_Equ) (NULL, &V1, &V2) ; } vBFxEqu[i][0] = V2.Val[0]; vBFxEqu[i][1] = V2.Val[1]; vBFxEqu[i][2] = V2.Val[2]; } } /* for Nbr_Equ */ /* Shape Functions (+ surrounding expression) */ Current.Element = Element ; Cal_vBFxDof(EquationTerm_P, FI, QuantityStorage_P0, QuantityStorageDof_P, Nbr_Dof, xFunctionBFDof, vBFxEqu, vBFxDof); Factor = (FI->Flag_ChangeCoord) ? weight * fabs(Element->DetJac) : weight ; /* Product and assembly in elementary submatrix (k?-1.:1.)* */ if (FI->SymmetricalMatrix) for (i = 0 ; i < Nbr_Equ ; i++) for (j = 0 ; j <= i ; j++) for (k = 0 ; k < Current.NbrHar ; k++) Ek[i][j][k] += Factor * ((double (*)(double*, double*)) FI->Cal_Productx) (vBFxEqu[i], &(vBFxDof[j].Val[MAX_DIM*k])) ; else for (i = 0 ; i < Nbr_Equ ; i++) for (j = 0 ; j < Nbr_Dof ; j++) for (k = 0 ; k < Current.NbrHar ; k++) Ek[i][j][k] += Factor * ((double (*)(double*, double*)) FI->Cal_Productx) (vBFxEqu[i], &(vBFxDof[j].Val[MAX_DIM*k])); } /* for i_IntPoint ... */ break ; /* case GAUSS */ /* ------------------------------------- */ /* A N A L Y T I C */ /* ------------------------------------- */ case ANALYTIC : if (EquationTerm_P->Case.LocalTerm.Term.CanonicalWholeQuantity == CWQ_DOF) { Factor = 1. ; } if (EquationTerm_P->Case.LocalTerm.Term.CanonicalWholeQuantity == CWQ_EXP_TIME_DOF) { if (EquationTerm_P->Case.LocalTerm.Term.ExpressionIndexForCanonical >= 0) { Get_ValueOfExpression ((struct Expression *)List_Pointer (Problem_S.Expression, EquationTerm_P->Case.LocalTerm.Term.ExpressionIndexForCanonical), QuantityStorage_P0, 0., 0., 0., &CoefPhys) ; Factor = CoefPhys.Val[0] ; } } else { Message::Error("Bad expression for full analytic integration"); } if (FI->SymmetricalMatrix) { for (i = 0 ; i < Nbr_Equ ; i++) for (j = 0 ; j <= i ; j++) Ek[i][j][0] = Factor * Cal_AnalyticIntegration (Element, (void (*)())xFunctionBFEqu[i], (void (*)())xFunctionBFEqu[j], i, j, FI->Cal_Productx) ; } else { switch (FI->Type_DefineQuantityDof) { case LOCALQUANTITY : for (i = 0 ; i < Nbr_Equ ; i++) for (j = 0 ; j < Nbr_Dof ; j++) Ek[i][j][0] = Factor * Cal_AnalyticIntegration (Element, (void (*)())xFunctionBFEqu[i], (void (*)())xFunctionBFDof[j], i, j, FI->Cal_Productx) ; break; default : Message::Error("Exterior analytical integration not implemented"); break; } } break ; /* case ANALYTIC */ default : Message::Error ("Unknown type of Integration method (%s)", ((struct IntegrationMethod *) List_Pointer(Problem_S.IntegrationMethod, EquationTerm_P->Case.LocalTerm.IntegrationMethodIndex))->Name); break; } /* Complete elementary matrix if symmetrical */ /* ----------------------------------------- */ if (FI->SymmetricalMatrix) for (i = 1 ; i < Nbr_Equ ; i++) for (j = 0 ; j < i ; j++) for (k = 0 ; k < Current.NbrHar ; k++) Ek[j][i][k] = Ek[i][j][k] ; if(Message::GetVerbosity() == 10) { printf("Galerkin = ") ; for (j = 0 ; j < Nbr_Dof ; j++) Print_DofNumber(QuantityStorageDof_P->BasisFunction[j].Dof) ; printf("\n") ; for (i = 0 ; i < Nbr_Equ ; i++) { Print_DofNumber(QuantityStorageEqu_P->BasisFunction[i].Dof) ; printf("[ ") ; for (j = 0 ; j < Nbr_Dof ; j++) { printf("(") ; for(k = 0 ; k < Current.NbrHar ; k++) printf("% .5e ", Ek[i][j][k]) ; printf(")") ; } printf("]\n") ; } } /* Assembly in global matrix */ /* ------------------------- */ if (!Current.flagAssDiag) /*+++prov*/ for (i = 0 ; i < Nbr_Equ ; i++) for (j = 0 ; j < Nbr_Dof ; j++) ((void (*)(struct Dof*, struct Dof*, double*)) FI->Function_AssembleTerm) (QuantityStorageEqu_P->BasisFunction[i].Dof, QuantityStorageDof_P->BasisFunction[j].Dof, Ek[i][j]) ; else if (Current.flagAssDiag == 1) { for (i = 0 ; i < Nbr_Equ ; i++) { /* for (j = 0 ; j < Nbr_Dof ; j++)*/ j = i; ((void (*)(struct Dof*, struct Dof*, double*)) FI->Function_AssembleTerm) (QuantityStorageEqu_P->BasisFunction[i].Dof, QuantityStorageDof_P->BasisFunction[j].Dof, Ek[i][j]) ; } } else if (Current.flagAssDiag == 2) { for (i = 0 ; i < Nbr_Equ ; i++) { /* for (j = 0 ; j < Nbr_Dof ; j++)*/ j = i; Ek[i][j][0] = -1.; for (k = 1 ; k < Current.NbrHar ; k++) Ek[i][j][k] = 0. ; ((void (*)(struct Dof*, struct Dof*, double*)) FI->Function_AssembleTerm) (QuantityStorageEqu_P->BasisFunction[i].Dof, QuantityStorageDof_P->BasisFunction[j].Dof, Ek[i][j]) ; } } /* Exit while(1) directly if not integral quantity */ if (FI->Type_DefineQuantityDof != INTEGRALQUANTITY) break ; } /* while (1) ... */ Current.flagAssDiag = 0; /*+++prov*/ } getdp-2.4.2-source/Legacy/MainLegacy.h000644 001750 001750 00000000447 12116424202 021165 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _MAIN_LEGACY_H_ #define _MAIN_LEGACY_H_ int MainLegacy(int argc, char *argv[]); #endif getdp-2.4.2-source/Legacy/Generate_Network.cpp000644 001750 001750 00000014354 12171312076 022762 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "ProData.h" #include "ListUtils.h" #include "MallocUtils.h" #include "Message.h" extern int Flag_NETWORK_CACHE; extern char *Name_Path ; /* ------------------------------------------------------------------------ */ /* G e n e r a t e _ N e t w o r k */ /* ------------------------------------------------------------------------ */ /* Determination of the matrix 'Loop - Branch' from the matrix 'Node - Branch' */ struct ConstraintActive * Generate_Network(char *Name, List_T * ConstraintPerRegion_L) { /* List of the Nodes of the Network */ List_T *ListInt_L = List_Create(10, 10, sizeof(int)) ; int Nbr_Branch = List_Nbr(ConstraintPerRegion_L) ; if (!Nbr_Branch) Message::Error("No branch in Network") ; struct ConstraintPerRegion * CPR ; for (int j = 0 ; j < Nbr_Branch ; j++) { CPR = (struct ConstraintPerRegion *)List_Pointer(ConstraintPerRegion_L, j) ; List_Replace(ListInt_L, &(CPR->Case.Network.Node1), fcmp_int) ; List_Replace(ListInt_L, &(CPR->Case.Network.Node2), fcmp_int) ; } if (Nbr_Branch) List_Sort(ListInt_L, fcmp_int) ; int n = List_Nbr(ListInt_L) - 1 ; /* Nbr_Node - 1 */ int Nbr_Loop = Nbr_Branch - n ; /* Nbr of independent loops */ Message::Info("Network has %d branch(es), %d node(s) and %d loop(s)", Nbr_Branch, n + 1, Nbr_Loop); /* Active data */ struct ConstraintActive * Active = (struct ConstraintActive *)Malloc(sizeof(struct ConstraintActive)) ; Active->Case.Network.NbrNode = n ; Active->Case.Network.NbrBranch = Nbr_Branch ; Active->Case.Network.NbrLoop = Nbr_Loop ; int ** MatNode, ** MatLoop ; Active->Case.Network.MatNode = MatNode = (int **)Malloc(n*sizeof(int *)); for (int i=0 ; iCase.Network.MatLoop = MatLoop = (int **)Malloc(Nbr_Loop*sizeof(int *)); for (int i=0 ; iCase.Network.Node1), fcmp_int)) > 0) MatNode[i-1][j] = -1 ; /* skip index 0, i.e. node 1 */ if ((i = List_ISearch(ListInt_L, &(CPR->Case.Network.Node2), fcmp_int)) > 0) MatNode[i-1][j] = 1 ; } /* Transformation of MatNode -> MatA ... Welsh algorithm */ int ** MatA = (int **)Malloc(n*sizeof(int *)) ; for (int i=0 ; i. #ifndef _DOFDATA_H_ #define _DOFDATA_H_ #include #include "ListUtils.h" #include "TreeUtils.h" #include "LinAlg.h" #define DOF_PRE 1 #define DOF_RES 2 #define DOF_TMP 3 struct Solution { int TimeStep ; /* Must be first member of struct (for searching purposes) */ double Time, TimeImag ; int SolutionExist ; double * TimeFunctionValues, ExplicitTimeFunctionValue ; gVector x ; } ; struct Dof { int NumType ; /* Key 1 */ int Entity ; /* Key 2 */ int Harmonic ; /* Key 3 */ int Type ; /* Val must be out of the union (a member with constructor (gScalar with PETSc) is not allowed in a union); Val holds the init value for Type==Unknown, and the assigned value for Type==FixedAssociate. Val is not used for Type==Link. Val2 potentially holds a second init value for Type==Unknown */ gScalar Val, Val2 ; union { struct { int NumDof ; /* Equation number - 1st position */ bool NonLocal ; /* Set to true if equation is non-local */ } Unknown ; struct { int NumDof ; /* Equation number (Associate) - 1st position */ int TimeFunctionIndex ; } FixedAssociate ; struct { int EntityRef ; double Coef, Coef2 ; struct Dof * Dof ; } Link ; } Case ; } ; /* Dof.Type */ /* definitive in preprocessing and processing */ #define DOF_UNKNOWN 1 /* unknown */ #define DOF_FIXED 2 /* spatial fixed */ #define DOF_FIXEDWITHASSOCIATE 3 /* associate */ #define DOF_LINK 7 /* link */ #define DOF_LINKCPLX 8 /* linkcplx */ /* definitive in a preprocessing */ #define DOF_UNKNOWN_INIT 5 /* initial condition */ /* temporary */ #define DOF_FIXED_SOLVE 4 /* waiting to be fixed by a resolution */ #define DOF_FIXEDWITHASSOCIATE_SOLVE 6 /* waiting to be fixed by a resolution */ struct CorrectionSolutions { List_T * Solutions ; } ; struct DofData { int Num ; int ResolutionIndex, SystemIndex ; int GeoDataIndex ; List_T * FunctionSpaceIndex ; List_T * TimeFunctionIndex ; List_T * Pulsation ; int NbrHar ; double * Val_Pulsation ; int NbrAnyDof, NbrDof ; Tree_T * DofTree ; List_T * DofList ; int * DummyDof ; char * SolverDataFileName ; List_T * Solutions ; struct Solution * CurrentSolution ; struct Solution * Save_CurrentSolution ; struct { int Flag ; List_T * Save_FullSolutions ; struct Solution * Save_CurrentFullSolution ; List_T * AllSolutions ; } CorrectionSolutions ; int Flag_RHS ; // only assemble RHS int Flag_Init[4] ; int Flag_Only ; int Flag_InitOnly[3] ; // For recalculating only the matrices that are required List_T *OnlyTheseMatrices ; // Flag_Init[0] == 1 || Flag_Init[0] == 2 gMatrix A; gVector b; gSolver Solver; // Flag_Init[0] == 2 gMatrix Jac ; gVector res, dx ; // Flag_Init[1,2,3] == 1 gMatrix M1, M2, M3 ; gVector m1, m2, m3 ; List_T *m1s, *m2s, *m3s; // Flag_Only and Flag_InitOnly[0,1,2] gMatrix A1, A2, A3 ; gVector b1, b2, b3 ; gMatrix A_MH_moving, A_MH_moving2 ; gVector b_MH_moving, b_MH_moving2 ; gSolver Solver_MH_moving ; std::vector NonLocalEquations; } ; int fcmp_Dof(const void * a, const void * b) ; void Dof_InitDofData(struct DofData * DofData_P, int Num, int ResolutionIndex, int SystemIndex, char * Name_SolverDataFile) ; void Dof_FreeDofData(struct DofData * DofData_P) ; void Dof_SetCurrentDofData(struct DofData * DofData_P) ; void Dof_OpenFile(int Type, char * Name, const char * Mode) ; void Dof_CloseFile(int Type) ; void Dof_FlushFile(int Type) ; void Dof_WriteFilePRE0(int Num_Resolution, char * Name_Resolution, int Nbr_DofData) ; void Dof_ReadFilePRE0(int * Num_Resolution, int * Nbr_DofData) ; void Dof_WriteFilePRE(struct DofData * DofData_P) ; void Dof_WriteDofPRE(void * a, void * b) ; void Dof_ReadFilePRE(struct DofData * DofData_P) ; void Dof_WriteFileRES0(char * Name_File, int Format) ; void Dof_ReadFileRES0(void) ; void Dof_WriteFileRES(char * Name_File, struct DofData * DofData_P, int Format, double Val_Time, double Val_TimeImag, int Val_TimeStep) ; void Dof_ReadFileRES(List_T * DofData_L, struct DofData * Read_DofData_P, int Read_DofData, double *Time, double *TimeImag, double *TimeStep) ; void Dof_WriteFileRES_ExtendMH(char * Name_File, struct DofData * DofData_P, int Format, int NbrH); void Dof_WriteFileRES_MHtoTime(char * Name_File, struct DofData * DofData_P, int Format, List_T * Time_L); void Dof_WriteFileRES_WithEntityNum(char * Name_File, struct DofData * DofData_P, struct GeoData * GeoData_P0, struct Group * Group_P, bool saveFixed); void Dof_TransferDofTreeToList(struct DofData * DofData_P) ; void Dof_InitDofType(struct DofData * DofData_P) ; void Dof_DeleteDofTree(struct DofData * DofData_P) ; void Dof_AddFunctionSpaceIndex(int Index_FunctionSpace) ; void Dof_AddTimeFunctionIndex(int Index_TimeFunction) ; void Dof_AddPulsation(struct DofData * DofData_P, double Val_Pulsation) ; void Dof_DefineAssignFixedDof(int D1, int D2, int NbrHar, double * Val, int Index_TimeFunction) ; void Dof_DefineInitFixedDof(int D1, int D2, int NbrHar, double * Val, double *Val2, bool NonLocal=false) ; void Dof_DefineAssignSolveDof(int D1, int D2, int NbrHar, int Index_TimeFunction) ; void Dof_DefineInitSolveDof(int D1, int D2, int NbrHar) ; void Dof_DefineLinkDof(int D1, int D2, int NbrHar, double Value[], int D2_Link) ; void Dof_DefineLinkCplxDof(int D1, int D2, int NbrHar, double Value[], int D2_Link) ; void Dof_DefineUnknownDof(int D1, int D2, int NbrHar, bool NonLocal=false) ; void Dof_DefineAssociateDof(int E1, int E2, int D1, int D2, int NbrHar, int init, double * Val) ; void Dof_DefineUnknownDofFromSolveOrInitDof(struct DofData ** DofData_P) ; void Dof_NumberUnknownDof(void) ; void Dof_UpdateAssignFixedDof(struct Dof *Dof_P, int NbrHar, double *Val) ; void Dof_UpdateLinkDof(struct Dof *Dof_P, int NbrHar, double Value[], int D2_Link) ; void Dof_AssembleInMat(struct Dof * Equ_P, struct Dof * Dof_P, int NbrHar, double * Val, gMatrix * Mat, gVector * Vec, List_T *Vecs=0) ; void Dof_AssembleInVec(struct Dof * Equ_P, struct Dof * Dof_P, int NbrHar, double * Val, struct Solution * OtherSolution, gVector * Vec0, gVector * Vec) ; void Dof_TransferSolutionToConstraint(struct DofData * DofData_P) ; void Dof_TransferDof(struct DofData * DofData1_P, struct DofData ** DofData2_P); struct Dof * Dof_GetDofStruct(struct DofData * DofData_P, int D1, int D2, int D3) ; gScalar Dof_GetDofValue(struct DofData * DofData_P, struct Dof * Dof_P) ; void Dof_GetRealDofValue(struct DofData * DofData_P, struct Dof * Dof_P, double *d) ; void Dof_GetComplexDofValue(struct DofData * DofData_P, struct Dof * Dof_P, double *d1, double *d2) ; void Dof_GetDummies(struct DefineSystem * DefineSystem_P, struct DofData * DofData_P) ; void Dof_InitDofForNoDof(struct Dof * DofForNoDof, int NbrHar) ; void Print_DofNumber(struct Dof *Dof_P) ; #endif getdp-2.4.2-source/Legacy/GF_LaplacexForm.cpp000644 001750 001750 00000060241 12116424202 022436 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Ruth Sabariego // #include #include "ProData.h" #include "ProDefine.h" #include "BF.h" #include "GF.h" #include "GeoData.h" #include "Message.h" #define SQU(a) ((a)*(a)) #define THESIGN(a) ((a)>=0 ? 1 : -1) #define ONE_OVER_TWO_PI 1.5915494309189534E-01 #define ONE_OVER_FOUR_PI 7.9577471545947668E-02 #define MAX_NODES 6 #define EPSILON 1.e-8 #define EPSILON2 1.e-20 #define RADIUS 0.154797 /* this is a hack... */ /* ------------------------------------------------------------------------ */ /* G F _ L a p l a c e x F o r m */ /* ------------------------------------------------------------------------ */ void GF_LaplacexForm(GF_ARGX) { double xs[MAX_NODES], ys[MAX_NODES], zs[MAX_NODES], u[3], v[3], n[3]; double u2=0., v2=0., xl=0., yl=0., zl=0., zl_2=0. ; double Area, m0[3], m1[3], m2[3] ; int Type_Int=0, i, j = 1 ; double a=0., b=0., c=0., d, e, f, i1, I1 = 0., Iua, Iva, r2; double s0m=0., s0p=0., s1m=0., s1p=0., s2m=0., s2p=0., t00, t10, t20, t0m_2, t0p_2, t1p_2; double r00_2=0., r10_2=0., r20_2=0., r00, r10, r20, r0p=0., r0m=0., r1p=0.; double f20=0., f21=0., f22=0., B0, B1, B2 ; double f30, f31, f32, N10, N20, N30 ; Val->Val[MAX_DIM] = 0.0 ; switch ((int)Fct->Para[0]) { case _2D : switch (Element->ElementSource->Type) { case POINT : xs[0] = Element->ElementSource->x[0] ; ys[0] = Element->ElementSource->y[0] ; r2 = SQU(x-xs[0])+SQU(y-ys[0]) ; if (r2 > SQU(RADIUS)){ Val->Type = SCALAR ; Val->Val[0] = - ONE_OVER_FOUR_PI * log(r2) ; } else{ Val->Type = SCALAR ; Val->Val[0] = - ONE_OVER_FOUR_PI * log(SQU(RADIUS)) ; } break ; case LINE : xs[0] = Element->ElementSource->x[0] ; ys[0] = Element->ElementSource->y[0] ; xs[1] = Element->ElementSource->x[1] ; ys[1] = Element->ElementSource->y[1] ; if(xFunctionBF == (void(*)())BF_Volume) { a = SQU(xs[0]-xs[1]) + SQU(ys[0]-ys[1]) ; b = 2. * ((x-xs[0])*(xs[0]-xs[1]) + (y-ys[0])*(ys[0]-ys[1])) ; c = SQU(x-xs[0]) + SQU(y-ys[0]) ; d = 0.5 * b / a ; e = c / a ; f = e - d*d ; if (f > EPSILON) { Type_Int = 1; } else if (fabs(f) < EPSILON){ Type_Int = 0; } else { Type_Int = -1; f = -f; } if (Element->Num == Element->ElementSource->Num) Type_Int = 2 ; if ((c == 0) || ((b == -2*a) && (c == a))) Type_Int = 3 ; switch (Type_Int) { case -1 : I1 = log(a) + ( (d+1.) * log(SQU(d+1.) - f) - 2.*(d+1.) + sqrt(f) * log((d+1.+sqrt(f))/(d+1.-sqrt(f))) ) - ( d*log(d*d-f) - 2.*d + sqrt(f)*log((d+sqrt(f))/(d-sqrt(f))) ) ; break ; case 0 : I1 = log(a) + (d+1.)*log(SQU(d+1.)) - d*log(SQU(d)) - 2. ; break ; case 1 : I1 = log(a) + ( (d+1.) * log(SQU(d+1.) + f) - 2.*(d+1.) + 2.*sqrt(f) * atan((d+1.)/sqrt(f)) ) - ( d*log(d*d+f) - 2.*d + 2.*sqrt(f)*atan(d/sqrt(f)) ) ; break ; case 2 : i1 = -b / (2.*a) ; I1 = 2. * i1 * (log(i1) - 1.) + 2. * (1.-i1) * (log(1.-i1) - 1.) + log(a) ; break ; case 3 : I1 = .5 * log(a) - 1. ; break ; } Val->Type = SCALAR ; Val->Val[0] = - ONE_OVER_FOUR_PI * I1 ; } else { Message::Error("Unknown Basis Function Type for 'GF_LaplacexForm'"); } break ; default : Message::Error("Unknown Element Type (%s) for 'GF_LaplacexForm'", Get_StringForDefine(Element_Type, Element->ElementSource->Type)); } break; case _3D : switch (Element->ElementSource->Type) { case LINE : xs[0] = Element->ElementSource->x[0] ; ys[0] = Element->ElementSource->y[0] ; zs[0] = Element->ElementSource->z[0] ; xs[1] = Element->ElementSource->x[1] ; ys[1] = Element->ElementSource->y[1] ; zs[1] = Element->ElementSource->z[1] ; a = SQU(xs[0]-xs[1]) + SQU(ys[0]-ys[1]) + SQU(zs[0]-zs[1]) ; b = 2. * ((x-xs[0])*(xs[0]-xs[1]) + (y-ys[0])*(ys[0]-ys[1]) + (z-zs[0])*(zs[0]-zs[1])) ; c = SQU(x-xs[0]) + SQU(y-ys[0]) + SQU(z-zs[0]) + SQU(RADIUS) ; Val->Val[0] = ONE_OVER_FOUR_PI * log( ( 2.*sqrt(a*(a+b+c))+2.*a+b ) / ( 2.*sqrt(a*c)+b ) ) ; Val->Type = SCALAR ; break ; case TRIANGLE : case QUADRANGLE : if(xFunctionBF == (void(*)())BF_Volume) Type_Int = 1 ; if(xFunctionBF == (void(*)())BF_Node) Type_Int = 2 ; xs[0] = Element->ElementSource->x[0] ; ys[0] = Element->ElementSource->y[0] ; zs[0] = Element->ElementSource->z[0] ; xs[1] = Element->ElementSource->x[1] ; ys[1] = Element->ElementSource->y[1] ; zs[1] = Element->ElementSource->z[1] ; xs[2] = Element->ElementSource->x[2] ; ys[2] = Element->ElementSource->y[2] ; zs[2] = Element->ElementSource->z[2] ; if (Element->ElementSource->Type == QUADRANGLE) { xs[3] = Element->ElementSource->x[3] ; ys[3] = Element->ElementSource->y[3] ; zs[3] = Element->ElementSource->z[3] ; j = 0 ; }; for(i = j; i < 2; i++){ /* triangle side lengths */ a = sqrt(SQU(xs[1]-xs[0]) + SQU(ys[1]-ys[0]) + SQU(zs[1]-zs[0])); b = sqrt(SQU(xs[2]-xs[1]) + SQU(ys[2]-ys[1]) + SQU(zs[2]-zs[1])); c = sqrt(SQU(xs[2]-xs[0]) + SQU(ys[2]-ys[0]) + SQU(zs[2]-zs[0])); /* local system (u,v,w) centered at (xs[0],ys[0],zs[0]) */ u[0] = (xs[1]-xs[0])/a; u[1] = (ys[1]-ys[0])/a; u[2] = (zs[1]-zs[0])/a; /* triangle normal */ Geo_CreateNormal(Element->ElementSource->Type,xs,ys,zs,n); /* v = n /\ u */ v[0] = n[1]*u[2]-n[2]*u[1]; v[1] = n[2]*u[0]-n[0]*u[2]; v[2] = n[0]*u[1]-n[1]*u[0]; u2 = (xs[2]-xs[0])*u[0] + (ys[2]-ys[0])*u[1] + (zs[2]-zs[0])*u[2]; /* u2 coordinate */ v2 = (xs[2]-xs[0])*v[0] + (ys[2]-ys[0])*v[1] + (zs[2]-zs[0])*v[2]; /* triangle height, v2 coordinate */ /* local coordinates of the observation point (xl, yl, zl) */ xl = u[0] * (x-xs[0]) + u[1] * (y-ys[0]) + u[2] * (z-zs[0]); yl = v[0] * (x-xs[0]) + v[1] * (y-ys[0]) + v[2] * (z-zs[0]); zl = n[0] * (x-xs[0]) + n[1] * (y-ys[0]) + n[2] * (z-zs[0]); s0m = -( (a-xl) * (a-u2) + yl*v2 ) / b; s0p = s0m + b; s1p = ( xl * u2 + yl * v2 ) / c; s1m = s1p - c; s2m = - xl; s2p = a - xl; /* distance observation point projection on triangle plane to triangle local vertices*/ /* t1m = t0p ; t2p = t0m ; t2m = t1p ; */ t00 = (yl * (u2-a) + v2 * (a-xl)) / b; t10 = (xl * v2 - yl * u2) / c; t20 = yl; t0m_2 = (a-xl)*(a-xl) + yl*yl; t0p_2 = (u2-xl)*(u2-xl) + (v2-yl)*(v2-yl); t1p_2 = xl*xl + yl*yl; /* minimum distances^2 from the observation point to each triangle side*/ zl_2 = SQU(zl) ; r00_2 = SQU(t00) + zl_2 ; r10_2 = SQU(t10) + zl_2 ; r20_2 = SQU(t20) + zl_2 ; /* distances from observation point to the vertices*/ r0p = sqrt(t0p_2 + zl_2); r0m = sqrt(t0m_2 + zl_2); r1p = sqrt(t1p_2 + zl_2); r00 = sqrt(r00_2); r10 = sqrt(r10_2); r20 = sqrt(r20_2); /* intermediate functions */ if(r00 <= EPSILON*(fabs(s0m)+fabs(s0p)) ){ f20 = log(s0m/s0p) ; B0 = 0; } else{ if (!(r0m + s0m)) Message::Error("1/0 in GF_LaplacexForm (case _3D TRIANGLE) Num %d Obs %.15e %.15e %.15e", Element->ElementSource->Num, x, y, z) ; f20 = log((r0p + s0p) / (r0m + s0m)); B0 = atan(t00*s0p/(r00_2+fabs(zl)*r0p))-atan(t00*s0m/(r00_2+fabs(zl)*r0m)); } if(r10 <= EPSILON*(fabs(s1m)+fabs(s1p)) ){ f21 = log(s1m/s1p); B1 = 0; } else{ if(!(r0p + s1m)) Message::Error("1/0 in GF_LaplacexForm (case _3D TRIANGLE) Num %d Obs %.15e %.15e %.15e", Element->ElementSource->Num, x, y, z) ; f21 = log((r1p + s1p) / (r0p + s1m)); B1 = atan(t10*s1p/(r10_2+fabs(zl)*r1p))-atan(t10*s1m/(r10_2+fabs(zl)*r0p)); } if(r20 <= EPSILON*(fabs(s2m)+fabs(s2p)) ){ f22 = log(s2m/s2p); B2 = 0; } else{ if(!(r1p+s2m)) Message::Error("1/0 in GF_LaplacexForm (case _3D TRIANGLE) Num %d Obs %.15e %.15e %.15e", Element->ElementSource->Num, x, y, z) ; f22 = log((r0m + s2p) / (r1p + s2m)); B2 = atan(t20*s2p/(r20_2+fabs(zl)*r0m))-atan(t20*s2m/(r20_2+fabs(zl)*r1p)); } I1 += -fabs(zl)*(B0+B1+B2) + t00*f20+t10*f21+t20*f22 ; /* 1/r integral solution*/ if (j == 0){ xs[1] = xs[2]; ys[1] = ys[2]; zs[1] = zs[2]; xs[2] = xs[3]; ys[2] = ys[3]; zs[2] = zs[3];} } switch ( Type_Int ){ case 1 : /* BF_Volume */ Area = a * v2/2 ;/* Triangle area */ Val->Val[0] = I1 /Area ; break; case 2 : /* BF_Node */ if (!v2) Message::Error("1/0 in GF_LaplacexForm (case _3D TRIANGLE) v2 %e", v2); f30 = (s0p*r0p-s0m*r0m) + r00_2 * f20 ; /* f3i */ f31 = (s1p*r1p-s1m*r0p) + r10_2 * f21 ; f32 = (s2p*r0m-s2m*r1p) + r20_2 * f22 ; m0[0] = ((ys[2] - ys[1]) * n[2] - (zs[2] - zs[1]) * n[1])*f30/b ; m0[1] = ((zs[2] - zs[1]) * n[0] - (xs[2] - xs[1]) * n[2])*f30/b ; m0[2] = ((xs[2] - xs[1]) * n[1] - (ys[2] - ys[1]) * n[0])*f30/b ; m1[0] = ((ys[0] - ys[2]) * n[2] - (zs[0] - zs[2]) * n[1])*f31/c ; m1[1] = ((zs[0] - zs[2]) * n[0] - (xs[0] - xs[2]) * n[2])*f31/c ; m1[2] = ((xs[0] - xs[2]) * n[1] - (ys[0] - ys[2]) * n[0])*f31/c ; m2[0] = (u[1] * n[2] - u[2]* n[1])*f32 ; m2[1] = (u[2] * n[0] - u[0]* n[2])*f32 ; m2[2] = (u[0] * n[1] - u[1]* n[0])*f32 ; Iua = (u[0] * (m0[0] + m1[0] + m2[0]) + u[1] * (m0[1] + m1[1] + m2[1]) + u[2] * (m0[2] + m1[2] + m2[2]))/2 ; Iva = (v[0] * (m0[0] + m1[0] + m2[0]) + v[1] * (m0[1] + m1[1] + m2[1]) + v[2] * (m0[2] + m1[2] + m2[2]))/2 ; switch(EntityNum){ case 1 : N10 = 1 - xl/a + (u2/a -1) * yl/v2 ; Val->Val[0] = N10 * I1 - Iua/a + (u2/a-1) * Iva/v2 ; break; case 2 : N20 = xl/a - u2/a * yl/v2 ; Val->Val[0] = N20 * I1 + Iua/a - u2/a * Iva/v2 ; break; case 3 : N30 = yl/v2 ; Val->Val[0] = N30 * I1 + Iva/v2 ; break; } break; default : Message::Error("Unknown Basis Function Type for 'GF_LaplacexForm'"); } Val->Val[0] *= ONE_OVER_FOUR_PI ; if (j == 0){ Val->Val[0] /= 2; } Val->Type = SCALAR ; break ; default : Message::Error("Unknown Element Type (%s) for 'GF_LaplacexForm'", Get_StringForDefine(Element_Type, Element->ElementSource->Type)); } break ; default : Message::Error("Unknown Dimension (%d) for 'GF_LaplacexForm'", (int)Fct->Para[0]); } } /* ------------------------------------------------------------------------ */ /* G F _ G r a d L a p l a c e x F o r m */ /* ------------------------------------------------------------------------ */ void GF_GradLaplacexForm(GF_ARGX) { double xs[MAX_NODES], ys[MAX_NODES], zs[MAX_NODES] ; double xxs, yys, r2, EPS ; double a, b, c, a2, I1, I2 ; double f0[3], f1[3], f2[3], N10, N20, N30 ; double m0[3], m1[3], m2[3], s0[3], s1[3] ; double umf2i, us0, us1, us2, vmf2i, vs0, vs1, vs2 ; double u[3], v[3], n[3], u2, v2, xl, yl, zl, zl_2 ; double area, I[3], Iua[3], Iva[3] ; double s0m, s0p, s1m, s1p, s2m, s2p, t00, t10, t20, t0m_2, t0p_2, t1p_2; double r00_2, r10_2, r20_2, r00, r10, r20, r0p, r0m, r1p, f20, f21, f22, B0, B1, B2, B ; int Type_Int=0 ; Val->Val[MAX_DIM] = Val->Val[MAX_DIM + 1] = Val->Val[MAX_DIM + 2] = 0. ; switch ((int)Fct->Para[0]) { case _2D : switch (Element->ElementSource->Type) { case POINT : Val->Type = VECTOR ; if (Element->Num == Element->ElementSource->Num) { Val->Val[0] = Val->Val[1] = Val->Val[2] = 0. ; return ; } xxs = x - Element->ElementSource->x[0] ; yys = y - Element->ElementSource->y[0] ; r2 = SQU(xxs)+SQU(yys) ; if (r2 > EPSILON2) { Val->Val[0] = - ONE_OVER_TWO_PI * xxs / r2 ; Val->Val[1] = - ONE_OVER_TWO_PI * yys / r2 ; Val->Val[2] = 0. ; } else { Val->Val[0] = Val->Val[1] = Val->Val[2] = 0. ; } break ; default : Message::Error("Unknown Element Type (%s) for 'GF_GradLaplacexForm'", Get_StringForDefine(Element_Type, Element->ElementSource->Type)); } break ; case _3D : switch (Element->ElementSource->Type) { case LINE : Val->Type = VECTOR ; xs[0] = Element->ElementSource->x[0] ; ys[0] = Element->ElementSource->y[0] ; zs[0] = Element->ElementSource->z[0] ; xs[1] = Element->ElementSource->x[1] ; ys[1] = Element->ElementSource->y[1] ; zs[1] = Element->ElementSource->z[1] ; a = SQU(xs[0]-xs[1]) + SQU(ys[0]-ys[1]) + SQU(zs[0]-zs[1]) ; b = 2. * ((x-xs[0])*(xs[0]-xs[1]) + (y-ys[0])*(ys[0]-ys[1]) + (z-zs[0])*(zs[0]-zs[1])) ; c = SQU(x-xs[0]) + SQU(y-ys[0]) + SQU(z-zs[0]) + SQU(RADIUS) ; I1 = 2./(4.*a*c-b*b) * ( (2.*a+b)/sqrt(a+b+c) - b/sqrt(c) ) ; I2 = 2./(-4.*a*c+b*b) * ( (2.*c+b)/sqrt(a+b+c) - 2.*sqrt(c) ) ; a2 = sqrt(a) ; Val->Val[0] = ONE_OVER_FOUR_PI * ( (xs[0]-x) * I1 + (xs[1]-xs[0]) * I2 ) * a2 ; Val->Val[1] = ONE_OVER_FOUR_PI * ( (ys[0]-y) * I1 + (ys[1]-ys[0]) * I2 ) * a2 ; Val->Val[2] = ONE_OVER_FOUR_PI * ( (zs[0]-z) * I1 + (zs[1]-zs[0]) * I2 ) * a2 ; break ; case TRIANGLE : Val->Type = VECTOR ; xs[0] = Element->ElementSource->x[0] ; ys[0] = Element->ElementSource->y[0] ; zs[0] = Element->ElementSource->z[0] ; xs[1] = Element->ElementSource->x[1] ; ys[1] = Element->ElementSource->y[1] ; zs[1] = Element->ElementSource->z[1] ; xs[2] = Element->ElementSource->x[2] ; ys[2] = Element->ElementSource->y[2] ; zs[2] = Element->ElementSource->z[2] ; if(xFunctionBF == (void(*)())BF_Volume) Type_Int = 1 ; if(xFunctionBF == (void(*)())BF_Node) Type_Int = 2 ; /* triangle side lengths */ a = sqrt(SQU(xs[1]-xs[0]) + SQU(ys[1]-ys[0]) + SQU(zs[1]-zs[0])); b = sqrt(SQU(xs[2]-xs[1]) + SQU(ys[2]-ys[1]) + SQU(zs[2]-zs[1])); c = sqrt(SQU(xs[2]-xs[0]) + SQU(ys[2]-ys[0]) + SQU(zs[2]-zs[0])); /* local system (u,v,w) centered at (xs[0],ys[0],zs[0]) */ u[0] = (xs[1]-xs[0])/a; u[1] = (ys[1]-ys[0])/a; u[2] = (zs[1]-zs[0])/a; /* triangle normal */ Geo_CreateNormal(Element->ElementSource->Type,xs,ys,zs,n); v[0] = n[1]*u[2]-n[2]*u[1]; v[1] = n[2]*u[0]-n[0]*u[2]; v[2] = n[0]*u[1]-n[1]*u[0]; u2 = (xs[2]-xs[0])*u[0] + (ys[2]-ys[0])*u[1] + (zs[2]-zs[0])*u[2]; /* u2 coordinate */ v2 = (xs[2]-xs[0])*v[0] + (ys[2]-ys[0])*v[1] + (zs[2]-zs[0])*v[2]; /* triangle height, v2 coordinate*/ /* local coordinates of the observation point (xl, yl, zl)*/ xl = u[0] * (x-xs[0]) + u[1] * (y-ys[0]) + u[2] * (z-zs[0]); yl = v[0] * (x-xs[0]) + v[1] * (y-ys[0]) + v[2] * (z-zs[0]); zl = n[0] * (x-xs[0]) + n[1] * (y-ys[0]) + n[2] * (z-zs[0]); area = a * v2/2 ;/* Triangle area */ if (!zl) zl = sqrt(area) * 1e-15 ; s0m = -( (a-xl) * (a-u2) + yl*v2 ) / b; s0p = s0m + b; s1p = ( xl * u2 + yl * v2 ) / c; s1m = s1p - c; s2m = - xl; s2p = a - xl; /* distance observation point projection on triangle plane to triangle local vertices*/ t00 = (yl * (u2-a) + v2 * (a-xl)) / b; t10 = (xl * v2 - yl * u2) / c; t20 = yl; t0m_2 = ((a-xl)*(a-xl) + yl*yl); t0p_2 = ((u2-xl)*(u2-xl) + (v2-yl)*(v2-yl)); t1p_2 = (xl*xl + yl*yl); /* minimum distances^2 from the observation point to each triangle side*/ zl_2 = SQU(zl) ; r00_2 = SQU(t00) + zl_2 ; r10_2 = SQU(t10) + zl_2 ; r20_2 = SQU(t20) + zl_2 ; r00 = sqrt(r00_2); r10 = sqrt(r10_2); r20 = sqrt(r20_2); /* distances from observation point to the vertices*/ r0p = sqrt(t0p_2 + zl_2); r0m = sqrt(t0m_2 + zl_2); r1p = sqrt(t1p_2 + zl_2); EPS = EPSILON*(fabs(s0m)+fabs(s0p)); B0 = (r00 <= EPS) ? 0. : atan(t00*s0p/(r00_2+fabs(zl)*r0p))-atan(t00*s0m/(r00_2+fabs(zl)*r0m)); f20 = ((r0m + s0m) <= EPS) ? log(s0m/s0p) : log((r0p + s0p) / (r0m + s0m)) ; EPS = EPSILON*(fabs(s1m)+fabs(s1p)) ; B1 = (r10 <=EPS) ? 0. : atan(t10*s1p/(r10_2+fabs(zl)*r1p))-atan(t10*s1m/(r10_2+fabs(zl)*r0p)); f21 = ((r0p + s1m)<=EPS) ? log(s1m/s1p) : log((r1p + s1p) / (r0p + s1m)); EPS = EPSILON*(fabs(s2m)+fabs(s2p)) ; B2 = (r20 <= EPS) ? 0. : atan(t20*s2p/(r20_2+fabs(zl)*r0m))-atan(t20*s2m/(r20_2+fabs(zl)*r1p)); f22 = ((r1p + s2m)< EPS) ? log(s2m/s2p): log((r0m + s2p) / (r1p + s2m)); B = B0 + B1 + B2 ; s0[0] = (xs[2] - xs[1])/b ; s0[1] = (ys[2] - ys[1])/b ; s0[2] = (zs[2] - zs[1])/b ; s1[0] = (xs[0] - xs[2])/c ; s1[1] = (ys[0] - ys[2])/c ; s1[2] = (zs[0] - zs[2])/c ; m0[0] = s0[1] * n[2] - s0[2]* n[1] ; m0[1] = s0[2] * n[0] - s0[0]* n[2] ; m0[2] = s0[0] * n[1] - s0[1]* n[0] ; m1[0] = s1[1]* n[2] - s1[2] * n[1] ; m1[1] = s1[2]* n[0] - s1[0] * n[2] ; m1[2] = s1[0]* n[1] - s1[1] * n[0] ; m2[0] = u[1] * n[2] - u[2]* n[1] ; m2[1] = u[2] * n[0] - u[0]* n[2] ; m2[2] = u[0] * n[1] - u[1]* n[0] ; /* Grad(1/r) integral solution*/ I[0] = -n[0] * THESIGN(zl) * B - (m0[0]*f20 + m1[0]*f21 + m2[0]*f22) ; I[1] = -n[1] * THESIGN(zl) * B - (m0[1]*f20 + m1[1]*f21 + m2[1]*f22) ; I[2] = -n[2] * THESIGN(zl) * B - (m0[2]*f20 + m1[2]*f21 + m2[2]*f22) ; switch ( Type_Int ){ case 1 : /* BF_Volume */ Val->Val[0] = I[0]/area ; Val->Val[1] = I[1]/area ; Val->Val[2] = I[2]/area ; break; case 2 : /* BF_Node */ if (!v2 ) Message::Error("1/0 in GF_LaplacexForm (case _3D TRIANGLE) v2 %e", v2); f0[0] = s0[0] * t00 * f20 - m0[0]*(r0p-r0m) ; /* fi */ f0[1] = s0[1] * t00 * f20 - m0[1]*(r0p-r0m) ; f0[2] = s0[2] * t00 * f20 - m0[2]*(r0p-r0m) ; f1[0] = s1[0] * t10 * f21 - m1[0]*(r1p-r0p) ; f1[1] = s1[1] * t10 * f21 - m1[1]*(r1p-r0p) ; f1[2] = s1[2] * t10 * f21 - m1[2]*(r1p-r0p) ; f2[0] = u[0] * t20 * f22 - m2[0]*(r0m-r1p) ; f2[1] = u[1] * t20 * f22 - m2[1]*(r0m-r1p) ; f2[2] = u[2] * t20 * f22 - m2[2]*(r0m-r1p) ; umf2i = u[0]*(m0[0]*f20 + m1[0]*f21 + m2[0]*f22) + u[1]*(m0[1]*f20 + m1[1]*f21 + m2[1]*f22) + u[2]*(m0[2]*f20 + m1[2]*f21 + m2[2]*f22) ; us0 = u[0] * s0[0] + u[1] * s0[1] + u[2] * s0[2] ; us1 = u[0] * s1[0] + u[1] * s1[1] + u[2] * s1[2] ; us2 = u[0] * u[0] + u[1] * u[1] + u[2] * u[2] ; vmf2i = v[0]*(m0[0]*f20 + m1[0]*f21 + m2[0]*f22) + v[1]*(m0[1]*f20 + m1[1]*f21 + m2[1]*f22) + v[2]*(m0[2]*f20 + m1[2]*f21 + m2[2]*f22) ; vs0 = v[0] * s0[0] + v[1] * s0[1] + v[2] * s0[2] ; vs1 = v[0] * s1[0] + v[1] * s1[1] + v[2] * s1[2] ; vs2 = v[0] * u[0] + v[1] * u[1] + v[2] * u[2] ; B *= fabs(zl); umf2i *= zl ; vmf2i *= zl ; Iua[0] = n[0] * umf2i - B * u[0] + f0[0] * us0 + f1[0] * us1 + f2[0] * us2 ; Iua[1] = n[1] * umf2i - B * u[1] + f0[1] * us0 + f1[1] * us1 + f2[1] * us2 ; Iua[2] = n[2] * umf2i - B * u[2] + f0[2] * us0 + f1[2] * us1 + f2[2] * us2 ; Iva[0] = n[0] * vmf2i - B * v[0] + f0[0] * vs0 + f1[0] * vs1 + f2[0] * vs2 ; Iva[1] = n[1] * vmf2i - B * v[1] + f0[1] * vs0 + f1[1] * vs1 + f2[1] * vs2 ; Iva[2] = n[2] * vmf2i - B * v[2] + f0[2] * vs0 + f1[2] * vs1 + f2[2] * vs2 ; switch(EntityNum){ case 1 : N10 = 1 - xl/a + (u2/a -1) * yl/v2 ; Val->Val[0] = N10 * I[0] - Iua[0]/a + (u2/a-1) * Iva[0]/v2 ; Val->Val[1] = N10 * I[1] - Iua[1]/a + (u2/a-1) * Iva[1]/v2 ; Val->Val[2] = N10 * I[2] - Iua[2]/a + (u2/a-1) * Iva[2]/v2 ; break; case 2 : N20 = xl/a - u2/a * yl/v2 ; Val->Val[0] = N20 * I[0] + Iua[0]/a - u2/a * Iva[0]/v2 ; Val->Val[1] = N20 * I[1] + Iua[1]/a - u2/a * Iva[1]/v2 ; Val->Val[2] = N20 * I[2] + Iua[2]/a - u2/a * Iva[2]/v2 ; break; case 3 : N30 = yl/v2 ; Val->Val[0] = N30 * I[0] + Iva[0]/v2 ; Val->Val[1] = N30 * I[1] + Iva[1]/v2 ; Val->Val[2] = N30 * I[2] + Iva[2]/v2 ; break; } break; } Val->Val[0] *= ONE_OVER_FOUR_PI ; Val->Val[1] *= ONE_OVER_FOUR_PI ; Val->Val[2] *= ONE_OVER_FOUR_PI ; break ; default : Message::Error("Unknown Element Type (%s) for 'GF_GradLaplacexForm'", Get_StringForDefine(Element_Type, Element->ElementSource->Type)); } break ; default : Message::Error("Unknown Dimension (%d) for 'GF_GradLaplacexForm'", (int)Fct->Para[0]); } } /* ------------------------------------------------------------------------ */ /* G F _ N P x G r a d L a p l a c e x F o r m */ /* ------------------------------------------------------------------------ */ void GF_NPxGradLaplacexForm(GF_ARGX) { double xs[MAX_NODES], ys[MAX_NODES] ; double xp[MAX_NODES], yp[MAX_NODES], N[3] ; int Type_Int; double a, b, c, d, m, n, Jp, i1, Is, I1=0 ; struct Value ValGrad ; Val->Type = SCALAR ; Val->Val[MAX_DIM] = 0.0 ; if (Element->Num == Element->ElementSource->Num) { Val->Val[0] = 0.0 ; return ; } switch ((int)Fct->Para[0]) { case _2D : switch (Element->ElementSource->Type) { case LINE : if (Element->Type != LINE) Message::Error("GF_NPxGradLaplacexForm not ready for mixed geometrical elements"); xs[0] = Element->ElementSource->x[0] ; ys[0] = Element->ElementSource->y[0] ; xs[1] = Element->ElementSource->x[1] ; ys[1] = Element->ElementSource->y[1] ; if(xFunctionBF == (void(*)())BF_Volume) { if ((x == xs[0]) && (y == ys[0])) Type_Int = 1 ; else if ((x == xs[1]) && (y == ys[1])) Type_Int = 2 ; else Type_Int = 3 ; xp[0] = Element->x[0] ; yp[0] = Element->y[0] ; xp[1] = Element->x[1] ; yp[1] = Element->y[1] ; a = SQU(xs[0]-xs[1]) + SQU(ys[0]-ys[1]) ; b = 2. * ((x-xs[0]) * (xs[0]-xs[1]) + (y-ys[0]) * (ys[0]-ys[1])) ; c = SQU(x-xs[0]) + SQU(y-ys[0]) ; d = 4.*a*c - b*b ; switch (Type_Int) { case 1 : case 2 : Message::Error("Degenerate case not done in 'GF_NPxGradLaplacexForm'"); break ; case 3 : if (fabs(d) < EPSILON2) { I1 = 0.0 ; } else { if(d<0) Message::Error("Unexpected value in 'GF_NPxGradLaplacexForm'"); i1 = sqrt(d) ; Is = 2. / i1 * (atan((2.*a+b)/i1) - atan(b/i1)) ; Jp = sqrt(SQU(xp[0]-xp[1])+SQU(yp[0]-yp[1])) ; m = ((ys[0]-ys[1]) * (xp[0]-xp[1]) + (xs[0]-xs[1]) * (yp[1]-yp[0])) / Jp ; n = ((yp[1]-yp[0]) * (x-xs[0]) + (xp[0]-xp[1]) * (y-ys[0])) / Jp ; I1 = m /(2.*a) * log((a+b)/c+1.) + (n - m*b/(2.*a)) * Is ; } break ; } Val->Val[0] = - ONE_OVER_TWO_PI * I1 ; } else { Message::Error("Unknown Basis Function Type for 'GF_NPxGradLaplacexForm'"); } break ; default : Message::Error("Unknown Element Type (%s) for 'GF_NPxGradLaplacexForm'", Get_StringForDefine(Element_Type, Element->ElementSource->Type)); } break ; case _3D: switch (Element->ElementSource->Type) { case TRIANGLE : Geo_CreateNormal(Element->Type, Element->x,Element->y,Element->z, N); GF_GradLaplacexForm(Element, Fct, xFunctionBF, EntityNum, x, y, z, &ValGrad) ; Val->Val[0] = N[0]*ValGrad.Val[0] + N[1]*ValGrad.Val[1] + N[2]*ValGrad.Val[2] ; break ; default : Message::Error("Unknown Element Type (%s) for 'GF_NPxGradLaplacexForm'", Get_StringForDefine(Element_Type, Element->ElementSource->Type)); } break ; default : Message::Error("Unknown Dimension (%d) for 'GF_NPxGradLaplacexForm'", (int)Fct->Para[0]); } } /* ------------------------------------------------------------------------ */ /* G F _ N S x G r a d L a p l a c e x F o r m */ /* ------------------------------------------------------------------------ */ void GF_NSxGradLaplacexForm(GF_ARGX) { Message::Error("Not done: 'GF_NSxGradLaplacexForm'"); } /* ------------------------------------------------------------------------ */ /* G F _ A p p r o x i m a t e L a p l a c e x F o r m */ /* ------------------------------------------------------------------------ */ void GF_ApproximateLaplacexForm(GF_ARGX) { switch ((int)Fct->Para[1]) { case 0 : GF_LaplacexForm(Element, Fct, (void(*)())BF_Volume, 1, x, y, z, Val); break ; default : Message::Error("Bad Parameter Value in 'GF_ApproximateLaplacexForm'"); break; } } getdp-2.4.2-source/Legacy/EigenSolve_SLEPC.cpp000644 001750 001750 00000040141 12171526422 022500 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "GetDPConfig.h" #if defined(HAVE_SLEPC) // SLEPc interface for solving eigenvalue problems // // SLEPc can solve both linear and quadratic eigenvalue // problems. SLEPc options can be specified in the .petscrc file, or // directly on the command line. // // For example, to use MUMPs for a linear evp: // -eps_type krylovschur // -st_ksp_type preonly -st_pc_type lu // -st_pc_factor_mat_solver_package mumps // // To solve a quadratic evp by linearization, using the first canonic // form, and building the operator explicitly so we can use a direct // solver: // -qep_type linear -qep_linear_cform 1 -qep_linear_explicitmatrix // -qep_eps_type krylovschur // -qep_st_ksp_type preonly -qep_st_pc_type lu // -qep_st_pc_factor_mat_solver_package mumps // // To solve the quadratic evp directly using arnoldi iter: // -qep_type qarnoldi -qep_eps_type krylovschur // -qep_st_ksp_type gmres -qep_st_pc_type ilu #include #include #include #include "ProData.h" #include "DofData.h" #include "Message.h" #include "MallocUtils.h" #include #include extern struct CurrentData Current ; extern void _fillseq(Vec &V, Vec &Vseq); // from LinAlg_PETsc.cpp static void _try(int ierr){ CHKERRABORT(PETSC_COMM_WORLD, ierr); } static PetscErrorCode _myMonitor(const char *str, int its, int nconv, PetscScalar *eigr, PetscScalar *eigi, PetscReal* errest) { if(!its) return 0; std::ostringstream sstream; sstream << " " << its << " " << str << " nconv=" << nconv << " first unconverged value " #if defined(PETSC_USE_COMPLEX) << PetscRealPart(eigr[nconv]) << " + i * (" << PetscImaginaryPart(eigr[nconv]) << ")" #else << eigr[nconv] << " + i * (" << eigi[nconv] << ")" #endif << " error " << errest[nconv]; Message::Info("%s", sstream.str().c_str()); return 0; } static PetscErrorCode _myEpsMonitor(EPS eps, int its, int nconv, PetscScalar *eigr, PetscScalar *eigi, PetscReal* errest, int nest, void *mctx) { return _myMonitor("EPS", its, nconv, eigr, eigi, errest); } static PetscErrorCode _myQepMonitor(QEP qep, int its, int nconv, PetscScalar *eigr, PetscScalar *eigi, PetscReal* errest, int nest, void *mctx) { return _myMonitor("QEP", its, nconv, eigr, eigi, errest); } static void _storeEigenVectors(struct DofData *DofData_P, int nconv, EPS eps, QEP qep) { if (nconv <= 0) return; // temporary (parallel) vectors to store real and imaginary part of eigenvectors Vec xr, xi; _try(MatGetVecs(DofData_P->M1.M, PETSC_NULL, &xr)); _try(MatGetVecs(DofData_P->M1.M, PETSC_NULL, &xi)); // temporary sequential vectors to transfer eigenvectors to getdp Vec xr_seq, xi_seq; if(Message::GetCommSize() > 1){ PetscInt n; _try(VecGetSize(xr, &n)); _try(VecCreateSeq(PETSC_COMM_SELF, n, &xr_seq)); _try(VecCreateSeq(PETSC_COMM_SELF, n, &xi_seq)); } Message::Info(" %-24s%-24s%-12s", "Re", "Im", "Relative error"); bool newsol = false; for (int i = 0; i < nconv; i++){ PetscScalar kr, ki; PetscReal error; if(eps){ _try(EPSGetEigenpair(eps, i, &kr, &ki, xr, xi)); _try(EPSComputeRelativeError(eps, i, &error)); } else{ _try(QEPGetEigenpair(qep, i, &kr, &ki, xr, xi)); _try(QEPComputeRelativeError(qep, i, &error)); } #if defined(PETSC_USE_COMPLEX) PetscReal re = PetscRealPart(kr), im = PetscImaginaryPart(kr); #else PetscReal re = kr, im = ki; #endif double ore, oim; if(eps){ Message::Info("EIG %03d w^2 = %s%.16e %s%.16e %3.6e", i, (re < 0) ? "" : " ", re, (im < 0) ? "" : " ", im, error); double abs = sqrt(re * re + im * im), arg = atan2(im, re); ore = sqrt(abs) * cos(0.5*arg); oim = sqrt(abs) * sin(0.5*arg); double fre = ore / 2. / M_PI, fim = oim / 2. / M_PI; Message::Info(" w = %s%.16e %s%.16e", (ore < 0) ? "" : " ", ore, (oim < 0) ? "" : " ", oim); Message::Info(" f = %s%.16e %s%.16e", (fre < 0) ? "" : " ", fre, (fim < 0) ? "" : " ", fim); } else{ ore = re; oim = im; Message::Info("EIG %03d w = %s%.16e %s%.16e %3.6e", i, (ore < 0) ? "" : " ", ore, (oim < 0) ? "" : " ", oim, error); double fre = re / 2. / M_PI, fim = im / 2. / M_PI; Message::Info(" f = %s%.16e %s%.16e", (fre < 0) ? "" : " ", fre, (fim < 0) ? "" : " ", fim); } // create new solution vector if necessary if(newsol) { struct Solution Solution_S; Solution_S.TimeFunctionValues = NULL; LinAlg_CreateVector(&Solution_S.x, &DofData_P->Solver, DofData_P->NbrDof); List_Add(DofData_P->Solutions, &Solution_S); DofData_P->CurrentSolution = (struct Solution*) List_Pointer(DofData_P->Solutions, List_Nbr(DofData_P->Solutions)-1); } newsol = true; DofData_P->CurrentSolution->Time = ore; DofData_P->CurrentSolution->TimeImag = oim; DofData_P->CurrentSolution->TimeStep = (int)Current.TimeStep; Free(DofData_P->CurrentSolution->TimeFunctionValues); DofData_P->CurrentSolution->TimeFunctionValues = NULL; DofData_P->CurrentSolution->SolutionExist = 1; // store eigenvector PetscScalar *tmpr, *tmpi; if(Message::GetCommSize() == 1){ _try(VecGetArray(xr, &tmpr)); _try(VecGetArray(xi, &tmpi)); } else{ _fillseq(xr, xr_seq); _fillseq(xi, xi_seq); _try(VecGetArray(xr_seq, &tmpr)); _try(VecGetArray(xi_seq, &tmpi)); } for(int l = 0; l < DofData_P->NbrDof; l += gCOMPLEX_INCREMENT){ #if defined(PETSC_USE_COMPLEX) double var_r = (double)PetscRealPart(tmpr[l]); double var_i = (double)PetscImaginaryPart(tmpr[l]); #else double var_r = (double)tmpr[l]; double var_i = (double)tmpi[l]; #endif LinAlg_SetComplexInVector(var_r, var_i, &DofData_P->CurrentSolution->x, l, l+1); } if(Message::GetCommSize() == 1){ _try(VecRestoreArray(xr, &tmpr)); _try(VecRestoreArray(xi, &tmpi)); } else{ _try(VecRestoreArray(xr_seq, &tmpr)); _try(VecRestoreArray(xi_seq, &tmpi)); } LinAlg_AssembleVector(&DofData_P->CurrentSolution->x); // increment the global timestep counter so that a future // GenerateSystem knows which solutions exist Current.TimeStep += 1.; // update the current value of Time and TimeImag so that // $EigenvalueReal and $EigenvalueImag are up-to-date Current.Time = re; Current.TimeImag = im; } #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) _try(VecDestroy(&xr)); _try(VecDestroy(&xi)); if(Message::GetCommSize() > 1){ _try(VecDestroy(&xr_seq)); _try(VecDestroy(&xi_seq)); } #else _try(VecDestroy(xr)); _try(VecDestroy(xi)); if(Message::GetCommSize() > 1){ _try(VecDestroy(xr_seq)); _try(VecDestroy(xi_seq)); } #endif } static void _linearEVP(struct DofData * DofData_P, int numEigenValues, double shift_r, double shift_i) { Message::Info("Solving linear eigenvalue problem"); // GetDP notation: -w^2 M3 x (+ iw M2 x) + M1 x = 0 // SLEPC notation for generalized linear EVP: A x - \lambda B x = 0 Mat A = DofData_P->M1.M; Mat B = DofData_P->M3.M; EPS eps; _try(EPSCreate(PETSC_COMM_WORLD, &eps)); _try(EPSSetOperators(eps, A, B)); _try(EPSSetProblemType(eps, EPS_GNHEP)); // set some default options _try(EPSSetDimensions(eps, numEigenValues, PETSC_DECIDE, PETSC_DECIDE)); _try(EPSSetTolerances(eps, 1.e-6, 100)); _try(EPSSetType(eps, EPSKRYLOVSCHUR)); // EPSKRYLOVSCHUR, EPSARNOLDI, EPSARPACK or EPSPOWER _try(EPSSetWhichEigenpairs(eps, EPS_SMALLEST_MAGNITUDE)); // EPS_SMALLEST_REAL, EPS_LARGEST_MAGNITUDE, ... _try(EPSMonitorSet(eps, _myEpsMonitor, PETSC_NULL, PETSC_NULL)); // override these options at runtime, petsc-style _try(EPSSetFromOptions(eps)); // force options specified directly as arguments if(numEigenValues) _try(EPSSetDimensions(eps, numEigenValues, PETSC_DECIDE, PETSC_DECIDE)); ST st; _try(EPSGetST(eps, &st)); _try(STSetType(st, STSINVERT)); // apply shift-and-invert transformation if(shift_r || shift_i){ #if defined(PETSC_USE_COMPLEX) PetscScalar shift = shift_r + PETSC_i * shift_i; #else PetscScalar shift = shift_r; if(shift_i) Message::Warning("Imaginary part of shift discarded: use PETSc with complex numbers"); #endif //_try(STSetShift(st, shift)); _try(EPSSetTarget(eps, shift)); _try(EPSSetWhichEigenpairs(eps, EPS_TARGET_MAGNITUDE)); } // use MUMPS by default if available #if (PETSC_VERSION_MAJOR > 2) && defined(PETSC_HAVE_MUMPS) KSP ksp; _try(STGetKSP(st, &ksp)); _try(KSPSetType(ksp, "preonly")); PC pc; _try(KSPGetPC(ksp, &pc)); _try(PCSetType(pc, PCLU)); _try(PCFactorSetMatSolverPackage(pc, "mumps")); #endif // print info #if (PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR == 4) const char *type = ""; #else const EPSType type; #endif _try(EPSGetType(eps, &type)); Message::Info("SLEPc solution method: %s", type); PetscInt nev; _try(EPSGetDimensions(eps, &nev, PETSC_NULL, PETSC_NULL)); Message::Info("SLEPc number of requested eigenvalues: %d", nev); PetscReal tol; PetscInt maxit; _try(EPSGetTolerances(eps, &tol, &maxit)); Message::Info("SLEPc stopping condition: tol=%g, maxit=%d", tol, maxit); // solve Message::Info("SLEPc solving..."); _try(EPSSolve(eps)); // check convergence int its; _try(EPSGetIterationNumber(eps, &its)); EPSConvergedReason reason; _try(EPSGetConvergedReason(eps, &reason)); if(reason == EPS_CONVERGED_TOL) Message::Info("SLEPc converged in %d iterations", its); else if(reason == EPS_DIVERGED_ITS) Message::Error("SLEPc diverged after %d iterations", its); else if(reason == EPS_DIVERGED_BREAKDOWN) Message::Error("SLEPc generic breakdown in method"); #if !(PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) else if(reason == EPS_DIVERGED_NONSYMMETRIC) Message::Error("The operator is nonsymmetric"); #endif // get number of converged approximate eigenpairs PetscInt nconv; _try(EPSGetConverged(eps, &nconv)); Message::Info("SLEPc number of converged eigenpairs: %d", nconv); // ignore additional eigenvalues if we get more than what we asked if(nconv > nev) nconv = nev; // print eigenvalues and store eigenvectors in DofData _storeEigenVectors(DofData_P, nconv, eps, PETSC_NULL); #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) _try(EPSDestroy(&eps)); #else _try(EPSDestroy(eps)); #endif } static void _quadraticEVP(struct DofData * DofData_P, int numEigenValues, double shift_r, double shift_i) { Message::Info("Solving quadratic eigenvalue problem"); // GetDP notation: -w^2 M3 x + iw M2 x + M1 x = 0 // SLEPC notations for quadratic EVP: (\lambda^2 M + \lambda C + K) x = 0 LinAlg_ProdMatrixDouble(&DofData_P->M3, -1.0, &DofData_P->M3); LinAlg_ProdMatrixComplex(&DofData_P->M2, 0.0, -1.0, &DofData_P->M2); Mat M = DofData_P->M3.M; Mat C = DofData_P->M2.M; Mat K = DofData_P->M1.M; QEP qep; _try(QEPCreate(PETSC_COMM_WORLD, &qep)); _try(QEPSetOperators(qep, M, C, K)); _try(QEPSetProblemType(qep, QEP_GENERAL)); // set some default options _try(QEPSetDimensions(qep, numEigenValues, PETSC_DECIDE, PETSC_DECIDE)); _try(QEPSetTolerances(qep, 1.e-6, 100)); _try(QEPSetType(qep, QEPLINEAR)); // QEPQARNOLDI _try(QEPSetWhichEigenpairs(qep, QEP_SMALLEST_MAGNITUDE)); // QEP_SMALLEST_REAL, QEP_LARGEST_MAGNITUDE, ... // if we linearize we can set additional options #if (PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR == 4) const char *type = ""; #else const QEPType type; #endif _try(QEPGetType(qep, &type)); if(!strcmp(type, QEPLINEAR)){ EPS eps; _try(QEPLinearGetEPS(qep, &eps)); _try(EPSSetType(eps, EPSKRYLOVSCHUR)); ST st; _try(EPSGetST(eps, &st)); _try(STSetType(st, STSINVERT)); // apply shift-and-invert transformation if(shift_r || shift_i){ #if defined(PETSC_USE_COMPLEX) PetscScalar shift = shift_r + PETSC_i * shift_i; #else PetscScalar shift = shift_r; if(shift_i) Message::Warning("Imaginary part of shift discarded: use PETSc with complex numbers"); #endif //_try(STSetShift(st, shift)); _try(EPSSetTarget(eps, shift)); _try(EPSSetWhichEigenpairs(eps, EPS_TARGET_MAGNITUDE)); } // use MUMPS by default if available #if (PETSC_VERSION_MAJOR > 2) && defined(PETSC_HAVE_MUMPS) _try(QEPLinearSetExplicitMatrix(qep, PETSC_TRUE)); Message::Info("SLEPc forcing explicit construction of matrix"); KSP ksp; _try(STGetKSP(st, &ksp)); _try(KSPSetType(ksp, "preonly")); PC pc; _try(KSPGetPC(ksp, &pc)); _try(PCSetType(pc, PCLU)); _try(PCFactorSetMatSolverPackage(pc, "mumps")); #endif } _try(QEPMonitorSet(qep, _myQepMonitor, PETSC_NULL, PETSC_NULL)); // override these options at runtime, if necessary _try(QEPSetFromOptions(qep)); // force options specified directly as arguments if(numEigenValues) _try(QEPSetDimensions(qep, numEigenValues, PETSC_DECIDE, PETSC_DECIDE)); // print info Message::Info("SLEPc solution method: %s", type); PetscInt nev; _try(QEPGetDimensions(qep, &nev, PETSC_NULL, PETSC_NULL)); Message::Info("SLEPc number of requested eigenvalues: %d", nev); PetscReal tol; PetscInt maxit; _try(QEPGetTolerances(qep, &tol, &maxit)); Message::Info("SLEPc stopping condition: tol=%g, maxit=%d", tol, maxit); // solve _try(QEPSolve(qep)); // check convergence int its; _try(QEPGetIterationNumber(qep, &its)); QEPConvergedReason reason; _try(QEPGetConvergedReason(qep, &reason)); if(reason == QEP_CONVERGED_TOL) Message::Info("SLEPc converged in %d iterations", its); else if(reason == QEP_DIVERGED_ITS) Message::Error("SLEPc diverged after %d iterations", its); else if(reason == QEP_DIVERGED_BREAKDOWN) Message::Error("SLEPc generic breakdown in method"); else if(reason == QEP_CONVERGED_ITERATING) Message::Error("QEP converged interating"); // get number of converged approximate eigenpairs PetscInt nconv; _try(QEPGetConverged(qep, &nconv)); Message::Info("SLEPc number of converged eigenpairs: %d", nconv); // ignore additional eigenvalues if we get more than what we asked if(nconv > nev) nconv = nev; // print eigenvalues and store eigenvectors in DofData _storeEigenVectors(DofData_P, nconv, PETSC_NULL, qep); #if (PETSC_VERSION_RELEASE == 0 || ((PETSC_VERSION_MAJOR == 3) && (PETSC_VERSION_MINOR >= 2))) _try(QEPDestroy(&qep)); #else _try(QEPDestroy(qep)); #endif // restore operators LinAlg_ProdMatrixDouble(&DofData_P->M3, -1.0, &DofData_P->M3); LinAlg_ProdMatrixComplex(&DofData_P->M2, 0.0, -1.0, &DofData_P->M2); } void EigenSolve_SLEPC(struct DofData * DofData_P, int numEigenValues, double shift_r, double shift_i) { // bail out if we are not in harmonic regime: it's much easier this // way (since, for real, non-symmetric matrices we would get complex // eigenvectors we could not easily store) if(Current.NbrHar != 2){ Message::Error("EigenSolve requires system defined with \"Type Complex\""); return; } // GenerateSeparate[] creates three matrices M3, M2, M1 such that // -w^2 M3 x + iw M2 x + M1 x = b; check Flag_Init[i] to see which // operators exist: if(!DofData_P->Flag_Init[1] || !DofData_P->Flag_Init[3]){ Message::Error("No System available for EigenSolve: check 'DtDt' and 'GenerateSeparate'"); return; } if(!DofData_P->Flag_Init[2]){ // the shift refers to w^2 _linearEVP(DofData_P, numEigenValues, shift_r, shift_i); } else{ // the shift refers to w _quadraticEVP(DofData_P, numEigenValues, shift_r, shift_i); } } #endif getdp-2.4.2-source/Numeric/Adapt.h000644 001750 001750 00000001173 12116424200 020376 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _ADAPT_H_ #define _ADAPT_H_ #define P1 1 #define P2 2 #define H1 3 #define H2 4 double Adapt (int N, /* Number of elements */ int method, /* H1, H2, P1 or P2 */ int dim, /* 2 or 3 */ double *err, /* elementary errors */ double *h, /* elementary mesh sizes */ double *p, /* elementary exponents */ double e0); /* prescribed error or number of elements */ #endif getdp-2.4.2-source/Numeric/Bessel.cpp000644 001750 001750 00000012254 12116424200 021117 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "GetDPConfig.h" #include "Message.h" #include "Bessel.h" #if defined(HAVE_NO_FORTRAN) static void zbesj_(double*, double*, double*, int*, int*, double*, double*, int*, int*) { Message::Fatal("Bessel functions require Fortran compiler"); } static void zbesy_(double*, double*, double*, int*, int*, double*, double*, int*, double*, double*, int*) { Message::Fatal("Bessel functions require Fortran compiler"); } static void zbesh_(double*, double*, double*, int*, int*, int*, double*, double*, int*, int*) { Message::Fatal("Bessel functions require Fortran compiler"); } #else #if defined(HAVE_UNDERSCORE) #define zbesj_ zbesj #define zbesy_ zbesy #define zbesh_ zbesh #endif extern "C" { void zbesj_(double*, double*, double*, int*, int*, double*, double*, int*, int*); void zbesy_(double*, double*, double*, int*, int*, double*, double*, int*, double*, double*, int*); void zbesh_(double*, double*, double*, int*, int*, int*, double*, double*, int*, int*); } #endif static int BesselError(int ierr, const char *str) { static int warn=0; switch(ierr){ case 0 : return 0; case 1 : Message::Error("Input error in %s", str); return BESSEL_ERROR_INPUT; case 2 : return BESSEL_OVERFLOW; case 3 : if(!warn){ Message::Info("Half machine accuracy lost in %s (large argument or order)", str); warn = 1; } return BESSEL_HALF_ACCURACY; case 4 : Message::Error("Complete loss of significance in %s (argument or order too large)", str); return BESSEL_NO_ACCURACY; case 5 : Message::Error("Failed to converge in %s", str); return BESSEL_NO_CONVERGENCE; default: Message::Info("Unknown Bessel status in %s (%d)", str, ierr); return ierr; } } // First kind Bessel functions int BesselJn(double n, int num, double x, double *val) { int nz = 0, ierr = 0, kode = 1; double xi = 0.0; double* ji = new double[num]; zbesj_(&x, &xi, &n, &kode, &num, val, ji, &nz, &ierr) ; delete[] ji; return BesselError(ierr, "BesselJn"); } int BesselSphericalJn(double n, int num, double x, double *val) { int ierr = BesselJn(n+0.5, num, x, val); double coef = sqrt(0.5*M_PI/x); for(int i = 0; i < num; i++){ val[i] *= coef; } return BesselError(ierr, "BesselSphericalJn"); } int BesselAltSphericalJn(double n, int num, double x, double *val) { int ierr = BesselJn(n+0.5, num, x, val); double coef = sqrt(0.5*M_PI*x); for(int i = 0; i < num; i++){ val[i] *= coef; } return BesselError(ierr, "BesselAltSphericalJn"); } // Second kind Bessel functions int BesselYn(double n, int num, double x, double *val) { int nz = 0, ierr = 0, kode = 1; double xi = 0.0; double* yi = new double[num]; double* auxyr = new double[num]; double* auxyi = new double[num]; zbesy_(&x, &xi, &n, &kode, &num, val, yi, &nz, auxyr, auxyi, &ierr); delete[] yi; delete[] auxyr; delete[] auxyi; return BesselError(ierr, "BesselYn"); } int BesselSphericalYn(double n, int num, double x, double *val) { int ierr = BesselYn(n+0.5, num, x, val); double coef = sqrt(0.5*M_PI/x); for(int i = 0; i < num; i++){ val[i] *= coef; } return BesselError(ierr, "BesselSphericalYn"); } int BesselAltSphericalYn(double n, int num, double x, double *val) { int ierr = BesselYn(n+0.5, num, x, val); double coef = sqrt(0.5*M_PI*x); for(int i = 0; i < num; i++){ val[i] *= coef; } return BesselError(ierr, "BesselAltSphericalYn"); } // Hankel functions (type = 1 or 2) int BesselHn(int type, double n, int num, double x, std::complex *val) { int nz = 0, ierr = 0, kode = 1; double* hr = new double[num]; double* hi = new double[num]; double xi = 0.0; zbesh_(&x, &xi, &n, &kode, &type, &num, hr, hi, &nz, &ierr); for(int i=0; i < num; i++){ val[i] = std::complex(hr[i], hi[i]); } delete[] hr; delete[] hi; return BesselError(ierr, "BesselHn"); } int BesselSphericalHn(int type, double n, int num, double x, std::complex *val) { int ierr = BesselHn(type, n+0.5, num, x, val); double coef = sqrt(0.5*M_PI/x); for(int i = 0; i < num; i++){ val[i] *= coef; } return BesselError(ierr, "BesselSphericalHn"); } int BesselAltSphericalHn(int type, double n, int num, double x, std::complex *val) { int ierr = BesselHn(type, n+0.5, num, x, val); double coef = sqrt(0.5*M_PI*x); for(int i = 0; i < num; i++){ val[i] *= coef; } return BesselError(ierr, "BesselAltSphericalHn"); } // Utilities for backward compatibility double Spherical_j_n(int n, double x) { double res; BesselSphericalJn(n, 1, x, &res); return res; } double AltSpherical_j_n(int n, double x) { double res; BesselAltSphericalJn(n, 1, x, &res); return res; } double Spherical_y_n(int n, double x) { double res; BesselSphericalYn(n, 1, x, &res); return res; } double AltSpherical_y_n(int n, double x) { double res; BesselAltSphericalYn(n, 1, x, &res); return res; } getdp-2.4.2-source/Numeric/Legendre.h000644 001750 001750 00000001320 12116424200 021064 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _LEGENDRE_H_ #define _LEGENDRE_H_ double Factorial(double n) ; double BinomialCoef( double n, double m ) ; double Legendre(int l, int m, double x) ; void LegendreRecursive(int l, int m, double x, double P[]) ; void LegendreRecursiveM(int l, double x, double P[]) ; double dLegendre (int l, int m, double x) ; double dLegendreFinDif (int l, int m, double x) ; void PrintLegendre(int l, int m, double x, char * FileName); void SphericalHarmonics(int l, int m, double Theta, double Phi, double Yl_m[]); #endif getdp-2.4.2-source/Numeric/NumericUtils.cpp000644 001750 001750 00000010232 12116424200 022317 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include "GetDPConfig.h" #include "Message.h" #if !defined(HAVE_GSL) && !defined(HAVE_NR) double brent(double ax, double bx, double cx, double (*f) (double), double tol, double *xmin) { Message::Error("Minimization routines require GSL or NR"); return 0; } void mnbrak(double *ax, double *bx, double *cx, double *fa_dummy, double *fb_dummy, double *fc_dummy, double (*func) (double)) { Message::Error("Minimization routines require GSL or NR"); } #endif #if defined(HAVE_GSL) #include #include #include static double (*nrfunc) (double); double fn1(double x, void *params) { double val = nrfunc(x); return val; } #define MAXITER 100 // Returns the minimum betwen ax and cx to a given tolerance tol using // brent's method. double brent(double ax, double bx, double cx, double (*f) (double), double tol, double *xmin) { int status; int iter = 0; double a, b, c; // a < b < c const gsl_min_fminimizer_type *T; gsl_min_fminimizer *s; gsl_function F; // gsl wants a= 0.0 ? fabs(a) : -fabs(a)) void mnbrak(double *ax, double *bx, double *cx, double *fa_dummy, double *fb_dummy, double *fc_dummy, double (*func) (double)) { double ulim, u, r, q; volatile double f_a, f_b, f_c, f_u; f_a = (*func) (*ax); f_b = (*func) (*bx); if(f_b > f_a) { double tmp; tmp = *ax; *ax = *bx; *bx = tmp; tmp = f_b; f_b = f_a; f_a = tmp; } *cx = *bx + MYGOLD_ * (*bx - *ax); f_c = (*func) (*cx); while(f_b > f_c) { r = (*bx - *ax) * (f_b - f_c); q = (*bx - *cx) * (f_b - f_a); u = (*bx) - ((*bx - *cx) * q - (*bx - *ax) * r) / (2.0 * SIGN(std::max(fabs(q - r), MYTINY_), q - r)); ulim = *bx + MYLIMIT_ * (*cx - *bx); if((*bx - u) * (u - *cx) > 0.0) { f_u = (*func) (u); if(f_u < f_c) { *ax = *bx; *bx = u; return; } else if(f_u > f_b) { *cx = u; return; } u = *cx + MYGOLD_ * (*cx - *bx); f_u = (*func) (u); } else if((*cx - u) * (u - ulim) > 0.0) { f_u = (*func) (u); if(f_u < f_c) { *bx = *cx; *cx = u; u = *cx + MYGOLD_ * (*cx - *bx); f_b = f_c; f_c = f_u; f_u = (*func) (u); } } else if((u - ulim) * (ulim - *cx) >= 0.0) { u = ulim; f_u = (*func) (u); } else { u = *cx + MYGOLD_ * (*cx - *bx); f_u = (*func) (u); } *ax = *bx; *bx = *cx; *cx = u; f_a = f_b; f_b = f_c; f_c = f_u; } } #endif getdp-2.4.2-source/Numeric/Legendre.cpp000644 001750 001750 00000011504 12166744441 021445 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Ruth Sabariego // #include #include #include "Message.h" #define THESIGN(a) ((a)>=0 ? 1 : -1) #define THEABS(a) ((a)>=0 ? a : -a) #define ONE_OVER_FOUR_PI 7.9577471545947668E-02 double Factorial(double n) { /* FACTORIAL(n) is the product of all the integers from 1 to n */ double F ; if ( n < 0 ){ Message::Error("Factorial(n): n must be a positive integer") ; return 0; } if ( n == 0 ) return 1. ; if ( n <= 2 ) return n ; F = n ; while ( n > 2 ){ n-- ; F *= n ; } return F; } double BinomialCoef(double n, double m) { /* Binomial Coefficients: (n m) Computes de number of ways of choosing m objects from a collection of n distinct objects */ int i ; double B = 1. ; if (m==0 || n==m) return 1. ; for(i = (int)n ; i > m ; i--) B *= (double)i/(double)(i-m); return B; } double Legendre(int l, int m, double x) { /* Computes the associated Legendre polynomial P_l^m(x). Here the degree l and the order m are the integers satisfying -l<=m<=l, while x lies in the range -1<=x<=1 */ double fact, pll=0., pmm, pmmp1, somx2, Cte ; int i, ll; if ( THEABS(m) > l || fabs(x) > 1.){ Message::Error("Bad arguments for Legendre: P_l^m(x) with -l<=m<=l (int)," " -1<=x<=1 l = %d m = %d x = %.8g", l, m, x); return 0.; } Cte = (m > 0) ? 1. : Factorial((double)(l-THEABS(m))) / Factorial((double)(l+THEABS(m))) * pow(-1.,(double)THEABS(m)) ; m = THEABS(m) ; pmm = 1. ; if (m > 0) { somx2 = sqrt((1.-x)*(1.+x)) ; fact = 1. ; for (i=1;i<=m;i++){ pmm *= -fact*somx2 ; fact += 2. ; } } if (l==m){ return Cte*pmm ; } else { pmmp1 = x * (2*m+1)*pmm ; if (l==(m+1)){ return Cte*pmmp1 ; } else { for (ll=(m+2);ll<=l;ll++) { pll = (x*(2*ll-1)*pmmp1-(ll+m-1)*pmm)/(ll-m) ; pmm = pmmp1 ; pmmp1 = pll ; } return Cte*pll ; } } } void LegendreRecursive(int l, int m, double x, double P[]) { /* Computes recursively a (l+1)-terms sequence of the associated Legendre polynomial P_l^m(x). l and m are the integers satisfying 0<=m<=l x lies in the range -1<=x<=1 l = maximum order considered, m = invariable */ int il ; double Pl_m, Plm1_m ; P[0] = Plm1_m = Legendre(0, m, x) ; P[1] = Pl_m = Legendre(1, m, x) ; if (l >=2) for(il = 1 ; il < l ; il ++){ P[il+1] = (2*il+1)*x*Pl_m/(il-m+1) + (il+m)*Plm1_m/(m-il-1) ; Plm1_m = Pl_m ; Pl_m = P[il+1]; } } void LegendreRecursiveM(int l, double x, double P[]) { /* Computes recursively a (l+1)-terms sequence of the associated Legendre polynomial P_l^m(x). x lies in the range -1<=x<=1, l = invariable, -l<=m<=l */ int m ; double Pl_m, Plm1_m ; if (fabs(x) == 1.) for(m = -l ; m <= l ; m ++) P[l+m] = (m==0) ? pow(THESIGN(x),(double)l) : 0. ; else{ if (l==0){ P[0] = Legendre(0, 0, x) ; return; } P[0] = Plm1_m = Legendre(l, -l, x) ; P[1] = Pl_m = Legendre(l, -l+1, x) ; if (l >= 1) for(m = -l+1 ; m < l ; m ++){ P[l+m+1] = -2*m*x*Pl_m/sqrt(1-x*x) + (m*(m-1)-l*(l+1))*Plm1_m ; Plm1_m = Pl_m ; Pl_m = P[l+m+1]; } else return ; } } double dLegendre (int l, int m, double x) { /* Computes the derivative of the associated Legendre polynomial P_l^m(x) */ double dpl; if ( THEABS(m) > l || fabs(x) > 1.){ Message::Error("Bad arguments for dLegendre: -l<=m<=l (integers), -1<=x<=1." " Current values: l %d m %d x %.8g", l, m, x) ; return 0.; } if (fabs(x)==1.) dpl = 0.; else dpl = ((l+m)*(l-m+1)*sqrt(1-x*x)*((THEABS((m-1))>l) ? 0. : Legendre(l, m-1, x)) + m*x* Legendre (l,m,x))/(1-x*x); return dpl; } double dLegendreFinDif (int l, int m, double x) { /* Computes the derivative of the associated Legendre polynomial P_l^m(x) using Finite Differences: f'(x) = (f(x+\delta x)-f(x-\delta x))/(2 \delta) */ double dpl, delta = 1e-6; if ( THEABS(m) > l || fabs(x) > 1.){ Message::Error("Bad arguments for dLegendreFinDif: -l<=m<=l (integers), " "-1<=x<=1. Current values: l %d m %d x %.8g", l, m, x ); return 0.; } dpl = (Legendre (l, m, x+delta) - Legendre (l, m, x-delta))/(2*delta); return dpl; } void SphericalHarmonics(int l, int m, double Theta, double Phi, double Yl_m[]) { int am ; double cn, Pl_m, F, cRe ; cn = sqrt((2*l+1)*ONE_OVER_FOUR_PI) ; /* Normalization Factor */ am = THESIGN(m)*m ; F= sqrt(Factorial((double)(l-am))/ Factorial((double)(l+am))) ; Pl_m = Legendre(l, am, cos(Theta)); cRe = cn * F * Pl_m ; Yl_m[0] = cRe*cos(m*Phi) ; Yl_m[1] = cRe*sin(m*Phi) ; } getdp-2.4.2-source/Numeric/NumericUtils.h000644 001750 001750 00000001063 12116424200 021766 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _NUMERIC_UTILS_H_ #define _NUMERIC_UTILS_H_ // Numerical routines implemented using either the GSL or Numerical Recipes double brent(double ax, double bx, double cx, double (*f)(double), double tol, double *xmin); void mnbrak(double *ax, double *bx, double *cx, double *fa, double *fb, double *fc, double (*func)(double)); #endif getdp-2.4.2-source/Numeric/Bessel.h000644 001750 001750 00000002617 12116424200 020566 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #ifndef _BESSEL_H_ #define _BESSEL_H_ #include #include #define BESSEL_ERROR_INPUT 1 #define BESSEL_OVERFLOW 2 #define BESSEL_HALF_ACCURACY 3 #define BESSEL_NO_ACCURACY 4 #define BESSEL_NO_CONVERGENCE 5 // These routines provide a C++ interface to the Fortran Bessel // functions from Donald E. Amos (Sandia National Laboratories) int BesselJn(double n, int num, double x, double *val); int BesselSphericalJn(double n, int num, double x, double *val); int BesselAltSphericalJn(double n, int num, double x, double *val); int BesselYn(double n, int num, double x, double *val); int BesselSphericalYn(double n, int num, double x, double *val); int BesselAltSphericalYn(double n, int num, double x, double *val); int BesselHn(int type, double n, int num, double x, std::complex *val); int BesselSphericalHn(int type, double n, int num, double x, std::complex *val); int BesselAltSphericalHn(int type, double n, int num, double x, std::complex *val); // Utilities for backward compatibility double Spherical_j_n(int n, double x); double AltSpherical_j_n(int n, double x); double Spherical_y_n(int n, double x); double AltSpherical_y_n(int n, double x); #endif getdp-2.4.2-source/Numeric/CMakeLists.txt000644 001750 001750 00000000663 12116424200 021737 0ustar00geuzainegeuzaine000000 000000 # GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine # # See the LICENSE.txt file for license information. Please report all # bugs and problems to the public mailing list . set(SRC NumericUtils.cpp Adapt.cpp Legendre.cpp Bessel.cpp ) if(ENABLE_FORTRAN) list(APPEND SRC BesselLib.f) endif(ENABLE_FORTRAN) file(GLOB HDR RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} *.h) append_getdp_src(Numeric "${SRC};${HDR}") getdp-2.4.2-source/Numeric/BesselLib.f000644 001750 001750 00001067512 11266605602 021235 0ustar00geuzainegeuzaine000000 000000 REAL FUNCTION R1MACH(I) INTEGER I C C SINGLE-PRECISION MACHINE CONSTANTS C R1MACH(1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. C R1MACH(2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C R1MACH(3) = B**(-T), THE SMALLEST RELATIVE SPACING. C R1MACH(4) = B**(1-T), THE LARGEST RELATIVE SPACING. C R1MACH(5) = LOG10(B) C C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES, C INCLUDING AUTO-DOUBLE COMPILERS. C TO ALTER FOR A PARTICULAR ENVIRONMENT, THE DESIRED SET OF DATA C STATEMENTS MAY BE ACTIVATED BY REMOVING THE C FROM COLUMN 1. C CONSTANTS FOR OLDER MACHINES CAN BE OBTAINED BY C mail netlib@research.bell-labs.com C send old1mach from blas C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com. C INTEGER SMALL(2) INTEGER LARGE(2) INTEGER RIGHT(2) INTEGER DIVER(2) INTEGER LOG10(2) INTEGER SC SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC REAL RMACH(5) EQUIVALENCE (RMACH(1),SMALL(1)) EQUIVALENCE (RMACH(2),LARGE(1)) EQUIVALENCE (RMACH(3),RIGHT(1)) EQUIVALENCE (RMACH(4),DIVER(1)) EQUIVALENCE (RMACH(5),LOG10(1)) INTEGER J, K, L, T3E(3) DATA T3E(1) / 9777664 / DATA T3E(2) / 5323660 / DATA T3E(3) / 46980 / C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. C DATA RMACH(1) / O402400000000 / C DATA RMACH(2) / O376777777777 / C DATA RMACH(3) / O714400000000 / C DATA RMACH(4) / O716400000000 / C DATA RMACH(5) / O776464202324 /, SC/987/ C C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C DATA SMALL(1) / 8388608 / C DATA LARGE(1) / 2147483647 / C DATA RIGHT(1) / 880803840 / C DATA DIVER(1) / 889192448 / C DATA LOG10(1) / 1067065499 /, SC/987/ C DATA RMACH(1) / O00040000000 / C DATA RMACH(2) / O17777777777 / C DATA RMACH(3) / O06440000000 / C DATA RMACH(4) / O06500000000 / C DATA RMACH(5) / O07746420233 /, SC/987/ C C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. C DATA SMALL(1) / $00800000 / C DATA LARGE(1) / $7F7FFFFF / C DATA RIGHT(1) / $33800000 / C DATA DIVER(1) / $34000000 / C DATA LOG10(1) / $3E9A209B /, SC/987/ C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C DATA RMACH(1) / O000400000000 / C DATA RMACH(2) / O377777777777 / C DATA RMACH(3) / O146400000000 / C DATA RMACH(4) / O147400000000 / C DATA RMACH(5) / O177464202324 /, SC/987/ C IF (SC .NE. 987) THEN * *** CHECK FOR AUTODOUBLE *** SMALL(2) = 0 RMACH(1) = 1E13 IF (SMALL(2) .NE. 0) THEN * *** AUTODOUBLED *** IF ( SMALL(1) .EQ. 1117925532 * .AND. SMALL(2) .EQ. -448790528) THEN * *** IEEE BIG ENDIAN *** SMALL(1) = 1048576 SMALL(2) = 0 LARGE(1) = 2146435071 LARGE(2) = -1 RIGHT(1) = 1017118720 RIGHT(2) = 0 DIVER(1) = 1018167296 DIVER(2) = 0 LOG10(1) = 1070810131 LOG10(2) = 1352628735 ELSE IF ( SMALL(2) .EQ. 1117925532 * .AND. SMALL(1) .EQ. -448790528) THEN * *** IEEE LITTLE ENDIAN *** SMALL(2) = 1048576 SMALL(1) = 0 LARGE(2) = 2146435071 LARGE(1) = -1 RIGHT(2) = 1017118720 RIGHT(1) = 0 DIVER(2) = 1018167296 DIVER(1) = 0 LOG10(2) = 1070810131 LOG10(1) = 1352628735 ELSE IF ( SMALL(1) .EQ. -2065213935 * .AND. SMALL(2) .EQ. 10752) THEN * *** VAX WITH D_FLOATING *** SMALL(1) = 128 SMALL(2) = 0 LARGE(1) = -32769 LARGE(2) = -1 RIGHT(1) = 9344 RIGHT(2) = 0 DIVER(1) = 9472 DIVER(2) = 0 LOG10(1) = 546979738 LOG10(2) = -805796613 ELSE IF ( SMALL(1) .EQ. 1267827943 * .AND. SMALL(2) .EQ. 704643072) THEN * *** IBM MAINFRAME *** SMALL(1) = 1048576 SMALL(2) = 0 LARGE(1) = 2147483647 LARGE(2) = -1 RIGHT(1) = 856686592 RIGHT(2) = 0 DIVER(1) = 873463808 DIVER(2) = 0 LOG10(1) = 1091781651 LOG10(2) = 1352628735 ELSE WRITE(*,9010) STOP 777 END IF ELSE RMACH(1) = 1234567. IF (SMALL(1) .EQ. 1234613304) THEN * *** IEEE *** SMALL(1) = 8388608 LARGE(1) = 2139095039 RIGHT(1) = 864026624 DIVER(1) = 872415232 LOG10(1) = 1050288283 ELSE IF (SMALL(1) .EQ. -1271379306) THEN * *** VAX *** SMALL(1) = 128 LARGE(1) = -32769 RIGHT(1) = 13440 DIVER(1) = 13568 LOG10(1) = 547045274 ELSE IF (SMALL(1) .EQ. 1175639687) THEN * *** IBM MAINFRAME *** SMALL(1) = 1048576 LARGE(1) = 2147483647 RIGHT(1) = 990904320 DIVER(1) = 1007681536 LOG10(1) = 1091781651 ELSE IF (SMALL(1) .EQ. 1251390520) THEN * *** CONVEX C-1 *** SMALL(1) = 8388608 LARGE(1) = 2147483647 RIGHT(1) = 880803840 DIVER(1) = 889192448 LOG10(1) = 1067065499 ELSE DO 10 L = 1, 3 J = SMALL(1) / 10000000 K = SMALL(1) - 10000000*J IF (K .NE. T3E(L)) GO TO 20 SMALL(1) = J 10 CONTINUE * *** CRAY T3E *** CALL I1MT3E(SMALL, 16, 0, 0) CALL I1MT3E(LARGE, 32751, 16777215, 16777215) CALL I1MT3E(RIGHT, 15520, 0, 0) CALL I1MT3E(DIVER, 15536, 0, 0) CALL I1MT3E(LOG10, 16339, 4461392, 10451455) GO TO 30 20 CALL I1MCRA(J, K, 16405, 9876536, 0) IF (SMALL(1) .NE. J) THEN WRITE(*,9020) STOP 777 END IF * *** CRAY 1, XMP, 2, AND 3 *** CALL I1MCRA(SMALL(1), K, 8195, 8388608, 0) CALL I1MCRA(LARGE(1), K, 24574, 16777215, 16777214) CALL I1MCRA(RIGHT(1), K, 16338, 8388608, 0) CALL I1MCRA(DIVER(1), K, 16339, 8388608, 0) CALL I1MCRA(LOG10(1), K, 16383, 10100890, 8715216) END IF END IF 30 SC = 987 END IF * SANITY CHECK IF (RMACH(4) .GE. 1.0) STOP 776 IF (I .LT. 1 .OR. I .GT. 5) THEN WRITE(*,*) 'R1MACH(I): I =',I,' is out of bounds.' STOP END IF R1MACH = RMACH(I) RETURN 9010 FORMAT(/' Adjust autodoubled R1MACH by getting data'/ *' appropriate for your machine from D1MACH.') 9020 FORMAT(/' Adjust R1MACH by uncommenting data statements'/ *' appropriate for your machine.') * /* C source for R1MACH -- remove the * in column 1 */ *#include *#include *#include *float r1mach_(long *i) *{ * switch(*i){ * case 1: return FLT_MIN; * case 2: return FLT_MAX; * case 3: return FLT_EPSILON/FLT_RADIX; * case 4: return FLT_EPSILON; * case 5: return log10(FLT_RADIX); * } * fprintf(stderr, "invalid argument: r1mach(%ld)\n", *i); * exit(1); return 0; /* else complaint of missing return value */ *} END SUBROUTINE I1MT3E(A, B, C, D) **** SPECIAL COMPUTATION FOR CRAY T3E **** **** 64-BIT INTEGERS, "REAL" = IEEE DOUBLE **** INTEGER A(2), B, C, D A(2) = 16777216*B + C A(1) = 16777216*A(1) + D END SUBROUTINE I1MCRA(A, A1, B, C, D) **** SPECIAL COMPUTATION FOR OLD CRAY MACHINES **** INTEGER A, A1, B, C, D A1 = 16777216*B + C A = 16777216*A1 + D END c----------------------------------------------------------------------- c----------------------------------------------------------------------- DOUBLE PRECISION FUNCTION D1MACH(I) INTEGER I C C DOUBLE-PRECISION MACHINE CONSTANTS C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING. C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING. C D1MACH( 5) = LOG10(B) C C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES. C R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF C D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR C MANY MACHINES YET. C TO ALTER FOR A PARTICULAR ENVIRONMENT, THE DESIRED SET OF DATA C STATEMENTS MAY BE ACTIVATED BY REMOVING THE C FROM COLUMN 1. C CONSTANTS FOR OLDER MACHINES CAN BE OBTAINED BY C mail netlib@research.bell-labs.com C send old1mach from blas C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com. C INTEGER SMALL(2) INTEGER LARGE(2) INTEGER RIGHT(2) INTEGER DIVER(2) INTEGER LOG10(2) INTEGER SC, CRAY1(38), J COMMON /D9MACH/ CRAY1 SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC DOUBLE PRECISION DMACH(5) EQUIVALENCE (DMACH(1),SMALL(1)) EQUIVALENCE (DMACH(2),LARGE(1)) EQUIVALENCE (DMACH(3),RIGHT(1)) EQUIVALENCE (DMACH(4),DIVER(1)) EQUIVALENCE (DMACH(5),LOG10(1)) C C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 / C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 / C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 / C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 / C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/ C C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING C 32-BIT INTEGERS. C DATA SMALL(1),SMALL(2) / 8388608, 0 / C DATA LARGE(1),LARGE(2) / 2147483647, -1 / C DATA RIGHT(1),RIGHT(2) / 612368384, 0 / C DATA DIVER(1),DIVER(2) / 620756992, 0 / C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/ C C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000 C DATA SMALL(1),SMALL(2) / $00000000, $00100000 / C DATA LARGE(1),LARGE(2) / $FFFFFFFF, $7FEFFFFF / C DATA RIGHT(1),RIGHT(2) / $00000000, $3CA00000 / C DATA DIVER(1),DIVER(2) / $00000000, $3CB00000 / C DATA LOG10(1),LOG10(2) / $509F79FF, $3FD34413 /, SC/987/ C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 / C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 / C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 / C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 / C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/ C C ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES. IF (SC .NE. 987) THEN DMACH(1) = 1.D13 IF ( SMALL(1) .EQ. 1117925532 * .AND. SMALL(2) .EQ. -448790528) THEN * *** IEEE BIG ENDIAN *** SMALL(1) = 1048576 SMALL(2) = 0 LARGE(1) = 2146435071 LARGE(2) = -1 RIGHT(1) = 1017118720 RIGHT(2) = 0 DIVER(1) = 1018167296 DIVER(2) = 0 LOG10(1) = 1070810131 LOG10(2) = 1352628735 ELSE IF ( SMALL(2) .EQ. 1117925532 * .AND. SMALL(1) .EQ. -448790528) THEN * *** IEEE LITTLE ENDIAN *** SMALL(2) = 1048576 SMALL(1) = 0 LARGE(2) = 2146435071 LARGE(1) = -1 RIGHT(2) = 1017118720 RIGHT(1) = 0 DIVER(2) = 1018167296 DIVER(1) = 0 LOG10(2) = 1070810131 LOG10(1) = 1352628735 ELSE IF ( SMALL(1) .EQ. -2065213935 * .AND. SMALL(2) .EQ. 10752) THEN * *** VAX WITH D_FLOATING *** SMALL(1) = 128 SMALL(2) = 0 LARGE(1) = -32769 LARGE(2) = -1 RIGHT(1) = 9344 RIGHT(2) = 0 DIVER(1) = 9472 DIVER(2) = 0 LOG10(1) = 546979738 LOG10(2) = -805796613 ELSE IF ( SMALL(1) .EQ. 1267827943 * .AND. SMALL(2) .EQ. 704643072) THEN * *** IBM MAINFRAME *** SMALL(1) = 1048576 SMALL(2) = 0 LARGE(1) = 2147483647 LARGE(2) = -1 RIGHT(1) = 856686592 RIGHT(2) = 0 DIVER(1) = 873463808 DIVER(2) = 0 LOG10(1) = 1091781651 LOG10(2) = 1352628735 ELSE IF ( SMALL(1) .EQ. 1120022684 * .AND. SMALL(2) .EQ. -448790528) THEN * *** CONVEX C-1 *** SMALL(1) = 1048576 SMALL(2) = 0 LARGE(1) = 2147483647 LARGE(2) = -1 RIGHT(1) = 1019215872 RIGHT(2) = 0 DIVER(1) = 1020264448 DIVER(2) = 0 LOG10(1) = 1072907283 LOG10(2) = 1352628735 ELSE IF ( SMALL(1) .EQ. 815547074 * .AND. SMALL(2) .EQ. 58688) THEN * *** VAX G-FLOATING *** SMALL(1) = 16 SMALL(2) = 0 LARGE(1) = -32769 LARGE(2) = -1 RIGHT(1) = 15552 RIGHT(2) = 0 DIVER(1) = 15568 DIVER(2) = 0 LOG10(1) = 1142112243 LOG10(2) = 2046775455 ELSE DMACH(2) = 1.D27 + 1 DMACH(3) = 1.D27 LARGE(2) = LARGE(2) - RIGHT(2) IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN CRAY1(1) = 67291416 DO 10 J = 1, 20 10 CRAY1(J+1) = CRAY1(J) + CRAY1(J) CRAY1(22) = CRAY1(21) + 321322 DO 20 J = 22, 37 20 CRAY1(J+1) = CRAY1(J) + CRAY1(J) IF (CRAY1(38) .EQ. SMALL(1)) THEN * *** CRAY *** CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0) SMALL(2) = 0 CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215) CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214) CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0) RIGHT(2) = 0 CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0) DIVER(2) = 0 CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215) CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388) ELSE WRITE(*,9000) STOP 779 END IF ELSE WRITE(*,9000) STOP 779 END IF END IF SC = 987 END IF * SANITY CHECK IF (DMACH(4) .GE. 1.0D0) STOP 778 IF (I .LT. 1 .OR. I .GT. 5) THEN WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.' STOP END IF D1MACH = DMACH(I) RETURN 9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/ *' appropriate for your machine.') * /* Standard C source for D1MACH -- remove the * in column 1 */ *#include *#include *#include *double d1mach_(long *i) *{ * switch(*i){ * case 1: return DBL_MIN; * case 2: return DBL_MAX; * case 3: return DBL_EPSILON/FLT_RADIX; * case 4: return DBL_EPSILON; * case 5: return log10(FLT_RADIX); * } * fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i); * exit(1); return 0; /* some compilers demand return values */ *} END SUBROUTINE I1MCRY(A, A1, B, C, D) **** SPECIAL COMPUTATION FOR OLD CRAY MACHINES **** INTEGER A, A1, B, C, D A1 = 16777216*B + C A = 16777216*A1 + D END c----------------------------------------------------------------------- c----------------------------------------------------------------------- INTEGER FUNCTION I1MACH(I) INTEGER I C C I1MACH( 1) = THE STANDARD INPUT UNIT. C I1MACH( 2) = THE STANDARD OUTPUT UNIT. C I1MACH( 3) = THE STANDARD PUNCH UNIT. C I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT. C I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT. C I1MACH( 6) = THE NUMBER OF CHARACTERS PER CHARACTER STORAGE UNIT. C INTEGERS HAVE FORM SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) C I1MACH( 7) = A, THE BASE. C I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS. C I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE. C FLOATS HAVE FORM SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) C WHERE EMIN .LE. E .LE. EMAX. C I1MACH(10) = B, THE BASE. C SINGLE-PRECISION C I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS. C I1MACH(12) = EMIN, THE SMALLEST EXPONENT E. C I1MACH(13) = EMAX, THE LARGEST EXPONENT E. C DOUBLE-PRECISION C I1MACH(14) = T, THE NUMBER OF BASE-B DIGITS. C I1MACH(15) = EMIN, THE SMALLEST EXPONENT E. C I1MACH(16) = EMAX, THE LARGEST EXPONENT E. C INTEGER IMACH(16), OUTPUT, SANITY, SMALL(2) SAVE IMACH, SANITY REAL RMACH EQUIVALENCE (IMACH(4),OUTPUT), (RMACH,SMALL(1)) INTEGER J, K, T3E(3) DATA T3E(1) / 9777664 / DATA T3E(2) / 5323660 / DATA T3E(3) / 46980 / C C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 43 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / O377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 63 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 /, SANITY/987/ C C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING C 32-BIT INTEGER ARITHMETIC. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 56 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 /, SANITY/987/ C C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. C C DATA IMACH( 1) / 0 / C DATA IMACH( 2) / 0 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 0 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 1 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 /, SANITY/987/ C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C C NOTE THAT THE PUNCH UNIT, I1MACH(3), HAS BEEN SET TO 7 C WHICH IS APPROPRIATE FOR THE UNIVAC-FOR SYSTEM. C IF YOU HAVE THE UNIVAC-FTN SYSTEM, SET IT TO 1. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 6 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / O377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 60 / C DATA IMACH(15) /-1024 / C DATA IMACH(16) / 1023 /, SANITY/987/ C IF (SANITY .NE. 987) THEN * *** CHECK FOR AUTODOUBLE *** SMALL(2) = 0 RMACH = 1E13 IF (SMALL(2) .NE. 0) THEN * *** AUTODOUBLED *** IF ( (SMALL(1) .EQ. 1117925532 * .AND. SMALL(2) .EQ. -448790528) * .OR. (SMALL(2) .EQ. 1117925532 * .AND. SMALL(1) .EQ. -448790528)) THEN * *** IEEE *** IMACH(10) = 2 IMACH(14) = 53 IMACH(15) = -1021 IMACH(16) = 1024 ELSE IF ( SMALL(1) .EQ. -2065213935 * .AND. SMALL(2) .EQ. 10752) THEN * *** VAX WITH D_FLOATING *** IMACH(10) = 2 IMACH(14) = 56 IMACH(15) = -127 IMACH(16) = 127 ELSE IF ( SMALL(1) .EQ. 1267827943 * .AND. SMALL(2) .EQ. 704643072) THEN * *** IBM MAINFRAME *** IMACH(10) = 16 IMACH(14) = 14 IMACH(15) = -64 IMACH(16) = 63 ELSE WRITE(*,9010) STOP 777 END IF IMACH(11) = IMACH(14) IMACH(12) = IMACH(15) IMACH(13) = IMACH(16) ELSE RMACH = 1234567. IF (SMALL(1) .EQ. 1234613304) THEN * *** IEEE *** IMACH(10) = 2 IMACH(11) = 24 IMACH(12) = -125 IMACH(13) = 128 IMACH(14) = 53 IMACH(15) = -1021 IMACH(16) = 1024 SANITY = 987 ELSE IF (SMALL(1) .EQ. -1271379306) THEN * *** VAX *** IMACH(10) = 2 IMACH(11) = 24 IMACH(12) = -127 IMACH(13) = 127 IMACH(14) = 56 IMACH(15) = -127 IMACH(16) = 127 SANITY = 987 ELSE IF (SMALL(1) .EQ. 1175639687) THEN * *** IBM MAINFRAME *** IMACH(10) = 16 IMACH(11) = 6 IMACH(12) = -64 IMACH(13) = 63 IMACH(14) = 14 IMACH(15) = -64 IMACH(16) = 63 SANITY = 987 ELSE IF (SMALL(1) .EQ. 1251390520) THEN * *** CONVEX C-1 *** IMACH(10) = 2 IMACH(11) = 24 IMACH(12) = -128 IMACH(13) = 127 IMACH(14) = 53 IMACH(15) = -1024 IMACH(16) = 1023 ELSE DO 10 I = 1, 3 J = SMALL(1) / 10000000 K = SMALL(1) - 10000000*J IF (K .NE. T3E(I)) GO TO 20 SMALL(1) = J 10 CONTINUE * *** CRAY T3E *** IMACH(10) = 2 IMACH(11) = 53 IMACH(12) = -1024 IMACH(13) = 1023 IMACH(14) = 0 IMACH(15) = 0 IMACH(16) = 0 GO TO 30 20 CALL I1MCR1(J, K, 16405, 9876536, 0) IF (SMALL(1) .NE. J) THEN WRITE(*,9020) STOP 777 END IF * *** CRAY 1, XMP, 2, AND 3 *** IMACH(1) = 5 IMACH(2) = 6 IMACH(3) = 102 IMACH(4) = 6 IMACH(5) = 64 IMACH(6) = 8 IMACH(7) = 2 IMACH(8) = 63 CALL I1MCR1(IMACH(9), K, 32767, 16777215, 16777215) IMACH(10) = 2 IMACH(11) = 47 IMACH(12) = -8189 IMACH(13) = 8190 IMACH(14) = 94 IMACH(15) = -8099 IMACH(16) = 8190 GO TO 35 END IF END IF 30 IMACH( 1) = 5 IMACH( 2) = 6 IMACH( 3) = 7 IMACH( 4) = 6 IMACH( 5) = 32 IMACH( 6) = 4 IMACH( 7) = 2 IMACH( 8) = 31 IMACH( 9) = 2147483647 35 SANITY = 987 END IF 9010 FORMAT(/' Adjust autodoubled I1MACH by uncommenting data'/ * ' statements appropriate for your machine and setting'/ * ' IMACH(I) = IMACH(I+3) for I = 11, 12, and 13.') 9020 FORMAT(/' Adjust I1MACH by uncommenting data statements'/ * ' appropriate for your machine.') IF (I .LT. 1 .OR. I .GT. 16) GO TO 40 I1MACH = IMACH(I) C REMOVE THE FOLLOWING LINE IF FORTRAN66 IS PREFERRED TO FORTRAN77. IF (I .EQ. 6) I1MACH = 1 RETURN 40 WRITE(*,*) 'I1MACH(I): I =',I,' is out of bounds.' STOP * /* C source for I1MACH -- remove the * in column 1 */ * /* Note that some values may need changing. */ *#include *#include *#include *#include * *long i1mach_(long *i) *{ * switch(*i){ * case 1: return 5; /* standard input */ * case 2: return 6; /* standard output */ * case 3: return 7; /* standard punch */ * case 4: return 0; /* standard error */ * case 5: return 32; /* bits per integer */ * case 6: return 1; /* Fortran 77 value */ * case 7: return 2; /* base for integers */ * case 8: return 31; /* digits of integer base */ * case 9: return LONG_MAX; * case 10: return FLT_RADIX; * case 11: return FLT_MANT_DIG; * case 12: return FLT_MIN_EXP; * case 13: return FLT_MAX_EXP; * case 14: return DBL_MANT_DIG; * case 15: return DBL_MIN_EXP; * case 16: return DBL_MAX_EXP; * } * fprintf(stderr, "invalid argument: i1mach(%ld)\n", *i); * exit(1);return 0; /* some compilers demand return values */ *} END SUBROUTINE I1MCR1(A, A1, B, C, D) **** SPECIAL COMPUTATION FOR OLD CRAY MACHINES **** INTEGER A, A1, B, C, D A1 = 16777216*B + C A = 16777216*A1 + D END c----------------------------------------------------------------------- double precision function dgamln(z,ierr) c Logarithm of Gamma function c author Amos, Donald E., Sandia National Laboratories c c dgamln computes the natural log of the gamma function for c z.gt.0. the asymptotic expansion is used to generate values c greater than zmin which are adjusted by the recursion c g(z+1)=z*g(z) for z.le.zmin. the function was made as c portable as possible by computimg zmin from the number of base c 10 digits in a word, rln=amax1(-alog10(r1mach(4)),0.5e-18) c limited to 18 digits of (relative) accuracy. c c since integer arguments are common, a table look up on 100 c values is used for speed of execution. c c description of arguments c c input z is d0uble precision c z - argument, z.gt.0.0d0 c c output dgamln is double precision c dgamln - natural log of the gamma function at z.ne.0.0d0 c ierr - error flag c ierr=0, normal return, computation completed c ierr=1, z.le.0.0d0, no computation c c c***routines called i1mach,d1mach double precision cf, con, fln, fz, gln, rln, s, tlg, trm, tst, * t1, wdtol, z, zdmy, zinc, zm, zmin, zp, zsq, d1mach integer i, ierr, i1m, k, mz, nz, i1mach dimension cf(22), gln(100) c lngamma(n), n=1,100 data gln(1), gln(2), gln(3), gln(4), gln(5), gln(6), gln(7), 1 gln(8), gln(9), gln(10), gln(11), gln(12), gln(13), gln(14), 2 gln(15), gln(16), gln(17), gln(18), gln(19), gln(20), 3 gln(21), gln(22)/ 4 0.00000000000000000d+00, 0.00000000000000000d+00, 5 6.93147180559945309d-01, 1.79175946922805500d+00, 6 3.17805383034794562d+00, 4.78749174278204599d+00, 7 6.57925121201010100d+00, 8.52516136106541430d+00, 8 1.06046029027452502d+01, 1.28018274800814696d+01, 9 1.51044125730755153d+01, 1.75023078458738858d+01, a 1.99872144956618861d+01, 2.25521638531234229d+01, b 2.51912211827386815d+01, 2.78992713838408916d+01, c 3.06718601060806728d+01, 3.35050734501368889d+01, d 3.63954452080330536d+01, 3.93398841871994940d+01, e 4.23356164607534850d+01, 4.53801388984769080d+01/ data gln(23), gln(24), gln(25), gln(26), gln(27), gln(28), 1 gln(29), gln(30), gln(31), gln(32), gln(33), gln(34), 2 gln(35), gln(36), gln(37), gln(38), gln(39), gln(40), 3 gln(41), gln(42), gln(43), gln(44)/ 4 4.84711813518352239d+01, 5.16066755677643736d+01, 5 5.47847293981123192d+01, 5.80036052229805199d+01, 6 6.12617017610020020d+01, 6.45575386270063311d+01, 7 6.78897431371815350d+01, 7.12570389671680090d+01, 8 7.46582363488301644d+01, 7.80922235533153106d+01, 9 8.15579594561150372d+01, 8.50544670175815174d+01, a 8.85808275421976788d+01, 9.21361756036870925d+01, b 9.57196945421432025d+01, 9.93306124547874269d+01, c 1.02968198614513813d+02, 1.06631760260643459d+02, d 1.10320639714757395d+02, 1.14034211781461703d+02, e 1.17771881399745072d+02, 1.21533081515438634d+02/ data gln(45), gln(46), gln(47), gln(48), gln(49), gln(50), 1 gln(51), gln(52), gln(53), gln(54), gln(55), gln(56), 2 gln(57), gln(58), gln(59), gln(60), gln(61), gln(62), 3 gln(63), gln(64), gln(65), gln(66)/ 4 1.25317271149356895d+02, 1.29123933639127215d+02, 5 1.32952575035616310d+02, 1.36802722637326368d+02, 6 1.40673923648234259d+02, 1.44565743946344886d+02, 7 1.48477766951773032d+02, 1.52409592584497358d+02, 8 1.56360836303078785d+02, 1.60331128216630907d+02, 9 1.64320112263195181d+02, 1.68327445448427652d+02, a 1.72352797139162802d+02, 1.76395848406997352d+02, b 1.80456291417543771d+02, 1.84533828861449491d+02, c 1.88628173423671591d+02, 1.92739047287844902d+02, d 1.96866181672889994d+02, 2.01009316399281527d+02, e 2.05168199482641199d+02, 2.09342586752536836d+02/ data gln(67), gln(68), gln(69), gln(70), gln(71), gln(72), 1 gln(73), gln(74), gln(75), gln(76), gln(77), gln(78), 2 gln(79), gln(80), gln(81), gln(82), gln(83), gln(84), 3 gln(85), gln(86), gln(87), gln(88)/ 4 2.13532241494563261d+02, 2.17736934113954227d+02, 5 2.21956441819130334d+02, 2.26190548323727593d+02, 6 2.30439043565776952d+02, 2.34701723442818268d+02, 7 2.38978389561834323d+02, 2.43268849002982714d+02, 8 2.47572914096186884d+02, 2.51890402209723194d+02, 9 2.56221135550009525d+02, 2.60564940971863209d+02, a 2.64921649798552801d+02, 2.69291097651019823d+02, b 2.73673124285693704d+02, 2.78067573440366143d+02, c 2.82474292687630396d+02, 2.86893133295426994d+02, d 2.91323950094270308d+02, 2.95766601350760624d+02, e 3.00220948647014132d+02, 3.04686856765668715d+02/ data gln(89), gln(90), gln(91), gln(92), gln(93), gln(94), 1 gln(95), gln(96), gln(97), gln(98), gln(99), gln(100)/ 2 3.09164193580146922d+02, 3.13652829949879062d+02, 3 3.18152639620209327d+02, 3.22663499126726177d+02, 4 3.27185287703775217d+02, 3.31717887196928473d+02, 5 3.36261181979198477d+02, 3.40815058870799018d+02, 6 3.45379407062266854d+02, 3.49954118040770237d+02, 7 3.54539085519440809d+02, 3.59134205369575399d+02/ c coefficients of asymptotic expansion data cf(1), cf(2), cf(3), cf(4), cf(5), cf(6), cf(7), cf(8), 1 cf(9), cf(10), cf(11), cf(12), cf(13), cf(14), cf(15), 2 cf(16), cf(17), cf(18), cf(19), cf(20), cf(21), cf(22)/ 3 8.33333333333333333d-02, -2.77777777777777778d-03, 4 7.93650793650793651d-04, -5.95238095238095238d-04, 5 8.41750841750841751d-04, -1.91752691752691753d-03, 6 6.41025641025641026d-03, -2.95506535947712418d-02, 7 1.79644372368830573d-01, -1.39243221690590112d+00, 8 1.34028640441683920d+01, -1.56848284626002017d+02, 9 2.19310333333333333d+03, -3.61087712537249894d+04, a 6.91472268851313067d+05, -1.52382215394074162d+07, b 3.82900751391414141d+08, -1.08822660357843911d+10, c 3.47320283765002252d+11, -1.23696021422692745d+13, d 4.88788064793079335d+14, -2.13203339609193739d+16/ c c ln(2*pi) data con / 1.83787706640934548d+00/ c c***first executable statement dgamln ierr=0 if (z.le.0.0d0) go to 70 if (z.gt.101.0d0) go to 10 nz = int(sngl(z)) fz = z - float(nz) if (fz.gt.0.0d0) go to 10 if (nz.gt.100) go to 10 dgamln = gln(nz) return 10 continue wdtol = d1mach(4) wdtol = dmax1(wdtol,0.5d-18) i1m = i1mach(14) rln = d1mach(5)*float(i1m) fln = dmin1(rln,20.0d0) fln = dmax1(fln,3.0d0) fln = fln - 3.0d0 zm = 1.8000d0 + 0.3875d0*fln mz = int(sngl(zm)) + 1 zmin = float(mz) zdmy = z zinc = 0.0d0 if (z.ge.zmin) go to 20 zinc = zmin - float(nz) zdmy = z + zinc 20 continue zp = 1.0d0/zdmy t1 = cf(1)*zp s = t1 if (zp.lt.wdtol) go to 40 zsq = zp*zp tst = t1*wdtol do 30 k=2,22 zp = zp*zsq trm = cf(k)*zp if (dabs(trm).lt.tst) go to 40 s = s + trm 30 continue 40 continue if (zinc.ne.0.0d0) go to 50 tlg = dlog(z) dgamln = z*(tlg-1.0d0) + 0.5d0*(con-tlg) + s return 50 continue zp = 1.0d0 nz = int(sngl(zinc)) do 60 i=1,nz zp = zp*(z+float(i-1)) 60 continue tlg = dlog(zdmy) dgamln = zdmy*(tlg-1.0d0) - dlog(zp) + 0.5d0*(con-tlg) + s return c c 70 continue dgamln = d1mach(7) ierr=1 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine xerror(mess,nmess,l1,l2) c c this is a dummy xerror routine to print error messages with nmess c characters. l1 and l2 are dummy parameters to make this call c compatible with the slatec xerror routine. this is a fortran 77 c routine. c character*(*) mess nn=nmess/70 nr=nmess-70*nn if(nr.ne.0) nn=nn+1 k=1 print 900 900 format(/) do 10 i=1,nn kmin=min0(k+69,nmess) print *, mess(k:kmin) k=k+70 10 continue print 900 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- double precision function zabs2(zr, zi) c refer to zbesh,zbesi,zbesj,zbesk,zbesy,zairy,zbiry c zabs2 computes the absolute value or magnitude of a double c precision complex variable cmplx(zr,zi) c double precision zr, zi, u, v, q, s u = dabs(zr) v = dabs(zi) s = u + v c----------------------------------------------------------------------- c s*1.0d0 makes an unnormalized underflow on cdc machines into a c true floating zero c----------------------------------------------------------------------- s = s*1.0d+0 if (s.eq.0.0d+0) go to 20 if (u.gt.v) go to 10 q = u/v zabs2 = v*dsqrt(1.d+0+q*q) return 10 q = v/u zabs2 = u*dsqrt(1.d+0+q*q) return 20 zabs2 = 0.0d+0 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zacai(zr, zi, fnu, kode, mr, n, yr, yi, nz, rl, tol, * elim, alim) c Refer to zairy c c zacai applies the analytic continuation formula c c k(fnu,zn*exp(mp))=k(fnu,zn)*exp(-mp*fnu) - mp*i(fnu,zn) c mp=pi*mr*cmplx(0.0,1.0) c c to continue the k function from the right half to the left c half z plane for use with zairy where fnu=1/3 or 2/3 and n=1. c zacai is the same as zacon with the parts for larger orders and c recurrence removed. a recursive call to zacon can result if zacon c is called from zairy. c c***routines called zasyi,zbknu,zmlri,zseri,zs1s2,d1mach,zabs2 c complex csgn,cspn,c1,c2,y,z,zn,cy double precision alim, arg, ascle, az, csgnr, csgni, cspnr, * cspni, c1r, c1i, c2r, c2i, cyr, cyi, dfnu, elim, fmr, fnu, pi, * rl, sgn, tol, yy, yr, yi, zr, zi, znr, zni, d1mach, zabs2 integer inu, iuf, kode, mr, n, nn, nw, nz dimension yr(n), yi(n), cyr(2), cyi(2) data pi / 3.14159265358979324d0 / nz = 0 znr = -zr zni = -zi az = zabs2(zr,zi) nn = n dfnu = fnu + dble(float(n-1)) if (az.le.2.0d0) go to 10 if (az*az*0.25d0.gt.dfnu+1.0d0) go to 20 10 continue c----------------------------------------------------------------------- c power series for the i function c----------------------------------------------------------------------- call zseri(znr, zni, fnu, kode, nn, yr, yi, nw, tol, elim, alim) go to 40 20 continue if (az.lt.rl) go to 30 c----------------------------------------------------------------------- c asymptotic expansion for large z for the i function c----------------------------------------------------------------------- call zasyi(znr, zni, fnu, kode, nn, yr, yi, nw, rl, tol, elim, * alim) if (nw.lt.0) go to 80 go to 40 30 continue c----------------------------------------------------------------------- c miller algorithm normalized by the series for the i function c----------------------------------------------------------------------- call zmlri(znr, zni, fnu, kode, nn, yr, yi, nw, tol) if(nw.lt.0) go to 80 40 continue c----------------------------------------------------------------------- c analytic continuation to the left half plane for the k function c----------------------------------------------------------------------- call zbknu(znr, zni, fnu, kode, 1, cyr, cyi, nw, tol, elim, alim) if (nw.ne.0) go to 80 fmr = dble(float(mr)) sgn = -dsign(pi,fmr) csgnr = 0.0d0 csgni = sgn if (kode.eq.1) go to 50 yy = -zni csgnr = -csgni*dsin(yy) csgni = csgni*dcos(yy) 50 continue c----------------------------------------------------------------------- c calculate cspn=exp(fnu*pi*i) to minimize losses of significance c when fnu is large c----------------------------------------------------------------------- inu = int(sngl(fnu)) arg = (fnu-dble(float(inu)))*sgn cspnr = dcos(arg) cspni = dsin(arg) if (mod(inu,2).eq.0) go to 60 cspnr = -cspnr cspni = -cspni 60 continue c1r = cyr(1) c1i = cyi(1) c2r = yr(1) c2i = yi(1) if (kode.eq.1) go to 70 iuf = 0 ascle = 1.0d+3*d1mach(1)/tol call zs1s2(znr, zni, c1r, c1i, c2r, c2i, nw, ascle, alim, iuf) nz = nz + nw 70 continue yr(1) = cspnr*c1r - cspni*c1i + csgnr*c2r - csgni*c2i yi(1) = cspnr*c1i + cspni*c1r + csgnr*c2i + csgni*c2r return 80 continue nz = -1 if(nw.eq.(-2)) nz=-2 return end c----------------------------------------------------------------------- subroutine zacon(zr, zi, fnu, kode, mr, n, yr, yi, nz, rl, fnul, * tol, elim, alim) c Refer to zbesk,zbesh c c zacon applies the analytic continuation formula c c k(fnu,zn*exp(mp))=k(fnu,zn)*exp(-mp*fnu) - mp*i(fnu,zn) c mp=pi*mr*cmplx(0.0,1.0) c c to continue the k function from the right half to the left c half z plane c c***routines called zbinu,zbknu,zs1s2,d1mach,zabs2,zmlt c c complex ck,cone,cscl,cscr,csgn,cspn,cy,czero,c1,c2,rz,sc1,sc2,st, c *s1,s2,y,z,zn double precision alim, arg, ascle, as2, azn, bry, bscle, cki, * ckr, coner, cpn, cscl, cscr, csgni, csgnr, cspni, cspnr, * csr, csrr, cssr, cyi, cyr, c1i, c1m, c1r, c2i, c2r, elim, fmr, * fn, fnu, fnul, pi, pti, ptr, razn, rl, rzi, rzr, sc1i, sc1r, * sc2i, sc2r, sgn, spn, sti, str, s1i, s1r, s2i, s2r, tol, yi, yr, * yy, zeror, zi, zni, znr, zr, d1mach, zabs2 integer i, inu, iuf, kflag, kode, mr, n, nn, nw, nz dimension yr(n), yi(n), cyr(2), cyi(2), cssr(3), csrr(3), bry(3) data pi / 3.14159265358979324d0 / data zeror,coner / 0.0d0,1.0d0 / nz = 0 znr = -zr zni = -zi nn = n call zbinu(znr, zni, fnu, kode, nn, yr, yi, nw, rl, fnul, tol, * elim, alim) if (nw.lt.0) go to 90 c----------------------------------------------------------------------- c analytic continuation to the left half plane for the k function c----------------------------------------------------------------------- nn = min0(2,n) call zbknu(znr, zni, fnu, kode, nn, cyr, cyi, nw, tol, elim, alim) if (nw.ne.0) go to 90 s1r = cyr(1) s1i = cyi(1) fmr = dble(float(mr)) sgn = -dsign(pi,fmr) csgnr = zeror csgni = sgn if (kode.eq.1) go to 10 yy = -zni cpn = dcos(yy) spn = dsin(yy) call zmlt(csgnr, csgni, cpn, spn, csgnr, csgni) 10 continue c----------------------------------------------------------------------- c calculate cspn=exp(fnu*pi*i) to minimize losses of significance c when fnu is large c----------------------------------------------------------------------- inu = int(sngl(fnu)) arg = (fnu-dble(float(inu)))*sgn cpn = dcos(arg) spn = dsin(arg) cspnr = cpn cspni = spn if (mod(inu,2).eq.0) go to 20 cspnr = -cspnr cspni = -cspni 20 continue iuf = 0 c1r = s1r c1i = s1i c2r = yr(1) c2i = yi(1) ascle = 1.0d+3*d1mach(1)/tol if (kode.eq.1) go to 30 call zs1s2(znr, zni, c1r, c1i, c2r, c2i, nw, ascle, alim, iuf) nz = nz + nw sc1r = c1r sc1i = c1i 30 continue call zmlt(cspnr, cspni, c1r, c1i, str, sti) call zmlt(csgnr, csgni, c2r, c2i, ptr, pti) yr(1) = str + ptr yi(1) = sti + pti if (n.eq.1) return cspnr = -cspnr cspni = -cspni s2r = cyr(2) s2i = cyi(2) c1r = s2r c1i = s2i c2r = yr(2) c2i = yi(2) if (kode.eq.1) go to 40 call zs1s2(znr, zni, c1r, c1i, c2r, c2i, nw, ascle, alim, iuf) nz = nz + nw sc2r = c1r sc2i = c1i 40 continue call zmlt(cspnr, cspni, c1r, c1i, str, sti) call zmlt(csgnr, csgni, c2r, c2i, ptr, pti) yr(2) = str + ptr yi(2) = sti + pti if (n.eq.2) return cspnr = -cspnr cspni = -cspni azn = zabs2(znr,zni) razn = 1.0d0/azn str = znr*razn sti = -zni*razn rzr = (str+str)*razn rzi = (sti+sti)*razn fn = fnu + 1.0d0 ckr = fn*rzr cki = fn*rzi c----------------------------------------------------------------------- c scale near exponent extremes during recurrence on k functions c----------------------------------------------------------------------- cscl = 1.0d0/tol cscr = tol cssr(1) = cscl cssr(2) = coner cssr(3) = cscr csrr(1) = cscr csrr(2) = coner csrr(3) = cscl bry(1) = ascle bry(2) = 1.0d0/ascle bry(3) = d1mach(2) as2 = zabs2(s2r,s2i) kflag = 2 if (as2.gt.bry(1)) go to 50 kflag = 1 go to 60 50 continue if (as2.lt.bry(2)) go to 60 kflag = 3 60 continue bscle = bry(kflag) s1r = s1r*cssr(kflag) s1i = s1i*cssr(kflag) s2r = s2r*cssr(kflag) s2i = s2i*cssr(kflag) csr = csrr(kflag) do 80 i=3,n str = s2r sti = s2i s2r = ckr*str - cki*sti + s1r s2i = ckr*sti + cki*str + s1i s1r = str s1i = sti c1r = s2r*csr c1i = s2i*csr str = c1r sti = c1i c2r = yr(i) c2i = yi(i) if (kode.eq.1) go to 70 if (iuf.lt.0) go to 70 call zs1s2(znr, zni, c1r, c1i, c2r, c2i, nw, ascle, alim, iuf) nz = nz + nw sc1r = sc2r sc1i = sc2i sc2r = c1r sc2i = c1i if (iuf.ne.3) go to 70 iuf = -4 s1r = sc1r*cssr(kflag) s1i = sc1i*cssr(kflag) s2r = sc2r*cssr(kflag) s2i = sc2i*cssr(kflag) str = sc2r sti = sc2i 70 continue ptr = cspnr*c1r - cspni*c1i pti = cspnr*c1i + cspni*c1r yr(i) = ptr + csgnr*c2r - csgni*c2i yi(i) = pti + csgnr*c2i + csgni*c2r ckr = ckr + rzr cki = cki + rzi cspnr = -cspnr cspni = -cspni if (kflag.ge.3) go to 80 ptr = dabs(c1r) pti = dabs(c1i) c1m = dmax1(ptr,pti) if (c1m.le.bscle) go to 80 kflag = kflag + 1 bscle = bry(kflag) s1r = s1r*csr s1i = s1i*csr s2r = str s2i = sti s1r = s1r*cssr(kflag) s1i = s1i*cssr(kflag) s2r = s2r*cssr(kflag) s2i = s2i*cssr(kflag) csr = csrr(kflag) 80 continue return 90 continue nz = -1 if(nw.eq.(-2)) nz=-2 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zdiv(ar, ai, br, bi, cr, ci) c Refer to zbesh,zbesi,zbesj,zbesk,zbesy,zairy,zbiry c c double precision complex divide c=a/b. c c***routines called zabs2 c double precision ar, ai, br, bi, cr, ci, bm, ca, cb, cc, cd double precision zabs2 bm = 1.0d0/zabs2(br,bi) cc = br*bm cd = bi*bm ca = (ar*cc+ai*cd)*bm cb = (ai*cc-ar*cd)*bm cr = ca ci = cb return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zexp(ar, ai, br, bi) c Refer to zbesh,zbesi,zbesj,zbesk,zbesy,zairy,zbiry c c double precision complex exponential function b=exp(a) c double precision ar, ai, br, bi, zm, ca, cb zm = dexp(ar) ca = zm*dcos(ai) cb = zm*dsin(ai) br = ca bi = cb return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zkscl(zrr,zri,fnu,n,yr,yi,nz,rzr,rzi,ascle,tol,elim) c geuz for g77 EXTERNAL zlog c refer to zbesk c c set k functions to zero on underflow, continue recurrence c on scaled functions until two members come on scale, then c return with min(nz+2,n) values scaled by 1/tol. c c routines called zuchk,zabs2,zlog c c complex ck,cs,cy,czero,rz,s1,s2,y,zr,zd,celm double precision acs, as, ascle, cki, ckr, csi, csr, cyi, * cyr, elim, fn, fnu, rzi, rzr, str, s1i, s1r, s2i, * s2r, tol, yi, yr, zeroi, zeror, zri, zrr, zabs2, * zdr, zdi, celmr, elm, helim, alas integer i, ic, idum, kk, n, nn, nw, nz dimension yr(n), yi(n), cyr(2), cyi(2) data zeror,zeroi / 0.0d0 , 0.0d0 / c nz = 0 ic = 0 nn = min0(2,n) do 10 i=1,nn s1r = yr(i) s1i = yi(i) cyr(i) = s1r cyi(i) = s1i as = zabs2(s1r,s1i) acs = -zrr + dlog(as) nz = nz + 1 yr(i) = zeror yi(i) = zeroi if (acs.lt.(-elim)) go to 10 call zlog(s1r, s1i, csr, csi, idum) csr = csr - zrr csi = csi - zri str = dexp(csr)/tol csr = str*dcos(csi) csi = str*dsin(csi) call zuchk(csr, csi, nw, ascle, tol) if (nw.ne.0) go to 10 yr(i) = csr yi(i) = csi ic = i nz = nz - 1 10 continue if (n.eq.1) return if (ic.gt.1) go to 20 yr(1) = zeror yi(1) = zeroi nz = 2 20 continue if (n.eq.2) return if (nz.eq.0) return fn = fnu + 1.0d0 ckr = fn*rzr cki = fn*rzi s1r = cyr(1) s1i = cyi(1) s2r = cyr(2) s2i = cyi(2) helim = 0.5d0*elim elm = dexp(-elim) celmr = elm zdr = zrr zdi = zri c c find two consecutive y values on scale. scale recurrence if c s2 gets larger than exp(elim/2) c do 30 i=3,n kk = i csr = s2r csi = s2i s2r = ckr*csr - cki*csi + s1r s2i = cki*csr + ckr*csi + s1i s1r = csr s1i = csi ckr = ckr + rzr cki = cki + rzi as = zabs2(s2r,s2i) alas = dlog(as) acs = -zdr + alas nz = nz + 1 yr(i) = zeror yi(i) = zeroi if (acs.lt.(-elim)) go to 25 call zlog(s2r, s2i, csr, csi, idum) csr = csr - zdr csi = csi - zdi str = dexp(csr)/tol csr = str*dcos(csi) csi = str*dsin(csi) call zuchk(csr, csi, nw, ascle, tol) if (nw.ne.0) go to 25 yr(i) = csr yi(i) = csi nz = nz - 1 if (ic.eq.kk-1) go to 40 ic = kk go to 30 25 continue if(alas.lt.helim) go to 30 zdr = zdr - elim s1r = s1r*celmr s1i = s1i*celmr s2r = s2r*celmr s2i = s2i*celmr 30 continue nz = n if(ic.eq.n) nz=n-1 go to 45 40 continue nz = kk - 2 45 continue do 50 i=1,nz yr(i) = zeror yi(i) = zeroi 50 continue return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zlog(ar, ai, br, bi, ierr) c Refer to zbesh,zbesi,zbesj,zbesk,zbesy,zairy,zbiry c c double precision complex logarithm b=clog(a) c ierr=0,normal return ierr=1, z=cmplx(0.0,0.0) c***routines called zabs2 double precision ar, ai, br, bi, zm, dtheta, dpi, dhpi double precision zabs2 data dpi , dhpi / 3.141592653589793238462643383d+0, 1 1.570796326794896619231321696d+0/ c ierr=0 if (ar.eq.0.0d+0) go to 10 if (ai.eq.0.0d+0) go to 20 dtheta = datan(ai/ar) if (dtheta.le.0.0d+0) go to 40 if (ar.lt.0.0d+0) dtheta = dtheta - dpi go to 50 10 if (ai.eq.0.0d+0) go to 60 bi = dhpi br = dlog(dabs(ai)) if (ai.lt.0.0d+0) bi = -bi return 20 if (ar.gt.0.0d+0) go to 30 br = dlog(dabs(ar)) bi = dpi return 30 br = dlog(ar) bi = 0.0d+0 return 40 if (ar.lt.0.0d+0) dtheta = dtheta + dpi 50 zm = zabs2(ar,ai) br = dlog(zm) bi = dtheta return 60 continue ierr=1 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zmlt(ar, ai, br, bi, cr, ci) c Refer to zbesh,zbesi,zbesj,zbesk,zbesy,zairy,zbiry c c double precision complex multiply, c=a*b. c double precision ar, ai, br, bi, cr, ci, ca, cb ca = ar*br - ai*bi cb = ar*bi + ai*br cr = ca ci = cb return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zrati(zr, zi, fnu, n, cyr, cyi, tol) c Refer to zbesi,zbesk,zbesh c c zrati computes ratios of i bessel functions by backward c recurrence. the starting index is determined by forward c recurrence as described in j. res. of nat. bur. of standards-b, c mathematical sciences, vol 77b, p111-114, september, 1973, c bessel functions i and j of complex argument and integer order, c by d. j. sookne. c c***routines called zabs2,zdiv c complex z,cy(1),cone,czero,p1,p2,t1,rz,pt,cdfnu double precision ak, amagz, ap1, ap2, arg, az, cdfnui, cdfnur, * conei, coner, cyi, cyr, czeroi, czeror, dfnu, fdnu, flam, fnu, * fnup, pti, ptr, p1i, p1r, p2i, p2r, rak, rap1, rho, rt2, rzi, * rzr, test, test1, tol, tti, ttr, t1i, t1r, zi, zr, zabs2 integer i, id, idnu, inu, itime, k, kk, magz, n dimension cyr(n), cyi(n) data czeror,czeroi,coner,conei,rt2/ 1 0.0d0, 0.0d0, 1.0d0, 0.0d0, 1.41421356237309505d0 / az = zabs2(zr,zi) inu = int(sngl(fnu)) idnu = inu + n - 1 magz = int(sngl(az)) amagz = dble(float(magz+1)) fdnu = dble(float(idnu)) fnup = dmax1(amagz,fdnu) id = idnu - magz - 1 itime = 1 k = 1 ptr = 1.0d0/az rzr = ptr*(zr+zr)*ptr rzi = -ptr*(zi+zi)*ptr t1r = rzr*fnup t1i = rzi*fnup p2r = -t1r p2i = -t1i p1r = coner p1i = conei t1r = t1r + rzr t1i = t1i + rzi if (id.gt.0) id = 0 ap2 = zabs2(p2r,p2i) ap1 = zabs2(p1r,p1i) c----------------------------------------------------------------------- c the overflow test on k(fnu+i-1,z) before the call to cbknu c guarantees that p2 is on scale. scale test1 and all subsequent c p2 values by ap1 to ensure that an overflow does not occur c prematurely. c----------------------------------------------------------------------- arg = (ap2+ap2)/(ap1*tol) test1 = dsqrt(arg) test = test1 rap1 = 1.0d0/ap1 p1r = p1r*rap1 p1i = p1i*rap1 p2r = p2r*rap1 p2i = p2i*rap1 ap2 = ap2*rap1 10 continue k = k + 1 ap1 = ap2 ptr = p2r pti = p2i p2r = p1r - (t1r*ptr-t1i*pti) p2i = p1i - (t1r*pti+t1i*ptr) p1r = ptr p1i = pti t1r = t1r + rzr t1i = t1i + rzi ap2 = zabs2(p2r,p2i) if (ap1.le.test) go to 10 if (itime.eq.2) go to 20 ak = zabs2(t1r,t1i)*0.5d0 flam = ak + dsqrt(ak*ak-1.0d0) rho = dmin1(ap2/ap1,flam) test = test1*dsqrt(rho/(rho*rho-1.0d0)) itime = 2 go to 10 20 continue kk = k + 1 - id ak = dble(float(kk)) t1r = ak t1i = czeroi dfnu = fnu + dble(float(n-1)) p1r = 1.0d0/ap2 p1i = czeroi p2r = czeror p2i = czeroi do 30 i=1,kk ptr = p1r pti = p1i rap1 = dfnu + t1r ttr = rzr*rap1 tti = rzi*rap1 p1r = (ptr*ttr-pti*tti) + p2r p1i = (ptr*tti+pti*ttr) + p2i p2r = ptr p2i = pti t1r = t1r - coner 30 continue if (p1r.ne.czeror .or. p1i.ne.czeroi) go to 40 p1r = tol p1i = tol 40 continue call zdiv(p2r, p2i, p1r, p1i, cyr(n), cyi(n)) if (n.eq.1) return k = n - 1 ak = dble(float(k)) t1r = ak t1i = czeroi cdfnur = fnu*rzr cdfnui = fnu*rzi do 60 i=2,n ptr = cdfnur + (t1r*rzr-t1i*rzi) + cyr(k+1) pti = cdfnui + (t1r*rzi+t1i*rzr) + cyi(k+1) ak = zabs2(ptr,pti) if (ak.ne.czeror) go to 50 ptr = tol pti = tol ak = tol*rt2 50 continue rak = coner/ak cyr(k) = rak*ptr*rak cyi(k) = -rak*pti*rak t1r = t1r - coner k = k - 1 60 continue return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zs1s2(zrr, zri, s1r, s1i, s2r, s2i, nz, ascle, alim, * iuf) c geuz for g77 EXTERNAL zexp EXTERNAL zlog c Refer to zbesk,zairy c c zs1s2 tests for a possible underflow resulting from the c addition of the i and k functions in the analytic con- c tinuation formula where s1=k function and s2=i function. c on kode=1 the i and k functions are different orders of c magnitude, but for kode=2 they can be of the same order c of magnitude and the maximum must be at least one c precision above the underflow limit. c c***routines called zabs2,zexp,zlog c complex czero,c1,s1,s1d,s2,zr double precision aa, alim, aln, ascle, as1, as2, c1i, c1r, s1di, * s1dr, s1i, s1r, s2i, s2r, zeroi, zeror, zri, zrr, zabs2 integer iuf, idum, nz data zeror,zeroi / 0.0d0 , 0.0d0 / nz = 0 as1 = zabs2(s1r,s1i) as2 = zabs2(s2r,s2i) if (s1r.eq.0.0d0 .and. s1i.eq.0.0d0) go to 10 if (as1.eq.0.0d0) go to 10 aln = -zrr - zrr + dlog(as1) s1dr = s1r s1di = s1i s1r = zeror s1i = zeroi as1 = zeror if (aln.lt.(-alim)) go to 10 call zlog(s1dr, s1di, c1r, c1i, idum) c1r = c1r - zrr - zrr c1i = c1i - zri - zri call zexp(c1r, c1i, s1r, s1i) as1 = zabs2(s1r,s1i) iuf = iuf + 1 10 continue aa = dmax1(as1,as2) if (aa.gt.ascle) return s1r = zeror s1i = zeroi s2r = zeror s2i = zeroi nz = 1 iuf = 0 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zshch(zr, zi, cshr, cshi, cchr, cchi) c Refer to zbesk,zbesh c c zshch computes the complex hyperbolic functions csh=sinh(x+i*y) c and cch=cosh(x+i*y), where i**2=-1. c double precision cchi, cchr, ch, cn, cshi, cshr, sh, sn, zi, zr, * dcosh, dsinh sh = dsinh(zr) ch = dcosh(zr) sn = dsin(zi) cn = dcos(zi) cshr = sh*cn cshi = ch*sn cchr = ch*cn cchi = sh*sn return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zsqrt(ar, ai, br, bi) c Refer to zbesh,zbesi,zbesj,zbesk,zbesy,zairy,zbiry c c double precision complex square root, b=csqrt(a) c c***routines called zabs2 c double precision ar, ai, br, bi, zm, dtheta, dpi, drt double precision zabs2 data drt , dpi / 7.071067811865475244008443621d-1, 1 3.141592653589793238462643383d+0/ zm = zabs2(ar,ai) zm = dsqrt(zm) if (ar.eq.0.0d+0) go to 10 if (ai.eq.0.0d+0) go to 20 dtheta = datan(ai/ar) if (dtheta.le.0.0d+0) go to 40 if (ar.lt.0.0d+0) dtheta = dtheta - dpi go to 50 10 if (ai.gt.0.0d+0) go to 60 if (ai.lt.0.0d+0) go to 70 br = 0.0d+0 bi = 0.0d+0 return 20 if (ar.gt.0.0d+0) go to 30 br = 0.0d+0 bi = dsqrt(dabs(ar)) return 30 br = dsqrt(ar) bi = 0.0d+0 return 40 if (ar.lt.0.0d+0) dtheta = dtheta + dpi 50 dtheta = dtheta*0.5d+0 br = zm*dcos(dtheta) bi = zm*dsin(dtheta) return 60 br = zm*drt bi = zm*drt return 70 br = zm*drt bi = -zm*drt return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zuchk(yr, yi, nz, ascle, tol) c refer to zseri,zuoik,zunk1,zunk2,zuni1,zuni2,zkscl c c y enters as a scaled quantity whose magnitude is greater than c exp(-alim)=ascle=1.0e+3*d1mach(1)/tol. the test is made to see c if the magnitude of the real or imaginary part would underflow c when y is scaled (by tol) to its proper value. y is accepted c if the underflow is at least one precision below the magnitude c of the largest component; otherwise the phase angle does not have c absolute accuracy and an underflow is assumed. c c complex y double precision ascle, ss, st, tol, wr, wi, yr, yi integer nz nz = 0 wr = dabs(yr) wi = dabs(yi) st = dmin1(wr,wi) if (st.gt.ascle) return ss = dmax1(wr,wi) st = st/tol if (ss.lt.st) nz = 1 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zunhj(zr, zi, fnu, ipmtr, tol, phir, phii, argr, argi, * zeta1r, zeta1i, zeta2r, zeta2i, asumr, asumi, bsumr, bsumi) c geuz for g77 EXTERNAL zsqrt EXTERNAL zlog c refer to zbesi,zbesk c c zunhj computes parameters for bessel functions c(fnu,z) = c j(fnu,z), y(fnu,z) or h(i,fnu,z) i=1,2 for large orders fnu c by means of the uniform asymptotic expansion c c c(fnu,z)=c1*phi*( asum*airy(arg) + c2*bsum*dairy(arg) ) c c for proper choices of c1, c2, airy and dairy where airy is c an airy function and dairy is its derivative. c c (2/3)*fnu*zeta**1.5 = zeta1-zeta2, c c zeta1=0.5*fnu*clog((1+w)/(1-w)), zeta2=fnu*w for scaling c purposes in airy functions from cairy or cbiry. c c mconj=sign of aimag(z), but is ambiguous when z is real and c must be specified. ipmtr=0 returns all parameters. ipmtr= c 1 computes all except asum and bsum. c c***routines called zabs2,zdiv,zlog,zsqrt,d1mach c complex arg,asum,bsum,cfnu,cone,cr,czero,dr,p,phi,przth,ptfn, c *rfn13,rtzta,rzth,suma,sumb,tfn,t2,up,w,w2,z,za,zb,zc,zeta,zeta1, c *zeta2,zth double precision alfa, ang, ap, ar, argi, argr, asumi, asumr, * atol, aw2, azth, beta, br, bsumi, bsumr, btol, c, conei, coner, * cri, crr, dri, drr, ex1, ex2, fnu, fn13, fn23, gama, gpi, hpi, * phii, phir, pi, pp, pr, przthi, przthr, ptfni, ptfnr, raw, raw2, * razth, rfnu, rfnu2, rfn13, rtzti, rtztr, rzthi, rzthr, sti, str, * sumai, sumar, sumbi, sumbr, test, tfni, tfnr, thpi, tol, tzai, * tzar, t2i, t2r, upi, upr, wi, wr, w2i, w2r, zai, zar, zbi, zbr, * zci, zcr, zeroi, zeror, zetai, zetar, zeta1i, zeta1r, zeta2i, * zeta2r, zi, zr, zthi, zthr, zabs2, ac, d1mach integer ias, ibs, ipmtr, is, j, jr, ju, k, kmax, kp1, ks, l, lr, * lrp1, l1, l2, m, idum dimension ar(14), br(14), c(105), alfa(180), beta(210), gama(30), * ap(30), pr(30), pi(30), upr(14), upi(14), crr(14), cri(14), * drr(14), dri(14) data ar(1), ar(2), ar(3), ar(4), ar(5), ar(6), ar(7), ar(8), 1 ar(9), ar(10), ar(11), ar(12), ar(13), ar(14)/ 2 1.00000000000000000d+00, 1.04166666666666667d-01, 3 8.35503472222222222d-02, 1.28226574556327160d-01, 4 2.91849026464140464d-01, 8.81627267443757652d-01, 5 3.32140828186276754d+00, 1.49957629868625547d+01, 6 7.89230130115865181d+01, 4.74451538868264323d+02, 7 3.20749009089066193d+03, 2.40865496408740049d+04, 8 1.98923119169509794d+05, 1.79190200777534383d+06/ data br(1), br(2), br(3), br(4), br(5), br(6), br(7), br(8), 1 br(9), br(10), br(11), br(12), br(13), br(14)/ 2 1.00000000000000000d+00, -1.45833333333333333d-01, 3 -9.87413194444444444d-02, -1.43312053915895062d-01, 4 -3.17227202678413548d-01, -9.42429147957120249d-01, 5 -3.51120304082635426d+00, -1.57272636203680451d+01, 6 -8.22814390971859444d+01, -4.92355370523670524d+02, 7 -3.31621856854797251d+03, -2.48276742452085896d+04, 8 -2.04526587315129788d+05, -1.83844491706820990d+06/ data c(1), c(2), c(3), c(4), c(5), c(6), c(7), c(8), c(9), c(10), 1 c(11), c(12), c(13), c(14), c(15), c(16), c(17), c(18), 2 c(19), c(20), c(21), c(22), c(23), c(24)/ 3 1.00000000000000000d+00, -2.08333333333333333d-01, 4 1.25000000000000000d-01, 3.34201388888888889d-01, 5 -4.01041666666666667d-01, 7.03125000000000000d-02, 6 -1.02581259645061728d+00, 1.84646267361111111d+00, 7 -8.91210937500000000d-01, 7.32421875000000000d-02, 8 4.66958442342624743d+00, -1.12070026162229938d+01, 9 8.78912353515625000d+00, -2.36408691406250000d+00, a 1.12152099609375000d-01, -2.82120725582002449d+01, b 8.46362176746007346d+01, -9.18182415432400174d+01, c 4.25349987453884549d+01, -7.36879435947963170d+00, d 2.27108001708984375d-01, 2.12570130039217123d+02, e -7.65252468141181642d+02, 1.05999045252799988d+03/ data c(25), c(26), c(27), c(28), c(29), c(30), c(31), c(32), 1 c(33), c(34), c(35), c(36), c(37), c(38), c(39), c(40), 2 c(41), c(42), c(43), c(44), c(45), c(46), c(47), c(48)/ 3 -6.99579627376132541d+02, 2.18190511744211590d+02, 4 -2.64914304869515555d+01, 5.72501420974731445d-01, 5 -1.91945766231840700d+03, 8.06172218173730938d+03, 6 -1.35865500064341374d+04, 1.16553933368645332d+04, 7 -5.30564697861340311d+03, 1.20090291321635246d+03, 8 -1.08090919788394656d+02, 1.72772750258445740d+00, 9 2.02042913309661486d+04, -9.69805983886375135d+04, a 1.92547001232531532d+05, -2.03400177280415534d+05, b 1.22200464983017460d+05, -4.11926549688975513d+04, c 7.10951430248936372d+03, -4.93915304773088012d+02, d 6.07404200127348304d+00, -2.42919187900551333d+05, e 1.31176361466297720d+06, -2.99801591853810675d+06/ data c(49), c(50), c(51), c(52), c(53), c(54), c(55), c(56), 1 c(57), c(58), c(59), c(60), c(61), c(62), c(63), c(64), 2 c(65), c(66), c(67), c(68), c(69), c(70), c(71), c(72)/ 3 3.76327129765640400d+06, -2.81356322658653411d+06, 4 1.26836527332162478d+06, -3.31645172484563578d+05, 5 4.52187689813627263d+04, -2.49983048181120962d+03, 6 2.43805296995560639d+01, 3.28446985307203782d+06, 7 -1.97068191184322269d+07, 5.09526024926646422d+07, 8 -7.41051482115326577d+07, 6.63445122747290267d+07, 9 -3.75671766607633513d+07, 1.32887671664218183d+07, a -2.78561812808645469d+06, 3.08186404612662398d+05, b -1.38860897537170405d+04, 1.10017140269246738d+02, c -4.93292536645099620d+07, 3.25573074185765749d+08, d -9.39462359681578403d+08, 1.55359689957058006d+09, e -1.62108055210833708d+09, 1.10684281682301447d+09/ data c(73), c(74), c(75), c(76), c(77), c(78), c(79), c(80), 1 c(81), c(82), c(83), c(84), c(85), c(86), c(87), c(88), 2 c(89), c(90), c(91), c(92), c(93), c(94), c(95), c(96)/ 3 -4.95889784275030309d+08, 1.42062907797533095d+08, 4 -2.44740627257387285d+07, 2.24376817792244943d+06, 5 -8.40054336030240853d+04, 5.51335896122020586d+02, 6 8.14789096118312115d+08, -5.86648149205184723d+09, 7 1.86882075092958249d+10, -3.46320433881587779d+10, 8 4.12801855797539740d+10, -3.30265997498007231d+10, 9 1.79542137311556001d+10, -6.56329379261928433d+09, a 1.55927986487925751d+09, -2.25105661889415278d+08, b 1.73951075539781645d+07, -5.49842327572288687d+05, c 3.03809051092238427d+03, -1.46792612476956167d+10, d 1.14498237732025810d+11, -3.99096175224466498d+11, e 8.19218669548577329d+11, -1.09837515608122331d+12/ data c(97), c(98), c(99), c(100), c(101), c(102), c(103), c(104), 1 c(105)/ 2 1.00815810686538209d+12, -6.45364869245376503d+11, 3 2.87900649906150589d+11, -8.78670721780232657d+10, 4 1.76347306068349694d+10, -2.16716498322379509d+09, 5 1.43157876718888981d+08, -3.87183344257261262d+06, 6 1.82577554742931747d+04/ data alfa(1), alfa(2), alfa(3), alfa(4), alfa(5), alfa(6), 1 alfa(7), alfa(8), alfa(9), alfa(10), alfa(11), alfa(12), 2 alfa(13), alfa(14), alfa(15), alfa(16), alfa(17), alfa(18), 3 alfa(19), alfa(20), alfa(21), alfa(22)/ 4 -4.44444444444444444d-03, -9.22077922077922078d-04, 5 -8.84892884892884893d-05, 1.65927687832449737d-04, 6 2.46691372741792910d-04, 2.65995589346254780d-04, 7 2.61824297061500945d-04, 2.48730437344655609d-04, 8 2.32721040083232098d-04, 2.16362485712365082d-04, 9 2.00738858762752355d-04, 1.86267636637545172d-04, a 1.73060775917876493d-04, 1.61091705929015752d-04, b 1.50274774160908134d-04, 1.40503497391269794d-04, c 1.31668816545922806d-04, 1.23667445598253261d-04, d 1.16405271474737902d-04, 1.09798298372713369d-04, e 1.03772410422992823d-04, 9.82626078369363448d-05/ data alfa(23), alfa(24), alfa(25), alfa(26), alfa(27), alfa(28), 1 alfa(29), alfa(30), alfa(31), alfa(32), alfa(33), alfa(34), 2 alfa(35), alfa(36), alfa(37), alfa(38), alfa(39), alfa(40), 3 alfa(41), alfa(42), alfa(43), alfa(44)/ 4 9.32120517249503256d-05, 8.85710852478711718d-05, 5 8.42963105715700223d-05, 8.03497548407791151d-05, 6 7.66981345359207388d-05, 7.33122157481777809d-05, 7 7.01662625163141333d-05, 6.72375633790160292d-05, 8 6.93735541354588974d-04, 2.32241745182921654d-04, 9 -1.41986273556691197d-05, -1.16444931672048640d-04, a -1.50803558053048762d-04, -1.55121924918096223d-04, b -1.46809756646465549d-04, -1.33815503867491367d-04, c -1.19744975684254051d-04, -1.06184319207974020d-04, d -9.37699549891194492d-05, -8.26923045588193274d-05, e -7.29374348155221211d-05, -6.44042357721016283d-05/ data alfa(45), alfa(46), alfa(47), alfa(48), alfa(49), alfa(50), 1 alfa(51), alfa(52), alfa(53), alfa(54), alfa(55), alfa(56), 2 alfa(57), alfa(58), alfa(59), alfa(60), alfa(61), alfa(62), 3 alfa(63), alfa(64), alfa(65), alfa(66)/ 4 -5.69611566009369048d-05, -5.04731044303561628d-05, 5 -4.48134868008882786d-05, -3.98688727717598864d-05, 6 -3.55400532972042498d-05, -3.17414256609022480d-05, 7 -2.83996793904174811d-05, -2.54522720634870566d-05, 8 -2.28459297164724555d-05, -2.05352753106480604d-05, 9 -1.84816217627666085d-05, -1.66519330021393806d-05, a -1.50179412980119482d-05, -1.35554031379040526d-05, b -1.22434746473858131d-05, -1.10641884811308169d-05, c -3.54211971457743841d-04, -1.56161263945159416d-04, d 3.04465503594936410d-05, 1.30198655773242693d-04, e 1.67471106699712269d-04, 1.70222587683592569d-04/ data alfa(67), alfa(68), alfa(69), alfa(70), alfa(71), alfa(72), 1 alfa(73), alfa(74), alfa(75), alfa(76), alfa(77), alfa(78), 2 alfa(79), alfa(80), alfa(81), alfa(82), alfa(83), alfa(84), 3 alfa(85), alfa(86), alfa(87), alfa(88)/ 4 1.56501427608594704d-04, 1.36339170977445120d-04, 5 1.14886692029825128d-04, 9.45869093034688111d-05, 6 7.64498419250898258d-05, 6.07570334965197354d-05, 7 4.74394299290508799d-05, 3.62757512005344297d-05, 8 2.69939714979224901d-05, 1.93210938247939253d-05, 9 1.30056674793963203d-05, 7.82620866744496661d-06, a 3.59257485819351583d-06, 1.44040049814251817d-07, b -2.65396769697939116d-06, -4.91346867098485910d-06, c -6.72739296091248287d-06, -8.17269379678657923d-06, d -9.31304715093561232d-06, -1.02011418798016441d-05, e -1.08805962510592880d-05, -1.13875481509603555d-05/ data alfa(89), alfa(90), alfa(91), alfa(92), alfa(93), alfa(94), 1 alfa(95), alfa(96), alfa(97), alfa(98), alfa(99), alfa(100), 2 alfa(101), alfa(102), alfa(103), alfa(104), alfa(105), 3 alfa(106), alfa(107), alfa(108), alfa(109), alfa(110)/ 4 -1.17519675674556414d-05, -1.19987364870944141d-05, 5 3.78194199201772914d-04, 2.02471952761816167d-04, 6 -6.37938506318862408d-05, -2.38598230603005903d-04, 7 -3.10916256027361568d-04, -3.13680115247576316d-04, 8 -2.78950273791323387d-04, -2.28564082619141374d-04, 9 -1.75245280340846749d-04, -1.25544063060690348d-04, a -8.22982872820208365d-05, -4.62860730588116458d-05, b -1.72334302366962267d-05, 5.60690482304602267d-06, c 2.31395443148286800d-05, 3.62642745856793957d-05, d 4.58006124490188752d-05, 5.24595294959114050d-05, e 5.68396208545815266d-05, 5.94349820393104052d-05/ data alfa(111), alfa(112), alfa(113), alfa(114), alfa(115), 1 alfa(116), alfa(117), alfa(118), alfa(119), alfa(120), 2 alfa(121), alfa(122), alfa(123), alfa(124), alfa(125), 3 alfa(126), alfa(127), alfa(128), alfa(129), alfa(130)/ 4 6.06478527578421742d-05, 6.08023907788436497d-05, 5 6.01577894539460388d-05, 5.89199657344698500d-05, 6 5.72515823777593053d-05, 5.52804375585852577d-05, 7 5.31063773802880170d-05, 5.08069302012325706d-05, 8 4.84418647620094842d-05, 4.60568581607475370d-05, 9 -6.91141397288294174d-04, -4.29976633058871912d-04, a 1.83067735980039018d-04, 6.60088147542014144d-04, b 8.75964969951185931d-04, 8.77335235958235514d-04, c 7.49369585378990637d-04, 5.63832329756980918d-04, d 3.68059319971443156d-04, 1.88464535514455599d-04/ data alfa(131), alfa(132), alfa(133), alfa(134), alfa(135), 1 alfa(136), alfa(137), alfa(138), alfa(139), alfa(140), 2 alfa(141), alfa(142), alfa(143), alfa(144), alfa(145), 3 alfa(146), alfa(147), alfa(148), alfa(149), alfa(150)/ 4 3.70663057664904149d-05, -8.28520220232137023d-05, 5 -1.72751952869172998d-04, -2.36314873605872983d-04, 6 -2.77966150694906658d-04, -3.02079514155456919d-04, 7 -3.12594712643820127d-04, -3.12872558758067163d-04, 8 -3.05678038466324377d-04, -2.93226470614557331d-04, 9 -2.77255655582934777d-04, -2.59103928467031709d-04, a -2.39784014396480342d-04, -2.20048260045422848d-04, b -2.00443911094971498d-04, -1.81358692210970687d-04, c -1.63057674478657464d-04, -1.45712672175205844d-04, d -1.29425421983924587d-04, -1.14245691942445952d-04/ data alfa(151), alfa(152), alfa(153), alfa(154), alfa(155), 1 alfa(156), alfa(157), alfa(158), alfa(159), alfa(160), 2 alfa(161), alfa(162), alfa(163), alfa(164), alfa(165), 3 alfa(166), alfa(167), alfa(168), alfa(169), alfa(170)/ 4 1.92821964248775885d-03, 1.35592576302022234d-03, 5 -7.17858090421302995d-04, -2.58084802575270346d-03, 6 -3.49271130826168475d-03, -3.46986299340960628d-03, 7 -2.82285233351310182d-03, -1.88103076404891354d-03, 8 -8.89531718383947600d-04, 3.87912102631035228d-06, 9 7.28688540119691412d-04, 1.26566373053457758d-03, a 1.62518158372674427d-03, 1.83203153216373172d-03, b 1.91588388990527909d-03, 1.90588846755546138d-03, c 1.82798982421825727d-03, 1.70389506421121530d-03, d 1.55097127171097686d-03, 1.38261421852276159d-03/ data alfa(171), alfa(172), alfa(173), alfa(174), alfa(175), 1 alfa(176), alfa(177), alfa(178), alfa(179), alfa(180)/ 2 1.20881424230064774d-03, 1.03676532638344962d-03, 3 8.71437918068619115d-04, 7.16080155297701002d-04, 4 5.72637002558129372d-04, 4.42089819465802277d-04, 5 3.24724948503090564d-04, 2.20342042730246599d-04, 6 1.28412898401353882d-04, 4.82005924552095464d-05/ data beta(1), beta(2), beta(3), beta(4), beta(5), beta(6), 1 beta(7), beta(8), beta(9), beta(10), beta(11), beta(12), 2 beta(13), beta(14), beta(15), beta(16), beta(17), beta(18), 3 beta(19), beta(20), beta(21), beta(22)/ 4 1.79988721413553309d-02, 5.59964911064388073d-03, 5 2.88501402231132779d-03, 1.80096606761053941d-03, 6 1.24753110589199202d-03, 9.22878876572938311d-04, 7 7.14430421727287357d-04, 5.71787281789704872d-04, 8 4.69431007606481533d-04, 3.93232835462916638d-04, 9 3.34818889318297664d-04, 2.88952148495751517d-04, a 2.52211615549573284d-04, 2.22280580798883327d-04, b 1.97541838033062524d-04, 1.76836855019718004d-04, c 1.59316899661821081d-04, 1.44347930197333986d-04, d 1.31448068119965379d-04, 1.20245444949302884d-04, e 1.10449144504599392d-04, 1.01828770740567258d-04/ data beta(23), beta(24), beta(25), beta(26), beta(27), beta(28), 1 beta(29), beta(30), beta(31), beta(32), beta(33), beta(34), 2 beta(35), beta(36), beta(37), beta(38), beta(39), beta(40), 3 beta(41), beta(42), beta(43), beta(44)/ 4 9.41998224204237509d-05, 8.74130545753834437d-05, 5 8.13466262162801467d-05, 7.59002269646219339d-05, 6 7.09906300634153481d-05, 6.65482874842468183d-05, 7 6.25146958969275078d-05, 5.88403394426251749d-05, 8 -1.49282953213429172d-03, -8.78204709546389328d-04, 9 -5.02916549572034614d-04, -2.94822138512746025d-04, a -1.75463996970782828d-04, -1.04008550460816434d-04, b -5.96141953046457895d-05, -3.12038929076098340d-05, c -1.26089735980230047d-05, -2.42892608575730389d-07, d 8.05996165414273571d-06, 1.36507009262147391d-05, e 1.73964125472926261d-05, 1.98672978842133780d-05/ data beta(45), beta(46), beta(47), beta(48), beta(49), beta(50), 1 beta(51), beta(52), beta(53), beta(54), beta(55), beta(56), 2 beta(57), beta(58), beta(59), beta(60), beta(61), beta(62), 3 beta(63), beta(64), beta(65), beta(66)/ 4 2.14463263790822639d-05, 2.23954659232456514d-05, 5 2.28967783814712629d-05, 2.30785389811177817d-05, 6 2.30321976080909144d-05, 2.28236073720348722d-05, 7 2.25005881105292418d-05, 2.20981015361991429d-05, 8 2.16418427448103905d-05, 2.11507649256220843d-05, 9 2.06388749782170737d-05, 2.01165241997081666d-05, a 1.95913450141179244d-05, 1.90689367910436740d-05, b 1.85533719641636667d-05, 1.80475722259674218d-05, c 5.52213076721292790d-04, 4.47932581552384646d-04, d 2.79520653992020589d-04, 1.52468156198446602d-04, e 6.93271105657043598d-05, 1.76258683069991397d-05/ data beta(67), beta(68), beta(69), beta(70), beta(71), beta(72), 1 beta(73), beta(74), beta(75), beta(76), beta(77), beta(78), 2 beta(79), beta(80), beta(81), beta(82), beta(83), beta(84), 3 beta(85), beta(86), beta(87), beta(88)/ 4 -1.35744996343269136d-05, -3.17972413350427135d-05, 5 -4.18861861696693365d-05, -4.69004889379141029d-05, 6 -4.87665447413787352d-05, -4.87010031186735069d-05, 7 -4.74755620890086638d-05, -4.55813058138628452d-05, 8 -4.33309644511266036d-05, -4.09230193157750364d-05, 9 -3.84822638603221274d-05, -3.60857167535410501d-05, a -3.37793306123367417d-05, -3.15888560772109621d-05, b -2.95269561750807315d-05, -2.75978914828335759d-05, c -2.58006174666883713d-05, -2.41308356761280200d-05, d -2.25823509518346033d-05, -2.11479656768912971d-05, e -1.98200638885294927d-05, -1.85909870801065077d-05/ data beta(89), beta(90), beta(91), beta(92), beta(93), beta(94), 1 beta(95), beta(96), beta(97), beta(98), beta(99), beta(100), 2 beta(101), beta(102), beta(103), beta(104), beta(105), 3 beta(106), beta(107), beta(108), beta(109), beta(110)/ 4 -1.74532699844210224d-05, -1.63997823854497997d-05, 5 -4.74617796559959808d-04, -4.77864567147321487d-04, 6 -3.20390228067037603d-04, -1.61105016119962282d-04, 7 -4.25778101285435204d-05, 3.44571294294967503d-05, 8 7.97092684075674924d-05, 1.03138236708272200d-04, 9 1.12466775262204158d-04, 1.13103642108481389d-04, a 1.08651634848774268d-04, 1.01437951597661973d-04, b 9.29298396593363896d-05, 8.40293133016089978d-05, c 7.52727991349134062d-05, 6.69632521975730872d-05, d 5.92564547323194704d-05, 5.22169308826975567d-05, e 4.58539485165360646d-05, 4.01445513891486808d-05/ data beta(111), beta(112), beta(113), beta(114), beta(115), 1 beta(116), beta(117), beta(118), beta(119), beta(120), 2 beta(121), beta(122), beta(123), beta(124), beta(125), 3 beta(126), beta(127), beta(128), beta(129), beta(130)/ 4 3.50481730031328081d-05, 3.05157995034346659d-05, 5 2.64956119950516039d-05, 2.29363633690998152d-05, 6 1.97893056664021636d-05, 1.70091984636412623d-05, 7 1.45547428261524004d-05, 1.23886640995878413d-05, 8 1.04775876076583236d-05, 8.79179954978479373d-06, 9 7.36465810572578444d-04, 8.72790805146193976d-04, a 6.22614862573135066d-04, 2.85998154194304147d-04, b 3.84737672879366102d-06, -1.87906003636971558d-04, c -2.97603646594554535d-04, -3.45998126832656348d-04, d -3.53382470916037712d-04, -3.35715635775048757d-04/ data beta(131), beta(132), beta(133), beta(134), beta(135), 1 beta(136), beta(137), beta(138), beta(139), beta(140), 2 beta(141), beta(142), beta(143), beta(144), beta(145), 3 beta(146), beta(147), beta(148), beta(149), beta(150)/ 4 -3.04321124789039809d-04, -2.66722723047612821d-04, 5 -2.27654214122819527d-04, -1.89922611854562356d-04, 6 -1.55058918599093870d-04, -1.23778240761873630d-04, 7 -9.62926147717644187d-05, -7.25178327714425337d-05, 8 -5.22070028895633801d-05, -3.50347750511900522d-05, 9 -2.06489761035551757d-05, -8.70106096849767054d-06, a 1.13698686675100290d-06, 9.16426474122778849d-06, b 1.56477785428872620d-05, 2.08223629482466847d-05, c 2.48923381004595156d-05, 2.80340509574146325d-05, d 3.03987774629861915d-05, 3.21156731406700616d-05/ data beta(151), beta(152), beta(153), beta(154), beta(155), 1 beta(156), beta(157), beta(158), beta(159), beta(160), 2 beta(161), beta(162), beta(163), beta(164), beta(165), 3 beta(166), beta(167), beta(168), beta(169), beta(170)/ 4 -1.80182191963885708d-03, -2.43402962938042533d-03, 5 -1.83422663549856802d-03, -7.62204596354009765d-04, 6 2.39079475256927218d-04, 9.49266117176881141d-04, 7 1.34467449701540359d-03, 1.48457495259449178d-03, 8 1.44732339830617591d-03, 1.30268261285657186d-03, 9 1.10351597375642682d-03, 8.86047440419791759d-04, a 6.73073208165665473d-04, 4.77603872856582378d-04, b 3.05991926358789362d-04, 1.60315694594721630d-04, c 4.00749555270613286d-05, -5.66607461635251611d-05, d -1.32506186772982638d-04, -1.90296187989614057d-04/ data beta(171), beta(172), beta(173), beta(174), beta(175), 1 beta(176), beta(177), beta(178), beta(179), beta(180), 2 beta(181), beta(182), beta(183), beta(184), beta(185), 3 beta(186), beta(187), beta(188), beta(189), beta(190)/ 4 -2.32811450376937408d-04, -2.62628811464668841d-04, 5 -2.82050469867598672d-04, -2.93081563192861167d-04, 6 -2.97435962176316616d-04, -2.96557334239348078d-04, 7 -2.91647363312090861d-04, -2.83696203837734166d-04, 8 -2.73512317095673346d-04, -2.61750155806768580d-04, 9 6.38585891212050914d-03, 9.62374215806377941d-03, a 7.61878061207001043d-03, 2.83219055545628054d-03, b -2.09841352012720090d-03, -5.73826764216626498d-03, c -7.70804244495414620d-03, -8.21011692264844401d-03, d -7.65824520346905413d-03, -6.47209729391045177d-03/ data beta(191), beta(192), beta(193), beta(194), beta(195), 1 beta(196), beta(197), beta(198), beta(199), beta(200), 2 beta(201), beta(202), beta(203), beta(204), beta(205), 3 beta(206), beta(207), beta(208), beta(209), beta(210)/ 4 -4.99132412004966473d-03, -3.45612289713133280d-03, 5 -2.01785580014170775d-03, -7.59430686781961401d-04, 6 2.84173631523859138d-04, 1.10891667586337403d-03, 7 1.72901493872728771d-03, 2.16812590802684701d-03, 8 2.45357710494539735d-03, 2.61281821058334862d-03, 9 2.67141039656276912d-03, 2.65203073395980430d-03, a 2.57411652877287315d-03, 2.45389126236094427d-03, b 2.30460058071795494d-03, 2.13684837686712662d-03, c 1.95896528478870911d-03, 1.77737008679454412d-03, d 1.59690280765839059d-03, 1.42111975664438546d-03/ data gama(1), gama(2), gama(3), gama(4), gama(5), gama(6), 1 gama(7), gama(8), gama(9), gama(10), gama(11), gama(12), 2 gama(13), gama(14), gama(15), gama(16), gama(17), gama(18), 3 gama(19), gama(20), gama(21), gama(22)/ 4 6.29960524947436582d-01, 2.51984209978974633d-01, 5 1.54790300415655846d-01, 1.10713062416159013d-01, 6 8.57309395527394825d-02, 6.97161316958684292d-02, 7 5.86085671893713576d-02, 5.04698873536310685d-02, 8 4.42600580689154809d-02, 3.93720661543509966d-02, 9 3.54283195924455368d-02, 3.21818857502098231d-02, a 2.94646240791157679d-02, 2.71581677112934479d-02, b 2.51768272973861779d-02, 2.34570755306078891d-02, c 2.19508390134907203d-02, 2.06210828235646240d-02, d 1.94388240897880846d-02, 1.83810633800683158d-02, e 1.74293213231963172d-02, 1.65685837786612353d-02/ data gama(23), gama(24), gama(25), gama(26), gama(27), gama(28), 1 gama(29), gama(30)/ 2 1.57865285987918445d-02, 1.50729501494095594d-02, 3 1.44193250839954639d-02, 1.38184805735341786d-02, 4 1.32643378994276568d-02, 1.27517121970498651d-02, 5 1.22761545318762767d-02, 1.18338262398482403d-02/ data ex1, ex2, hpi, gpi, thpi / 1 3.33333333333333333d-01, 6.66666666666666667d-01, 2 1.57079632679489662d+00, 3.14159265358979324d+00, 3 4.71238898038468986d+00/ data zeror,zeroi,coner,conei / 0.0d0, 0.0d0, 1.0d0, 0.0d0 / c rfnu = 1.0d0/fnu c----------------------------------------------------------------------- c overflow test (z/fnu too small) c----------------------------------------------------------------------- test = d1mach(1)*1.0d+3 ac = fnu*test if (dabs(zr).gt.ac .or. dabs(zi).gt.ac) go to 15 zeta1r = 2.0d0*dabs(dlog(test))+fnu zeta1i = 0.0d0 zeta2r = fnu zeta2i = 0.0d0 phir = 1.0d0 phii = 0.0d0 argr = 1.0d0 argi = 0.0d0 return 15 continue zbr = zr*rfnu zbi = zi*rfnu rfnu2 = rfnu*rfnu c----------------------------------------------------------------------- c compute in the fourth quadrant c----------------------------------------------------------------------- fn13 = fnu**ex1 fn23 = fn13*fn13 rfn13 = 1.0d0/fn13 w2r = coner - zbr*zbr + zbi*zbi w2i = conei - zbr*zbi - zbr*zbi aw2 = zabs2(w2r,w2i) if (aw2.gt.0.25d0) go to 130 c----------------------------------------------------------------------- c power series for cabs(w2).le.0.25d0 c----------------------------------------------------------------------- k = 1 pr(1) = coner pi(1) = conei sumar = gama(1) sumai = zeroi ap(1) = 1.0d0 if (aw2.lt.tol) go to 20 do 10 k=2,30 pr(k) = pr(k-1)*w2r - pi(k-1)*w2i pi(k) = pr(k-1)*w2i + pi(k-1)*w2r sumar = sumar + pr(k)*gama(k) sumai = sumai + pi(k)*gama(k) ap(k) = ap(k-1)*aw2 if (ap(k).lt.tol) go to 20 10 continue k = 30 20 continue kmax = k zetar = w2r*sumar - w2i*sumai zetai = w2r*sumai + w2i*sumar argr = zetar*fn23 argi = zetai*fn23 call zsqrt(sumar, sumai, zar, zai) call zsqrt(w2r, w2i, str, sti) zeta2r = str*fnu zeta2i = sti*fnu str = coner + ex2*(zetar*zar-zetai*zai) sti = conei + ex2*(zetar*zai+zetai*zar) zeta1r = str*zeta2r - sti*zeta2i zeta1i = str*zeta2i + sti*zeta2r zar = zar + zar zai = zai + zai call zsqrt(zar, zai, str, sti) phir = str*rfn13 phii = sti*rfn13 if (ipmtr.eq.1) go to 120 c----------------------------------------------------------------------- c sum series for asum and bsum c----------------------------------------------------------------------- sumbr = zeror sumbi = zeroi do 30 k=1,kmax sumbr = sumbr + pr(k)*beta(k) sumbi = sumbi + pi(k)*beta(k) 30 continue asumr = zeror asumi = zeroi bsumr = sumbr bsumi = sumbi l1 = 0 l2 = 30 btol = tol*(dabs(bsumr)+dabs(bsumi)) atol = tol pp = 1.0d0 ias = 0 ibs = 0 if (rfnu2.lt.tol) go to 110 do 100 is=2,7 atol = atol/rfnu2 pp = pp*rfnu2 if (ias.eq.1) go to 60 sumar = zeror sumai = zeroi do 40 k=1,kmax m = l1 + k sumar = sumar + pr(k)*alfa(m) sumai = sumai + pi(k)*alfa(m) if (ap(k).lt.atol) go to 50 40 continue 50 continue asumr = asumr + sumar*pp asumi = asumi + sumai*pp if (pp.lt.tol) ias = 1 60 continue if (ibs.eq.1) go to 90 sumbr = zeror sumbi = zeroi do 70 k=1,kmax m = l2 + k sumbr = sumbr + pr(k)*beta(m) sumbi = sumbi + pi(k)*beta(m) if (ap(k).lt.atol) go to 80 70 continue 80 continue bsumr = bsumr + sumbr*pp bsumi = bsumi + sumbi*pp if (pp.lt.btol) ibs = 1 90 continue if (ias.eq.1 .and. ibs.eq.1) go to 110 l1 = l1 + 30 l2 = l2 + 30 100 continue 110 continue asumr = asumr + coner pp = rfnu*rfn13 bsumr = bsumr*pp bsumi = bsumi*pp 120 continue return c----------------------------------------------------------------------- c cabs(w2).gt.0.25d0 c----------------------------------------------------------------------- 130 continue call zsqrt(w2r, w2i, wr, wi) if (wr.lt.0.0d0) wr = 0.0d0 if (wi.lt.0.0d0) wi = 0.0d0 str = coner + wr sti = wi call zdiv(str, sti, zbr, zbi, zar, zai) call zlog(zar, zai, zcr, zci, idum) if (zci.lt.0.0d0) zci = 0.0d0 if (zci.gt.hpi) zci = hpi if (zcr.lt.0.0d0) zcr = 0.0d0 zthr = (zcr-wr)*1.5d0 zthi = (zci-wi)*1.5d0 zeta1r = zcr*fnu zeta1i = zci*fnu zeta2r = wr*fnu zeta2i = wi*fnu azth = zabs2(zthr,zthi) ang = thpi if (zthr.ge.0.0d0 .and. zthi.lt.0.0d0) go to 140 ang = hpi if (zthr.eq.0.0d0) go to 140 ang = datan(zthi/zthr) if (zthr.lt.0.0d0) ang = ang + gpi 140 continue pp = azth**ex2 ang = ang*ex2 zetar = pp*dcos(ang) zetai = pp*dsin(ang) if (zetai.lt.0.0d0) zetai = 0.0d0 argr = zetar*fn23 argi = zetai*fn23 call zdiv(zthr, zthi, zetar, zetai, rtztr, rtzti) call zdiv(rtztr, rtzti, wr, wi, zar, zai) tzar = zar + zar tzai = zai + zai call zsqrt(tzar, tzai, str, sti) phir = str*rfn13 phii = sti*rfn13 if (ipmtr.eq.1) go to 120 raw = 1.0d0/dsqrt(aw2) str = wr*raw sti = -wi*raw tfnr = str*rfnu*raw tfni = sti*rfnu*raw razth = 1.0d0/azth str = zthr*razth sti = -zthi*razth rzthr = str*razth*rfnu rzthi = sti*razth*rfnu zcr = rzthr*ar(2) zci = rzthi*ar(2) raw2 = 1.0d0/aw2 str = w2r*raw2 sti = -w2i*raw2 t2r = str*raw2 t2i = sti*raw2 str = t2r*c(2) + c(3) sti = t2i*c(2) upr(2) = str*tfnr - sti*tfni upi(2) = str*tfni + sti*tfnr bsumr = upr(2) + zcr bsumi = upi(2) + zci asumr = zeror asumi = zeroi if (rfnu.lt.tol) go to 220 przthr = rzthr przthi = rzthi ptfnr = tfnr ptfni = tfni upr(1) = coner upi(1) = conei pp = 1.0d0 btol = tol*(dabs(bsumr)+dabs(bsumi)) ks = 0 kp1 = 2 l = 3 ias = 0 ibs = 0 do 210 lr=2,12,2 lrp1 = lr + 1 c----------------------------------------------------------------------- c compute two additional cr, dr, and up for two more terms in c next suma and sumb c----------------------------------------------------------------------- do 160 k=lr,lrp1 ks = ks + 1 kp1 = kp1 + 1 l = l + 1 zar = c(l) zai = zeroi do 150 j=2,kp1 l = l + 1 str = zar*t2r - t2i*zai + c(l) zai = zar*t2i + zai*t2r zar = str 150 continue str = ptfnr*tfnr - ptfni*tfni ptfni = ptfnr*tfni + ptfni*tfnr ptfnr = str upr(kp1) = ptfnr*zar - ptfni*zai upi(kp1) = ptfni*zar + ptfnr*zai crr(ks) = przthr*br(ks+1) cri(ks) = przthi*br(ks+1) str = przthr*rzthr - przthi*rzthi przthi = przthr*rzthi + przthi*rzthr przthr = str drr(ks) = przthr*ar(ks+2) dri(ks) = przthi*ar(ks+2) 160 continue pp = pp*rfnu2 if (ias.eq.1) go to 180 sumar = upr(lrp1) sumai = upi(lrp1) ju = lrp1 do 170 jr=1,lr ju = ju - 1 sumar = sumar + crr(jr)*upr(ju) - cri(jr)*upi(ju) sumai = sumai + crr(jr)*upi(ju) + cri(jr)*upr(ju) 170 continue asumr = asumr + sumar asumi = asumi + sumai test = dabs(sumar) + dabs(sumai) if (pp.lt.tol .and. test.lt.tol) ias = 1 180 continue if (ibs.eq.1) go to 200 sumbr = upr(lr+2) + upr(lrp1)*zcr - upi(lrp1)*zci sumbi = upi(lr+2) + upr(lrp1)*zci + upi(lrp1)*zcr ju = lrp1 do 190 jr=1,lr ju = ju - 1 sumbr = sumbr + drr(jr)*upr(ju) - dri(jr)*upi(ju) sumbi = sumbi + drr(jr)*upi(ju) + dri(jr)*upr(ju) 190 continue bsumr = bsumr + sumbr bsumi = bsumi + sumbi test = dabs(sumbr) + dabs(sumbi) if (pp.lt.btol .and. test.lt.btol) ibs = 1 200 continue if (ias.eq.1 .and. ibs.eq.1) go to 220 210 continue 220 continue asumr = asumr + coner str = -bsumr*rfn13 sti = -bsumi*rfn13 call zdiv(str, sti, rtztr, rtzti, bsumr, bsumi) go to 120 end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zuni1(zr, zi, fnu, kode, n, yr, yi, nz, nlast, fnul, * tol, elim, alim) c refer to zbesi,zbesk c c zuni1 computes i(fnu,z) by means of the uniform asymptotic c expansion for i(fnu,z) in -pi/3.le.arg z.le.pi/3. c c fnul is the smallest order permitted for the asymptotic c expansion. nlast=0 means all of the y values were set. c nlast.ne.0 is the number left to be computed by another c formula for orders fnu to fnu+nlast-1 because fnu+nlast-1.lt.fnul. c y(i)=czero for i=nlast+1,n c c***routines called zuchk,zunik,zuoik,d1mach,zabs2 c complex cfn,cone,crsc,cscl,csr,css,cwrk,czero,c1,c2,phi,rz,sum,s1, c *s2,y,z,zeta1,zeta2 double precision alim, aphi, ascle, bry, coner, crsc, * cscl, csrr, cssr, cwrki, cwrkr, c1r, c2i, c2m, c2r, elim, fn, * fnu, fnul, phii, phir, rast, rs1, rzi, rzr, sti, str, sumi, * sumr, s1i, s1r, s2i, s2r, tol, yi, yr, zeroi, zeror, zeta1i, * zeta1r, zeta2i, zeta2r, zi, zr, cyr, cyi, d1mach, zabs2 integer i, iflag, init, k, kode, m, n, nd, nlast, nn, nuf, nw, nz dimension bry(3), yr(n), yi(n), cwrkr(16), cwrki(16), cssr(3), * csrr(3), cyr(2), cyi(2) data zeror,zeroi,coner / 0.0d0, 0.0d0, 1.0d0 / c nz = 0 nd = n nlast = 0 c----------------------------------------------------------------------- c computed values with exponents between alim and elim in mag- c nitude are scaled to keep intermediate arithmetic on scale, c exp(alim)=exp(elim)*tol c----------------------------------------------------------------------- cscl = 1.0d0/tol crsc = tol cssr(1) = cscl cssr(2) = coner cssr(3) = crsc csrr(1) = crsc csrr(2) = coner csrr(3) = cscl bry(1) = 1.0d+3*d1mach(1)/tol c----------------------------------------------------------------------- c check for underflow and overflow on first member c----------------------------------------------------------------------- fn = dmax1(fnu,1.0d0) init = 0 call zunik(zr, zi, fn, 1, 1, tol, init, phir, phii, zeta1r, * zeta1i, zeta2r, zeta2i, sumr, sumi, cwrkr, cwrki) if (kode.eq.1) go to 10 str = zr + zeta2r sti = zi + zeta2i rast = fn/zabs2(str,sti) str = str*rast*rast sti = -sti*rast*rast s1r = -zeta1r + str s1i = -zeta1i + sti go to 20 10 continue s1r = -zeta1r + zeta2r s1i = -zeta1i + zeta2i 20 continue rs1 = s1r if (dabs(rs1).gt.elim) go to 130 30 continue nn = min0(2,nd) do 80 i=1,nn fn = fnu + dble(float(nd-i)) init = 0 call zunik(zr, zi, fn, 1, 0, tol, init, phir, phii, zeta1r, * zeta1i, zeta2r, zeta2i, sumr, sumi, cwrkr, cwrki) if (kode.eq.1) go to 40 str = zr + zeta2r sti = zi + zeta2i rast = fn/zabs2(str,sti) str = str*rast*rast sti = -sti*rast*rast s1r = -zeta1r + str s1i = -zeta1i + sti + zi go to 50 40 continue s1r = -zeta1r + zeta2r s1i = -zeta1i + zeta2i 50 continue c----------------------------------------------------------------------- c test for underflow and overflow c----------------------------------------------------------------------- rs1 = s1r if (dabs(rs1).gt.elim) go to 110 if (i.eq.1) iflag = 2 if (dabs(rs1).lt.alim) go to 60 c----------------------------------------------------------------------- c refine test and scale c----------------------------------------------------------------------- aphi = zabs2(phir,phii) rs1 = rs1 + dlog(aphi) if (dabs(rs1).gt.elim) go to 110 if (i.eq.1) iflag = 1 if (rs1.lt.0.0d0) go to 60 if (i.eq.1) iflag = 3 60 continue c----------------------------------------------------------------------- c scale s1 if cabs(s1).lt.ascle c----------------------------------------------------------------------- s2r = phir*sumr - phii*sumi s2i = phir*sumi + phii*sumr str = dexp(s1r)*cssr(iflag) s1r = str*dcos(s1i) s1i = str*dsin(s1i) str = s2r*s1r - s2i*s1i s2i = s2r*s1i + s2i*s1r s2r = str if (iflag.ne.1) go to 70 call zuchk(s2r, s2i, nw, bry(1), tol) if (nw.ne.0) go to 110 70 continue cyr(i) = s2r cyi(i) = s2i m = nd - i + 1 yr(m) = s2r*csrr(iflag) yi(m) = s2i*csrr(iflag) 80 continue if (nd.le.2) go to 100 rast = 1.0d0/zabs2(zr,zi) str = zr*rast sti = -zi*rast rzr = (str+str)*rast rzi = (sti+sti)*rast bry(2) = 1.0d0/bry(1) bry(3) = d1mach(2) s1r = cyr(1) s1i = cyi(1) s2r = cyr(2) s2i = cyi(2) c1r = csrr(iflag) ascle = bry(iflag) k = nd - 2 fn = dble(float(k)) do 90 i=3,nd c2r = s2r c2i = s2i s2r = s1r + (fnu+fn)*(rzr*c2r-rzi*c2i) s2i = s1i + (fnu+fn)*(rzr*c2i+rzi*c2r) s1r = c2r s1i = c2i c2r = s2r*c1r c2i = s2i*c1r yr(k) = c2r yi(k) = c2i k = k - 1 fn = fn - 1.0d0 if (iflag.ge.3) go to 90 str = dabs(c2r) sti = dabs(c2i) c2m = dmax1(str,sti) if (c2m.le.ascle) go to 90 iflag = iflag + 1 ascle = bry(iflag) s1r = s1r*c1r s1i = s1i*c1r s2r = c2r s2i = c2i s1r = s1r*cssr(iflag) s1i = s1i*cssr(iflag) s2r = s2r*cssr(iflag) s2i = s2i*cssr(iflag) c1r = csrr(iflag) 90 continue 100 continue return c----------------------------------------------------------------------- c set underflow and update parameters c----------------------------------------------------------------------- 110 continue if (rs1.gt.0.0d0) go to 120 yr(nd) = zeror yi(nd) = zeroi nz = nz + 1 nd = nd - 1 if (nd.eq.0) go to 100 call zuoik(zr, zi, fnu, kode, 1, nd, yr, yi, nuf, tol, elim, alim) if (nuf.lt.0) go to 120 nd = nd - nuf nz = nz + nuf if (nd.eq.0) go to 100 fn = fnu + dble(float(nd-1)) if (fn.ge.fnul) go to 30 nlast = nd return 120 continue nz = -1 return 130 continue if (rs1.gt.0.0d0) go to 120 nz = n do 140 i=1,n yr(i) = zeror yi(i) = zeroi 140 continue return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zuni2(zr, zi, fnu, kode, n, yr, yi, nz, nlast, fnul, * tol, elim, alim) c refer to zbesi,zbesk c c zuni2 computes i(fnu,z) in the right half plane by means of c uniform asymptotic expansion for j(fnu,zn) where zn is z*i c or -z*i and zn is in the right half plane also. c c fnul is the smallest order permitted for the asymptotic c expansion. nlast=0 means all of the y values were set. c nlast.ne.0 is the number left to be computed by another c formula for orders fnu to fnu+nlast-1 because fnu+nlast-1.lt.fnul. c y(i)=czero for i=nlast+1,n c c***routines called zairy,zuchk,zunhj,zuoik,d1mach,zabs2 c complex ai,arg,asum,bsum,cfn,ci,cid,cip,cone,crsc,cscl,csr,css, c *czero,c1,c2,dai,phi,rz,s1,s2,y,z,zb,zeta1,zeta2,zn double precision aarg, aic, aii, air, alim, ang, aphi, argi, * argr, ascle, asumi, asumr, bry, bsumi, bsumr, cidi, cipi, cipr, * coner, crsc, cscl, csrr, cssr, c1r, c2i, c2m, c2r, daii, * dair, elim, fn, fnu, fnul, hpi, phii, phir, rast, raz, rs1, rzi, * rzr, sti, str, s1i, s1r, s2i, s2r, tol, yi, yr, zbi, zbr, zeroi, * zeror, zeta1i, zeta1r, zeta2i, zeta2r, zi, zni, znr, zr, cyr, * cyi, d1mach, zabs2, car, sar integer i, iflag, in, inu, j, k, kode, n, nai, nd, ndai, nlast, * nn, nuf, nw, nz, idum dimension bry(3), yr(n), yi(n), cipr(4), cipi(4), cssr(3), * csrr(3), cyr(2), cyi(2) data zeror,zeroi,coner / 0.0d0, 0.0d0, 1.0d0 / data cipr(1),cipi(1),cipr(2),cipi(2),cipr(3),cipi(3),cipr(4), * cipi(4)/ 1.0d0,0.0d0, 0.0d0,1.0d0, -1.0d0,0.0d0, 0.0d0,-1.0d0/ data hpi, aic / 1 1.57079632679489662d+00, 1.265512123484645396d+00/ c nz = 0 nd = n nlast = 0 c----------------------------------------------------------------------- c computed values with exponents between alim and elim in mag- c nitude are scaled to keep intermediate arithmetic on scale, c exp(alim)=exp(elim)*tol c----------------------------------------------------------------------- cscl = 1.0d0/tol crsc = tol cssr(1) = cscl cssr(2) = coner cssr(3) = crsc csrr(1) = crsc csrr(2) = coner csrr(3) = cscl bry(1) = 1.0d+3*d1mach(1)/tol c----------------------------------------------------------------------- c zn is in the right half plane after rotation by ci or -ci c----------------------------------------------------------------------- znr = zi zni = -zr zbr = zr zbi = zi cidi = -coner inu = int(sngl(fnu)) ang = hpi*(fnu-dble(float(inu))) c2r = dcos(ang) c2i = dsin(ang) car = c2r sar = c2i in = inu + n - 1 in = mod(in,4) + 1 str = c2r*cipr(in) - c2i*cipi(in) c2i = c2r*cipi(in) + c2i*cipr(in) c2r = str if (zi.gt.0.0d0) go to 10 znr = -znr zbi = -zbi cidi = -cidi c2i = -c2i 10 continue c----------------------------------------------------------------------- c check for underflow and overflow on first member c----------------------------------------------------------------------- fn = dmax1(fnu,1.0d0) call zunhj(znr, zni, fn, 1, tol, phir, phii, argr, argi, zeta1r, * zeta1i, zeta2r, zeta2i, asumr, asumi, bsumr, bsumi) if (kode.eq.1) go to 20 str = zbr + zeta2r sti = zbi + zeta2i rast = fn/zabs2(str,sti) str = str*rast*rast sti = -sti*rast*rast s1r = -zeta1r + str s1i = -zeta1i + sti go to 30 20 continue s1r = -zeta1r + zeta2r s1i = -zeta1i + zeta2i 30 continue rs1 = s1r if (dabs(rs1).gt.elim) go to 150 40 continue nn = min0(2,nd) do 90 i=1,nn fn = fnu + dble(float(nd-i)) call zunhj(znr, zni, fn, 0, tol, phir, phii, argr, argi, * zeta1r, zeta1i, zeta2r, zeta2i, asumr, asumi, bsumr, bsumi) if (kode.eq.1) go to 50 str = zbr + zeta2r sti = zbi + zeta2i rast = fn/zabs2(str,sti) str = str*rast*rast sti = -sti*rast*rast s1r = -zeta1r + str s1i = -zeta1i + sti + dabs(zi) go to 60 50 continue s1r = -zeta1r + zeta2r s1i = -zeta1i + zeta2i 60 continue c----------------------------------------------------------------------- c test for underflow and overflow c----------------------------------------------------------------------- rs1 = s1r if (dabs(rs1).gt.elim) go to 120 if (i.eq.1) iflag = 2 if (dabs(rs1).lt.alim) go to 70 c----------------------------------------------------------------------- c refine test and scale c----------------------------------------------------------------------- c----------------------------------------------------------------------- aphi = zabs2(phir,phii) aarg = zabs2(argr,argi) rs1 = rs1 + dlog(aphi) - 0.25d0*dlog(aarg) - aic if (dabs(rs1).gt.elim) go to 120 if (i.eq.1) iflag = 1 if (rs1.lt.0.0d0) go to 70 if (i.eq.1) iflag = 3 70 continue c----------------------------------------------------------------------- c scale s1 to keep intermediate arithmetic on scale near c exponent extremes c----------------------------------------------------------------------- call zairy(argr, argi, 0, 2, air, aii, nai, idum) call zairy(argr, argi, 1, 2, dair, daii, ndai, idum) str = dair*bsumr - daii*bsumi sti = dair*bsumi + daii*bsumr str = str + (air*asumr-aii*asumi) sti = sti + (air*asumi+aii*asumr) s2r = phir*str - phii*sti s2i = phir*sti + phii*str str = dexp(s1r)*cssr(iflag) s1r = str*dcos(s1i) s1i = str*dsin(s1i) str = s2r*s1r - s2i*s1i s2i = s2r*s1i + s2i*s1r s2r = str if (iflag.ne.1) go to 80 call zuchk(s2r, s2i, nw, bry(1), tol) if (nw.ne.0) go to 120 80 continue if (zi.le.0.0d0) s2i = -s2i str = s2r*c2r - s2i*c2i s2i = s2r*c2i + s2i*c2r s2r = str cyr(i) = s2r cyi(i) = s2i j = nd - i + 1 yr(j) = s2r*csrr(iflag) yi(j) = s2i*csrr(iflag) str = -c2i*cidi c2i = c2r*cidi c2r = str 90 continue if (nd.le.2) go to 110 raz = 1.0d0/zabs2(zr,zi) str = zr*raz sti = -zi*raz rzr = (str+str)*raz rzi = (sti+sti)*raz bry(2) = 1.0d0/bry(1) bry(3) = d1mach(2) s1r = cyr(1) s1i = cyi(1) s2r = cyr(2) s2i = cyi(2) c1r = csrr(iflag) ascle = bry(iflag) k = nd - 2 fn = dble(float(k)) do 100 i=3,nd c2r = s2r c2i = s2i s2r = s1r + (fnu+fn)*(rzr*c2r-rzi*c2i) s2i = s1i + (fnu+fn)*(rzr*c2i+rzi*c2r) s1r = c2r s1i = c2i c2r = s2r*c1r c2i = s2i*c1r yr(k) = c2r yi(k) = c2i k = k - 1 fn = fn - 1.0d0 if (iflag.ge.3) go to 100 str = dabs(c2r) sti = dabs(c2i) c2m = dmax1(str,sti) if (c2m.le.ascle) go to 100 iflag = iflag + 1 ascle = bry(iflag) s1r = s1r*c1r s1i = s1i*c1r s2r = c2r s2i = c2i s1r = s1r*cssr(iflag) s1i = s1i*cssr(iflag) s2r = s2r*cssr(iflag) s2i = s2i*cssr(iflag) c1r = csrr(iflag) 100 continue 110 continue return 120 continue if (rs1.gt.0.0d0) go to 140 c----------------------------------------------------------------------- c set underflow and update parameters c----------------------------------------------------------------------- yr(nd) = zeror yi(nd) = zeroi nz = nz + 1 nd = nd - 1 if (nd.eq.0) go to 110 call zuoik(zr, zi, fnu, kode, 1, nd, yr, yi, nuf, tol, elim, alim) if (nuf.lt.0) go to 140 nd = nd - nuf nz = nz + nuf if (nd.eq.0) go to 110 fn = fnu + dble(float(nd-1)) if (fn.lt.fnul) go to 130 c fn = cidi c j = nuf + 1 c k = mod(j,4) + 1 c s1r = cipr(k) c s1i = cipi(k) c if (fn.lt.0.0d0) s1i = -s1i c str = c2r*s1r - c2i*s1i c c2i = c2r*s1i + c2i*s1r c c2r = str in = inu + nd - 1 in = mod(in,4) + 1 c2r = car*cipr(in) - sar*cipi(in) c2i = car*cipi(in) + sar*cipr(in) if (zi.le.0.0d0) c2i = -c2i go to 40 130 continue nlast = nd return 140 continue nz = -1 return 150 continue if (rs1.gt.0.0d0) go to 140 nz = n do 160 i=1,n yr(i) = zeror yi(i) = zeroi 160 continue return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zunik(zrr, zri, fnu, ikflg, ipmtr, tol, init, phir, * phii, zeta1r, zeta1i, zeta2r, zeta2i, sumr, sumi, cwrkr, cwrki) c geuz for g77 EXTERNAL zsqrt EXTERNAL zlog c Refer to zbesi,zbesk c c zunik computes parameters for the uniform asymptotic c expansions of the i and k functions on ikflg= 1 or 2 c respectively by c c w(fnu,zr) = phi*exp(zeta)*sum c c where zeta=-zeta1 + zeta2 or c zeta1 - zeta2 c c the first call must have init=0. subsequent calls with the c same zr and fnu will return the i or k function on ikflg= c 1 or 2 with no change in init. cwrk is a complex work c array. ipmtr=0 computes all parameters. ipmtr=1 computes phi, c zeta1,zeta2. c c***routines called zdiv,zlog,zsqrt,d1mach c complex cfn,con,cone,crfn,cwrk,czero,phi,s,sr,sum,t,t2,zeta1, c *zeta2,zn,zr double precision ac, c, con, conei, coner, crfni, crfnr, cwrki, * cwrkr, fnu, phii, phir, rfn, si, sr, sri, srr, sti, str, sumi, * sumr, test, ti, tol, tr, t2i, t2r, zeroi, zeror, zeta1i, zeta1r, * zeta2i, zeta2r, zni, znr, zri, zrr, d1mach integer i, idum, ikflg, init, ipmtr, j, k, l dimension c(120), cwrkr(16), cwrki(16), con(2) data zeror,zeroi,coner,conei / 0.0d0, 0.0d0, 1.0d0, 0.0d0 / data con(1), con(2) / 1 3.98942280401432678d-01, 1.25331413731550025d+00 / data c(1), c(2), c(3), c(4), c(5), c(6), c(7), c(8), c(9), c(10), 1 c(11), c(12), c(13), c(14), c(15), c(16), c(17), c(18), 2 c(19), c(20), c(21), c(22), c(23), c(24)/ 3 1.00000000000000000d+00, -2.08333333333333333d-01, 4 1.25000000000000000d-01, 3.34201388888888889d-01, 5 -4.01041666666666667d-01, 7.03125000000000000d-02, 6 -1.02581259645061728d+00, 1.84646267361111111d+00, 7 -8.91210937500000000d-01, 7.32421875000000000d-02, 8 4.66958442342624743d+00, -1.12070026162229938d+01, 9 8.78912353515625000d+00, -2.36408691406250000d+00, a 1.12152099609375000d-01, -2.82120725582002449d+01, b 8.46362176746007346d+01, -9.18182415432400174d+01, c 4.25349987453884549d+01, -7.36879435947963170d+00, d 2.27108001708984375d-01, 2.12570130039217123d+02, e -7.65252468141181642d+02, 1.05999045252799988d+03/ data c(25), c(26), c(27), c(28), c(29), c(30), c(31), c(32), 1 c(33), c(34), c(35), c(36), c(37), c(38), c(39), c(40), 2 c(41), c(42), c(43), c(44), c(45), c(46), c(47), c(48)/ 3 -6.99579627376132541d+02, 2.18190511744211590d+02, 4 -2.64914304869515555d+01, 5.72501420974731445d-01, 5 -1.91945766231840700d+03, 8.06172218173730938d+03, 6 -1.35865500064341374d+04, 1.16553933368645332d+04, 7 -5.30564697861340311d+03, 1.20090291321635246d+03, 8 -1.08090919788394656d+02, 1.72772750258445740d+00, 9 2.02042913309661486d+04, -9.69805983886375135d+04, a 1.92547001232531532d+05, -2.03400177280415534d+05, b 1.22200464983017460d+05, -4.11926549688975513d+04, c 7.10951430248936372d+03, -4.93915304773088012d+02, d 6.07404200127348304d+00, -2.42919187900551333d+05, e 1.31176361466297720d+06, -2.99801591853810675d+06/ data c(49), c(50), c(51), c(52), c(53), c(54), c(55), c(56), 1 c(57), c(58), c(59), c(60), c(61), c(62), c(63), c(64), 2 c(65), c(66), c(67), c(68), c(69), c(70), c(71), c(72)/ 3 3.76327129765640400d+06, -2.81356322658653411d+06, 4 1.26836527332162478d+06, -3.31645172484563578d+05, 5 4.52187689813627263d+04, -2.49983048181120962d+03, 6 2.43805296995560639d+01, 3.28446985307203782d+06, 7 -1.97068191184322269d+07, 5.09526024926646422d+07, 8 -7.41051482115326577d+07, 6.63445122747290267d+07, 9 -3.75671766607633513d+07, 1.32887671664218183d+07, a -2.78561812808645469d+06, 3.08186404612662398d+05, b -1.38860897537170405d+04, 1.10017140269246738d+02, c -4.93292536645099620d+07, 3.25573074185765749d+08, d -9.39462359681578403d+08, 1.55359689957058006d+09, e -1.62108055210833708d+09, 1.10684281682301447d+09/ data c(73), c(74), c(75), c(76), c(77), c(78), c(79), c(80), 1 c(81), c(82), c(83), c(84), c(85), c(86), c(87), c(88), 2 c(89), c(90), c(91), c(92), c(93), c(94), c(95), c(96)/ 3 -4.95889784275030309d+08, 1.42062907797533095d+08, 4 -2.44740627257387285d+07, 2.24376817792244943d+06, 5 -8.40054336030240853d+04, 5.51335896122020586d+02, 6 8.14789096118312115d+08, -5.86648149205184723d+09, 7 1.86882075092958249d+10, -3.46320433881587779d+10, 8 4.12801855797539740d+10, -3.30265997498007231d+10, 9 1.79542137311556001d+10, -6.56329379261928433d+09, a 1.55927986487925751d+09, -2.25105661889415278d+08, b 1.73951075539781645d+07, -5.49842327572288687d+05, c 3.03809051092238427d+03, -1.46792612476956167d+10, d 1.14498237732025810d+11, -3.99096175224466498d+11, e 8.19218669548577329d+11, -1.09837515608122331d+12/ data c(97), c(98), c(99), c(100), c(101), c(102), c(103), c(104), 1 c(105), c(106), c(107), c(108), c(109), c(110), c(111), 2 c(112), c(113), c(114), c(115), c(116), c(117), c(118)/ 3 1.00815810686538209d+12, -6.45364869245376503d+11, 4 2.87900649906150589d+11, -8.78670721780232657d+10, 5 1.76347306068349694d+10, -2.16716498322379509d+09, 6 1.43157876718888981d+08, -3.87183344257261262d+06, 7 1.82577554742931747d+04, 2.86464035717679043d+11, 8 -2.40629790002850396d+12, 9.10934118523989896d+12, 9 -2.05168994109344374d+13, 3.05651255199353206d+13, a -3.16670885847851584d+13, 2.33483640445818409d+13, b -1.23204913055982872d+13, 4.61272578084913197d+12, c -1.19655288019618160d+12, 2.05914503232410016d+11, d -2.18229277575292237d+10, 1.24700929351271032d+09/ data c(119), c(120)/ 1 -2.91883881222208134d+07, 1.18838426256783253d+05/ c if (init.ne.0) go to 40 c----------------------------------------------------------------------- c initialize all variables c----------------------------------------------------------------------- rfn = 1.0d0/fnu c----------------------------------------------------------------------- c overflow test (zr/fnu too small) c----------------------------------------------------------------------- test = d1mach(1)*1.0d+3 ac = fnu*test if (dabs(zrr).gt.ac .or. dabs(zri).gt.ac) go to 15 zeta1r = 2.0d0*dabs(dlog(test))+fnu zeta1i = 0.0d0 zeta2r = fnu zeta2i = 0.0d0 phir = 1.0d0 phii = 0.0d0 return 15 continue tr = zrr*rfn ti = zri*rfn sr = coner + (tr*tr-ti*ti) si = conei + (tr*ti+ti*tr) call zsqrt(sr, si, srr, sri) str = coner + srr sti = conei + sri call zdiv(str, sti, tr, ti, znr, zni) call zlog(znr, zni, str, sti, idum) zeta1r = fnu*str zeta1i = fnu*sti zeta2r = fnu*srr zeta2i = fnu*sri call zdiv(coner, conei, srr, sri, tr, ti) srr = tr*rfn sri = ti*rfn call zsqrt(srr, sri, cwrkr(16), cwrki(16)) phir = cwrkr(16)*con(ikflg) phii = cwrki(16)*con(ikflg) if (ipmtr.ne.0) return call zdiv(coner, conei, sr, si, t2r, t2i) cwrkr(1) = coner cwrki(1) = conei crfnr = coner crfni = conei ac = 1.0d0 l = 1 do 20 k=2,15 sr = zeror si = zeroi do 10 j=1,k l = l + 1 str = sr*t2r - si*t2i + c(l) si = sr*t2i + si*t2r sr = str 10 continue str = crfnr*srr - crfni*sri crfni = crfnr*sri + crfni*srr crfnr = str cwrkr(k) = crfnr*sr - crfni*si cwrki(k) = crfnr*si + crfni*sr ac = ac*rfn test = dabs(cwrkr(k)) + dabs(cwrki(k)) if (ac.lt.tol .and. test.lt.tol) go to 30 20 continue k = 15 30 continue init = k 40 continue if (ikflg.eq.2) go to 60 c----------------------------------------------------------------------- c compute sum for the i function c----------------------------------------------------------------------- sr = zeror si = zeroi do 50 i=1,init sr = sr + cwrkr(i) si = si + cwrki(i) 50 continue sumr = sr sumi = si phir = cwrkr(16)*con(1) phii = cwrki(16)*con(1) return 60 continue c----------------------------------------------------------------------- c compute sum for the k function c----------------------------------------------------------------------- sr = zeror si = zeroi tr = coner do 70 i=1,init sr = sr + tr*cwrkr(i) si = si + tr*cwrki(i) tr = -tr 70 continue sumr = sr sumi = si phir = cwrkr(16)*con(2) phii = cwrki(16)*con(2) return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zunk1(zr, zi, fnu, kode, mr, n, yr, yi, nz, tol, elim, * alim) c refer to zbesk c c zunk1 computes k(fnu,z) and its analytic continuation from the c right half plane to the left half plane by means of the c uniform asymptotic expansion. c mr indicates the direction of rotation for analytic continuation. c nz=-1 means an overflow will occur c c***routines called zkscl,zs1s2,zuchk,zunik,d1mach,zabs2 c complex cfn,ck,cone,crsc,cs,cscl,csgn,cspn,csr,css,cwrk,cy,czero, c *c1,c2,phi,phid,rz,sum,sumd,s1,s2,y,z,zeta1,zeta1d,zeta2,zeta2d,zr double precision alim, ang, aphi, asc, ascle, bry, cki, ckr, * coner, crsc, cscl, csgni, cspni, cspnr, csr, csrr, cssr, * cwrki, cwrkr, cyi, cyr, c1i, c1r, c2i, c2m, c2r, elim, fmr, fn, * fnf, fnu, phidi, phidr, phii, phir, pi, rast, razr, rs1, rzi, * rzr, sgn, sti, str, sumdi, sumdr, sumi, sumr, s1i, s1r, s2i, * s2r, tol, yi, yr, zeroi, zeror, zeta1i, zeta1r, zeta2i, zeta2r, * zet1di, zet1dr, zet2di, zet2dr, zi, zr, zri, zrr, d1mach, zabs2 integer i, ib, iflag, ifn, il, init, inu, iuf, k, kdflg, kflag, * kk, kode, mr, n, nw, nz, initd, ic, ipard, j dimension bry(3), init(2), yr(n), yi(n), sumr(2), sumi(2), * zeta1r(2), zeta1i(2), zeta2r(2), zeta2i(2), cyr(2), cyi(2), * cwrkr(16,3), cwrki(16,3), cssr(3), csrr(3), phir(2), phii(2) data zeror,zeroi,coner / 0.0d0, 0.0d0, 1.0d0 / data pi / 3.14159265358979324d0 / c kdflg = 1 nz = 0 c----------------------------------------------------------------------- c exp(-alim)=exp(-elim)/tol=approx. one precision greater than c the underflow limit c----------------------------------------------------------------------- cscl = 1.0d0/tol crsc = tol cssr(1) = cscl cssr(2) = coner cssr(3) = crsc csrr(1) = crsc csrr(2) = coner csrr(3) = cscl bry(1) = 1.0d+3*d1mach(1)/tol bry(2) = 1.0d0/bry(1) bry(3) = d1mach(2) zrr = zr zri = zi if (zr.ge.0.0d0) go to 10 zrr = -zr zri = -zi 10 continue j = 2 do 70 i=1,n c----------------------------------------------------------------------- c j flip flops between 1 and 2 in j = 3 - j c----------------------------------------------------------------------- j = 3 - j fn = fnu + dble(float(i-1)) init(j) = 0 call zunik(zrr, zri, fn, 2, 0, tol, init(j), phir(j), phii(j), * zeta1r(j), zeta1i(j), zeta2r(j), zeta2i(j), sumr(j), sumi(j), * cwrkr(1,j), cwrki(1,j)) if (kode.eq.1) go to 20 str = zrr + zeta2r(j) sti = zri + zeta2i(j) rast = fn/zabs2(str,sti) str = str*rast*rast sti = -sti*rast*rast s1r = zeta1r(j) - str s1i = zeta1i(j) - sti go to 30 20 continue s1r = zeta1r(j) - zeta2r(j) s1i = zeta1i(j) - zeta2i(j) 30 continue rs1 = s1r c----------------------------------------------------------------------- c test for underflow and overflow c----------------------------------------------------------------------- if (dabs(rs1).gt.elim) go to 60 if (kdflg.eq.1) kflag = 2 if (dabs(rs1).lt.alim) go to 40 c----------------------------------------------------------------------- c refine test and scale c----------------------------------------------------------------------- aphi = zabs2(phir(j),phii(j)) rs1 = rs1 + dlog(aphi) if (dabs(rs1).gt.elim) go to 60 if (kdflg.eq.1) kflag = 1 if (rs1.lt.0.0d0) go to 40 if (kdflg.eq.1) kflag = 3 40 continue c----------------------------------------------------------------------- c scale s1 to keep intermediate arithmetic on scale near c exponent extremes c----------------------------------------------------------------------- s2r = phir(j)*sumr(j) - phii(j)*sumi(j) s2i = phir(j)*sumi(j) + phii(j)*sumr(j) str = dexp(s1r)*cssr(kflag) s1r = str*dcos(s1i) s1i = str*dsin(s1i) str = s2r*s1r - s2i*s1i s2i = s1r*s2i + s2r*s1i s2r = str if (kflag.ne.1) go to 50 call zuchk(s2r, s2i, nw, bry(1), tol) if (nw.ne.0) go to 60 50 continue cyr(kdflg) = s2r cyi(kdflg) = s2i yr(i) = s2r*csrr(kflag) yi(i) = s2i*csrr(kflag) if (kdflg.eq.2) go to 75 kdflg = 2 go to 70 60 continue if (rs1.gt.0.0d0) go to 300 c----------------------------------------------------------------------- c for zr.lt.0.0, the i function to be added will overflow c----------------------------------------------------------------------- if (zr.lt.0.0d0) go to 300 kdflg = 1 yr(i)=zeror yi(i)=zeroi nz=nz+1 if (i.eq.1) go to 70 if ((yr(i-1).eq.zeror).and.(yi(i-1).eq.zeroi)) go to 70 yr(i-1)=zeror yi(i-1)=zeroi nz=nz+1 70 continue i = n 75 continue razr = 1.0d0/zabs2(zrr,zri) str = zrr*razr sti = -zri*razr rzr = (str+str)*razr rzi = (sti+sti)*razr ckr = fn*rzr cki = fn*rzi ib = i + 1 if (n.lt.ib) go to 160 c----------------------------------------------------------------------- c test last member for underflow and overflow. set sequence to zero c on underflow. c----------------------------------------------------------------------- fn = fnu + dble(float(n-1)) ipard = 1 if (mr.ne.0) ipard = 0 initd = 0 call zunik(zrr, zri, fn, 2, ipard, tol, initd, phidr, phidi, * zet1dr, zet1di, zet2dr, zet2di, sumdr, sumdi, cwrkr(1,3), * cwrki(1,3)) if (kode.eq.1) go to 80 str = zrr + zet2dr sti = zri + zet2di rast = fn/zabs2(str,sti) str = str*rast*rast sti = -sti*rast*rast s1r = zet1dr - str s1i = zet1di - sti go to 90 80 continue s1r = zet1dr - zet2dr s1i = zet1di - zet2di 90 continue rs1 = s1r if (dabs(rs1).gt.elim) go to 95 if (dabs(rs1).lt.alim) go to 100 c---------------------------------------------------------------------------- c refine estimate and test c------------------------------------------------------------------------- aphi = zabs2(phidr,phidi) rs1 = rs1+dlog(aphi) if (dabs(rs1).lt.elim) go to 100 95 continue if (dabs(rs1).gt.0.0d0) go to 300 c----------------------------------------------------------------------- c for zr.lt.0.0, the i function to be added will overflow c----------------------------------------------------------------------- if (zr.lt.0.0d0) go to 300 nz = n do 96 i=1,n yr(i) = zeror yi(i) = zeroi 96 continue return c--------------------------------------------------------------------------- c forward recur for remainder of the sequence c---------------------------------------------------------------------------- 100 continue s1r = cyr(1) s1i = cyi(1) s2r = cyr(2) s2i = cyi(2) c1r = csrr(kflag) ascle = bry(kflag) do 120 i=ib,n c2r = s2r c2i = s2i s2r = ckr*c2r - cki*c2i + s1r s2i = ckr*c2i + cki*c2r + s1i s1r = c2r s1i = c2i ckr = ckr + rzr cki = cki + rzi c2r = s2r*c1r c2i = s2i*c1r yr(i) = c2r yi(i) = c2i if (kflag.ge.3) go to 120 str = dabs(c2r) sti = dabs(c2i) c2m = dmax1(str,sti) if (c2m.le.ascle) go to 120 kflag = kflag + 1 ascle = bry(kflag) s1r = s1r*c1r s1i = s1i*c1r s2r = c2r s2i = c2i s1r = s1r*cssr(kflag) s1i = s1i*cssr(kflag) s2r = s2r*cssr(kflag) s2i = s2i*cssr(kflag) c1r = csrr(kflag) 120 continue 160 continue if (mr.eq.0) return c----------------------------------------------------------------------- c analytic continuation for re(z).lt.0.0d0 c----------------------------------------------------------------------- nz = 0 fmr = dble(float(mr)) sgn = -dsign(pi,fmr) c----------------------------------------------------------------------- c cspn and csgn are coeff of k and i functions resp. c----------------------------------------------------------------------- csgni = sgn inu = int(sngl(fnu)) fnf = fnu - dble(float(inu)) ifn = inu + n - 1 ang = fnf*sgn cspnr = dcos(ang) cspni = dsin(ang) if (mod(ifn,2).eq.0) go to 170 cspnr = -cspnr cspni = -cspni 170 continue asc = bry(1) iuf = 0 kk = n kdflg = 1 ib = ib - 1 ic = ib - 1 do 270 k=1,n fn = fnu + dble(float(kk-1)) c----------------------------------------------------------------------- c logic to sort out cases whose parameters were set for the k c function above c----------------------------------------------------------------------- m=3 if (n.gt.2) go to 175 172 continue initd = init(j) phidr = phir(j) phidi = phii(j) zet1dr = zeta1r(j) zet1di = zeta1i(j) zet2dr = zeta2r(j) zet2di = zeta2i(j) sumdr = sumr(j) sumdi = sumi(j) m = j j = 3 - j go to 180 175 continue if ((kk.eq.n).and.(ib.lt.n)) go to 180 if ((kk.eq.ib).or.(kk.eq.ic)) go to 172 initd = 0 180 continue call zunik(zrr, zri, fn, 1, 0, tol, initd, phidr, phidi, * zet1dr, zet1di, zet2dr, zet2di, sumdr, sumdi, * cwrkr(1,m), cwrki(1,m)) if (kode.eq.1) go to 200 str = zrr + zet2dr sti = zri + zet2di rast = fn/zabs2(str,sti) str = str*rast*rast sti = -sti*rast*rast s1r = -zet1dr + str s1i = -zet1di + sti go to 210 200 continue s1r = -zet1dr + zet2dr s1i = -zet1di + zet2di 210 continue c----------------------------------------------------------------------- c test for underflow and overflow c----------------------------------------------------------------------- rs1 = s1r if (dabs(rs1).gt.elim) go to 260 if (kdflg.eq.1) iflag = 2 if (dabs(rs1).lt.alim) go to 220 c----------------------------------------------------------------------- c refine test and scale c----------------------------------------------------------------------- aphi = zabs2(phidr,phidi) rs1 = rs1 + dlog(aphi) if (dabs(rs1).gt.elim) go to 260 if (kdflg.eq.1) iflag = 1 if (rs1.lt.0.0d0) go to 220 if (kdflg.eq.1) iflag = 3 220 continue str = phidr*sumdr - phidi*sumdi sti = phidr*sumdi + phidi*sumdr s2r = -csgni*sti s2i = csgni*str str = dexp(s1r)*cssr(iflag) s1r = str*dcos(s1i) s1i = str*dsin(s1i) str = s2r*s1r - s2i*s1i s2i = s2r*s1i + s2i*s1r s2r = str if (iflag.ne.1) go to 230 call zuchk(s2r, s2i, nw, bry(1), tol) if (nw.eq.0) go to 230 s2r = zeror s2i = zeroi 230 continue cyr(kdflg) = s2r cyi(kdflg) = s2i c2r = s2r c2i = s2i s2r = s2r*csrr(iflag) s2i = s2i*csrr(iflag) c----------------------------------------------------------------------- c add i and k functions, k sequence in y(i), i=1,n c----------------------------------------------------------------------- s1r = yr(kk) s1i = yi(kk) if (kode.eq.1) go to 250 call zs1s2(zrr, zri, s1r, s1i, s2r, s2i, nw, asc, alim, iuf) nz = nz + nw 250 continue yr(kk) = s1r*cspnr - s1i*cspni + s2r yi(kk) = cspnr*s1i + cspni*s1r + s2i kk = kk - 1 cspnr = -cspnr cspni = -cspni if (c2r.ne.0.0d0 .or. c2i.ne.0.0d0) go to 255 kdflg = 1 go to 270 255 continue if (kdflg.eq.2) go to 275 kdflg = 2 go to 270 260 continue if (rs1.gt.0.0d0) go to 300 s2r = zeror s2i = zeroi go to 230 270 continue k = n 275 continue il = n - k if (il.eq.0) return c----------------------------------------------------------------------- c recur backward for remainder of i sequence and add in the c k functions, scaling the i sequence during recurrence to keep c intermediate arithmetic on scale near exponent extremes. c----------------------------------------------------------------------- s1r = cyr(1) s1i = cyi(1) s2r = cyr(2) s2i = cyi(2) csr = csrr(iflag) ascle = bry(iflag) fn = dble(float(inu+il)) do 290 i=1,il c2r = s2r c2i = s2i s2r = s1r + (fn+fnf)*(rzr*c2r-rzi*c2i) s2i = s1i + (fn+fnf)*(rzr*c2i+rzi*c2r) s1r = c2r s1i = c2i fn = fn - 1.0d0 c2r = s2r*csr c2i = s2i*csr ckr = c2r cki = c2i c1r = yr(kk) c1i = yi(kk) if (kode.eq.1) go to 280 call zs1s2(zrr, zri, c1r, c1i, c2r, c2i, nw, asc, alim, iuf) nz = nz + nw 280 continue yr(kk) = c1r*cspnr - c1i*cspni + c2r yi(kk) = c1r*cspni + c1i*cspnr + c2i kk = kk - 1 cspnr = -cspnr cspni = -cspni if (iflag.ge.3) go to 290 c2r = dabs(ckr) c2i = dabs(cki) c2m = dmax1(c2r,c2i) if (c2m.le.ascle) go to 290 iflag = iflag + 1 ascle = bry(iflag) s1r = s1r*csr s1i = s1i*csr s2r = ckr s2i = cki s1r = s1r*cssr(iflag) s1i = s1i*cssr(iflag) s2r = s2r*cssr(iflag) s2i = s2i*cssr(iflag) csr = csrr(iflag) 290 continue return 300 continue nz = -1 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zunk2(zr, zi, fnu, kode, mr, n, yr, yi, nz, tol, elim, * alim) c refer to zbesk c c zunk2 computes k(fnu,z) and its analytic continuation from the c right half plane to the left half plane by means of the c uniform asymptotic expansions for h(kind,fnu,zn) and j(fnu,zn) c where zn is in the right half plane, kind=(3-mr)/2, mr=+1 or c -1. here zn=zr*i or -zr*i where zr=z if z is in the right c half plane or zr=-z if z is in the left half plane. mr indic- c ates the direction of rotation for analytic continuation. c nz=-1 means an overflow will occur c c***routines called zairy,zkscl,zs1s2,zuchk,zunhj,d1mach,zabs2 c complex ai,arg,argd,asum,asumd,bsum,bsumd,cfn,ci,cip,ck,cone,crsc, c *cr1,cr2,cs,cscl,csgn,cspn,csr,css,cy,czero,c1,c2,dai,phi,phid,rz, c *s1,s2,y,z,zb,zeta1,zeta1d,zeta2,zeta2d,zn,zr double precision aarg, aic, aii, air, alim, ang, aphi, argdi, * argdr, argi, argr, asc, ascle, asumdi, asumdr, asumi, asumr, * bry, bsumdi, bsumdr, bsumi, bsumr, car, cipi, cipr, cki, ckr, * coner, crsc, cr1i, cr1r, cr2i, cr2r, cscl, csgni, csi, * cspni, cspnr, csr, csrr, cssr, cyi, cyr, c1i, c1r, c2i, c2m, * c2r, daii, dair, elim, fmr, fn, fnf, fnu, hpi, phidi, phidr, * phii, phir, pi, pti, ptr, rast, razr, rs1, rzi, rzr, sar, sgn, * sti, str, s1i, s1r, s2i, s2r, tol, yi, yr, yy, zbi, zbr, zeroi, * zeror, zeta1i, zeta1r, zeta2i, zeta2r, zet1di, zet1dr, zet2di, * zet2dr, zi, zni, znr, zr, zri, zrr, d1mach, zabs2 integer i, ib, iflag, ifn, il, in, inu, iuf, k, kdflg, kflag, kk, * kode, mr, n, nai, ndai, nw, nz, idum, j, ipard, ic dimension bry(3), yr(n), yi(n), asumr(2), asumi(2), bsumr(2), * bsumi(2), phir(2), phii(2), argr(2), argi(2), zeta1r(2), * zeta1i(2), zeta2r(2), zeta2i(2), cyr(2), cyi(2), cipr(4), * cipi(4), cssr(3), csrr(3) data zeror,zeroi,coner,cr1r,cr1i,cr2r,cr2i / 1 0.0d0, 0.0d0, 1.0d0, 1 1.0d0,1.73205080756887729d0 , -0.5d0,-8.66025403784438647d-01 / data hpi, pi, aic / 1 1.57079632679489662d+00, 3.14159265358979324d+00, 1 1.26551212348464539d+00/ data cipr(1),cipi(1),cipr(2),cipi(2),cipr(3),cipi(3),cipr(4), * cipi(4) / 1 1.0d0,0.0d0 , 0.0d0,-1.0d0 , -1.0d0,0.0d0 , 0.0d0,1.0d0 / c kdflg = 1 nz = 0 c----------------------------------------------------------------------- c exp(-alim)=exp(-elim)/tol=approx. one precision greater than c the underflow limit c----------------------------------------------------------------------- cscl = 1.0d0/tol crsc = tol cssr(1) = cscl cssr(2) = coner cssr(3) = crsc csrr(1) = crsc csrr(2) = coner csrr(3) = cscl bry(1) = 1.0d+3*d1mach(1)/tol bry(2) = 1.0d0/bry(1) bry(3) = d1mach(2) zrr = zr zri = zi if (zr.ge.0.0d0) go to 10 zrr = -zr zri = -zi 10 continue yy = zri znr = zri zni = -zrr zbr = zrr zbi = zri inu = int(sngl(fnu)) fnf = fnu - dble(float(inu)) ang = -hpi*fnf car = dcos(ang) sar = dsin(ang) c2r = hpi*sar c2i = -hpi*car kk = mod(inu,4) + 1 str = c2r*cipr(kk) - c2i*cipi(kk) sti = c2r*cipi(kk) + c2i*cipr(kk) csr = cr1r*str - cr1i*sti csi = cr1r*sti + cr1i*str if (yy.gt.0.0d0) go to 20 znr = -znr zbi = -zbi 20 continue c----------------------------------------------------------------------- c k(fnu,z) is computed from h(2,fnu,-i*z) where z is in the first c quadrant. fourth quadrant values (yy.le.0.0e0) are computed by c conjugation since the k function is real on the positive real axis c----------------------------------------------------------------------- j = 2 do 80 i=1,n c----------------------------------------------------------------------- c j flip flops between 1 and 2 in j = 3 - j c----------------------------------------------------------------------- j = 3 - j fn = fnu + dble(float(i-1)) call zunhj(znr, zni, fn, 0, tol, phir(j), phii(j), argr(j), * argi(j), zeta1r(j), zeta1i(j), zeta2r(j), zeta2i(j), asumr(j), * asumi(j), bsumr(j), bsumi(j)) if (kode.eq.1) go to 30 str = zbr + zeta2r(j) sti = zbi + zeta2i(j) rast = fn/zabs2(str,sti) str = str*rast*rast sti = -sti*rast*rast s1r = zeta1r(j) - str s1i = zeta1i(j) - sti go to 40 30 continue s1r = zeta1r(j) - zeta2r(j) s1i = zeta1i(j) - zeta2i(j) 40 continue c----------------------------------------------------------------------- c test for underflow and overflow c----------------------------------------------------------------------- rs1 = s1r if (dabs(rs1).gt.elim) go to 70 if (kdflg.eq.1) kflag = 2 if (dabs(rs1).lt.alim) go to 50 c----------------------------------------------------------------------- c refine test and scale c----------------------------------------------------------------------- aphi = zabs2(phir(j),phii(j)) aarg = zabs2(argr(j),argi(j)) rs1 = rs1 + dlog(aphi) - 0.25d0*dlog(aarg) - aic if (dabs(rs1).gt.elim) go to 70 if (kdflg.eq.1) kflag = 1 if (rs1.lt.0.0d0) go to 50 if (kdflg.eq.1) kflag = 3 50 continue c----------------------------------------------------------------------- c scale s1 to keep intermediate arithmetic on scale near c exponent extremes c----------------------------------------------------------------------- c2r = argr(j)*cr2r - argi(j)*cr2i c2i = argr(j)*cr2i + argi(j)*cr2r call zairy(c2r, c2i, 0, 2, air, aii, nai, idum) call zairy(c2r, c2i, 1, 2, dair, daii, ndai, idum) str = dair*bsumr(j) - daii*bsumi(j) sti = dair*bsumi(j) + daii*bsumr(j) ptr = str*cr2r - sti*cr2i pti = str*cr2i + sti*cr2r str = ptr + (air*asumr(j)-aii*asumi(j)) sti = pti + (air*asumi(j)+aii*asumr(j)) ptr = str*phir(j) - sti*phii(j) pti = str*phii(j) + sti*phir(j) s2r = ptr*csr - pti*csi s2i = ptr*csi + pti*csr str = dexp(s1r)*cssr(kflag) s1r = str*dcos(s1i) s1i = str*dsin(s1i) str = s2r*s1r - s2i*s1i s2i = s1r*s2i + s2r*s1i s2r = str if (kflag.ne.1) go to 60 call zuchk(s2r, s2i, nw, bry(1), tol) if (nw.ne.0) go to 70 60 continue if (yy.le.0.0d0) s2i = -s2i cyr(kdflg) = s2r cyi(kdflg) = s2i yr(i) = s2r*csrr(kflag) yi(i) = s2i*csrr(kflag) str = csi csi = -csr csr = str if (kdflg.eq.2) go to 85 kdflg = 2 go to 80 70 continue if (rs1.gt.0.0d0) go to 320 c----------------------------------------------------------------------- c for zr.lt.0.0, the i function to be added will overflow c----------------------------------------------------------------------- if (zr.lt.0.0d0) go to 320 kdflg = 1 yr(i)=zeror yi(i)=zeroi nz=nz+1 str = csi csi =-csr csr = str if (i.eq.1) go to 80 if ((yr(i-1).eq.zeror).and.(yi(i-1).eq.zeroi)) go to 80 yr(i-1)=zeror yi(i-1)=zeroi nz=nz+1 80 continue i = n 85 continue razr = 1.0d0/zabs2(zrr,zri) str = zrr*razr sti = -zri*razr rzr = (str+str)*razr rzi = (sti+sti)*razr ckr = fn*rzr cki = fn*rzi ib = i + 1 if (n.lt.ib) go to 180 c----------------------------------------------------------------------- c test last member for underflow and overflow. set sequence to zero c on underflow. c----------------------------------------------------------------------- fn = fnu + dble(float(n-1)) ipard = 1 if (mr.ne.0) ipard = 0 call zunhj(znr, zni, fn, ipard, tol, phidr, phidi, argdr, argdi, * zet1dr, zet1di, zet2dr, zet2di, asumdr, asumdi, bsumdr, bsumdi) if (kode.eq.1) go to 90 str = zbr + zet2dr sti = zbi + zet2di rast = fn/zabs2(str,sti) str = str*rast*rast sti = -sti*rast*rast s1r = zet1dr - str s1i = zet1di - sti go to 100 90 continue s1r = zet1dr - zet2dr s1i = zet1di - zet2di 100 continue rs1 = s1r if (dabs(rs1).gt.elim) go to 105 if (dabs(rs1).lt.alim) go to 120 c---------------------------------------------------------------------------- c refine estimate and test c------------------------------------------------------------------------- aphi = zabs2(phidr,phidi) rs1 = rs1+dlog(aphi) if (dabs(rs1).lt.elim) go to 120 105 continue if (rs1.gt.0.0d0) go to 320 c----------------------------------------------------------------------- c for zr.lt.0.0, the i function to be added will overflow c----------------------------------------------------------------------- if (zr.lt.0.0d0) go to 320 nz = n do 106 i=1,n yr(i) = zeror yi(i) = zeroi 106 continue return 120 continue s1r = cyr(1) s1i = cyi(1) s2r = cyr(2) s2i = cyi(2) c1r = csrr(kflag) ascle = bry(kflag) do 130 i=ib,n c2r = s2r c2i = s2i s2r = ckr*c2r - cki*c2i + s1r s2i = ckr*c2i + cki*c2r + s1i s1r = c2r s1i = c2i ckr = ckr + rzr cki = cki + rzi c2r = s2r*c1r c2i = s2i*c1r yr(i) = c2r yi(i) = c2i if (kflag.ge.3) go to 130 str = dabs(c2r) sti = dabs(c2i) c2m = dmax1(str,sti) if (c2m.le.ascle) go to 130 kflag = kflag + 1 ascle = bry(kflag) s1r = s1r*c1r s1i = s1i*c1r s2r = c2r s2i = c2i s1r = s1r*cssr(kflag) s1i = s1i*cssr(kflag) s2r = s2r*cssr(kflag) s2i = s2i*cssr(kflag) c1r = csrr(kflag) 130 continue 180 continue if (mr.eq.0) return c----------------------------------------------------------------------- c analytic continuation for re(z).lt.0.0d0 c----------------------------------------------------------------------- nz = 0 fmr = dble(float(mr)) sgn = -dsign(pi,fmr) c----------------------------------------------------------------------- c cspn and csgn are coeff of k and i funcions resp. c----------------------------------------------------------------------- csgni = sgn if (yy.le.0.0d0) csgni = -csgni ifn = inu + n - 1 ang = fnf*sgn cspnr = dcos(ang) cspni = dsin(ang) if (mod(ifn,2).eq.0) go to 190 cspnr = -cspnr cspni = -cspni 190 continue c----------------------------------------------------------------------- c cs=coeff of the j function to get the i function. i(fnu,z) is c computed from exp(i*fnu*hpi)*j(fnu,-i*z) where z is in the first c quadrant. fourth quadrant values (yy.le.0.0e0) are computed by c conjugation since the i function is real on the positive real axis c----------------------------------------------------------------------- csr = sar*csgni csi = car*csgni in = mod(ifn,4) + 1 c2r = cipr(in) c2i = cipi(in) str = csr*c2r + csi*c2i csi = -csr*c2i + csi*c2r csr = str asc = bry(1) iuf = 0 kk = n kdflg = 1 ib = ib - 1 ic = ib - 1 do 290 k=1,n fn = fnu + dble(float(kk-1)) c----------------------------------------------------------------------- c logic to sort out cases whose parameters were set for the k c function above c----------------------------------------------------------------------- if (n.gt.2) go to 175 172 continue phidr = phir(j) phidi = phii(j) argdr = argr(j) argdi = argi(j) zet1dr = zeta1r(j) zet1di = zeta1i(j) zet2dr = zeta2r(j) zet2di = zeta2i(j) asumdr = asumr(j) asumdi = asumi(j) bsumdr = bsumr(j) bsumdi = bsumi(j) j = 3 - j go to 210 175 continue if ((kk.eq.n).and.(ib.lt.n)) go to 210 if ((kk.eq.ib).or.(kk.eq.ic)) go to 172 call zunhj(znr, zni, fn, 0, tol, phidr, phidi, argdr, * argdi, zet1dr, zet1di, zet2dr, zet2di, asumdr, * asumdi, bsumdr, bsumdi) 210 continue if (kode.eq.1) go to 220 str = zbr + zet2dr sti = zbi + zet2di rast = fn/zabs2(str,sti) str = str*rast*rast sti = -sti*rast*rast s1r = -zet1dr + str s1i = -zet1di + sti go to 230 220 continue s1r = -zet1dr + zet2dr s1i = -zet1di + zet2di 230 continue c----------------------------------------------------------------------- c test for underflow and overflow c----------------------------------------------------------------------- rs1 = s1r if (dabs(rs1).gt.elim) go to 280 if (kdflg.eq.1) iflag = 2 if (dabs(rs1).lt.alim) go to 240 c----------------------------------------------------------------------- c refine test and scale c----------------------------------------------------------------------- aphi = zabs2(phidr,phidi) aarg = zabs2(argdr,argdi) rs1 = rs1 + dlog(aphi) - 0.25d0*dlog(aarg) - aic if (dabs(rs1).gt.elim) go to 280 if (kdflg.eq.1) iflag = 1 if (rs1.lt.0.0d0) go to 240 if (kdflg.eq.1) iflag = 3 240 continue call zairy(argdr, argdi, 0, 2, air, aii, nai, idum) call zairy(argdr, argdi, 1, 2, dair, daii, ndai, idum) str = dair*bsumdr - daii*bsumdi sti = dair*bsumdi + daii*bsumdr str = str + (air*asumdr-aii*asumdi) sti = sti + (air*asumdi+aii*asumdr) ptr = str*phidr - sti*phidi pti = str*phidi + sti*phidr s2r = ptr*csr - pti*csi s2i = ptr*csi + pti*csr str = dexp(s1r)*cssr(iflag) s1r = str*dcos(s1i) s1i = str*dsin(s1i) str = s2r*s1r - s2i*s1i s2i = s2r*s1i + s2i*s1r s2r = str if (iflag.ne.1) go to 250 call zuchk(s2r, s2i, nw, bry(1), tol) if (nw.eq.0) go to 250 s2r = zeror s2i = zeroi 250 continue if (yy.le.0.0d0) s2i = -s2i cyr(kdflg) = s2r cyi(kdflg) = s2i c2r = s2r c2i = s2i s2r = s2r*csrr(iflag) s2i = s2i*csrr(iflag) c----------------------------------------------------------------------- c add i and k functions, k sequence in y(i), i=1,n c----------------------------------------------------------------------- s1r = yr(kk) s1i = yi(kk) if (kode.eq.1) go to 270 call zs1s2(zrr, zri, s1r, s1i, s2r, s2i, nw, asc, alim, iuf) nz = nz + nw 270 continue yr(kk) = s1r*cspnr - s1i*cspni + s2r yi(kk) = s1r*cspni + s1i*cspnr + s2i kk = kk - 1 cspnr = -cspnr cspni = -cspni str = csi csi = -csr csr = str if (c2r.ne.0.0d0 .or. c2i.ne.0.0d0) go to 255 kdflg = 1 go to 290 255 continue if (kdflg.eq.2) go to 295 kdflg = 2 go to 290 280 continue if (rs1.gt.0.0d0) go to 320 s2r = zeror s2i = zeroi go to 250 290 continue k = n 295 continue il = n - k if (il.eq.0) return c----------------------------------------------------------------------- c recur backward for remainder of i sequence and add in the c k functions, scaling the i sequence during recurrence to keep c intermediate arithmetic on scale near exponent extremes. c----------------------------------------------------------------------- s1r = cyr(1) s1i = cyi(1) s2r = cyr(2) s2i = cyi(2) csr = csrr(iflag) ascle = bry(iflag) fn = dble(float(inu+il)) do 310 i=1,il c2r = s2r c2i = s2i s2r = s1r + (fn+fnf)*(rzr*c2r-rzi*c2i) s2i = s1i + (fn+fnf)*(rzr*c2i+rzi*c2r) s1r = c2r s1i = c2i fn = fn - 1.0d0 c2r = s2r*csr c2i = s2i*csr ckr = c2r cki = c2i c1r = yr(kk) c1i = yi(kk) if (kode.eq.1) go to 300 call zs1s2(zrr, zri, c1r, c1i, c2r, c2i, nw, asc, alim, iuf) nz = nz + nw 300 continue yr(kk) = c1r*cspnr - c1i*cspni + c2r yi(kk) = c1r*cspni + c1i*cspnr + c2i kk = kk - 1 cspnr = -cspnr cspni = -cspni if (iflag.ge.3) go to 310 c2r = dabs(ckr) c2i = dabs(cki) c2m = dmax1(c2r,c2i) if (c2m.le.ascle) go to 310 iflag = iflag + 1 ascle = bry(iflag) s1r = s1r*csr s1i = s1i*csr s2r = ckr s2i = cki s1r = s1r*cssr(iflag) s1i = s1i*cssr(iflag) s2r = s2r*cssr(iflag) s2i = s2i*cssr(iflag) csr = csrr(iflag) 310 continue return 320 continue nz = -1 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zuoik(zr, zi, fnu, kode, ikflg, n, yr, yi, nuf, tol, * elim, alim) c geuz for g77 EXTERNAL zlog c refer to zbesi,zbesk,zbesh c c zuoik computes the leading terms of the uniform asymptotic c expansions for the i and k functions and compares them c (in logarithmic form) to alim and elim for over and underflow c where alim.lt.elim. if the magnitude, based on the leading c exponential, is less than alim or greater than -alim, then c the result is on scale. if not, then a refined test using other c multipliers (in logarithmic form) is made based on elim. here c exp(-elim)=smallest machine number*1.0e+3 and exp(-alim)= c exp(-elim)/tol c c ikflg=1 means the i sequence is tested c =2 means the k sequence is tested c nuf = 0 means the last member of the sequence is on scale c =-1 means an overflow would occur c ikflg=1 and nuf.gt.0 means the last nuf y values were set to zero c the first n-nuf values must be set by another routine c ikflg=2 and nuf.eq.n means all y values were set to zero c ikflg=2 and 0.lt.nuf.lt.n not considered. y must be set by c another routine c c***routines called zuchk,zunhj,zunik,d1mach,zabs2,zlog c complex arg,asum,bsum,cwrk,cz,czero,phi,sum,y,z,zb,zeta1,zeta2,zn, c *zr double precision aarg, aic, alim, aphi, argi, argr, asumi, asumr, * ascle, ax, ay, bsumi, bsumr, cwrki, cwrkr, czi, czr, elim, fnn, * fnu, gnn, gnu, phii, phir, rcz, str, sti, sumi, sumr, tol, yi, * yr, zbi, zbr, zeroi, zeror, zeta1i, zeta1r, zeta2i, zeta2r, zi, * zni, znr, zr, zri, zrr, d1mach, zabs2 integer i, idum, iform, ikflg, init, kode, n, nn, nuf, nw dimension yr(n), yi(n), cwrkr(16), cwrki(16) data zeror,zeroi / 0.0d0, 0.0d0 / data aic / 1.265512123484645396d+00 / nuf = 0 nn = n zrr = zr zri = zi if (zr.ge.0.0d0) go to 10 zrr = -zr zri = -zi 10 continue zbr = zrr zbi = zri ax = dabs(zr)*1.7321d0 ay = dabs(zi) iform = 1 if (ay.gt.ax) iform = 2 gnu = dmax1(fnu,1.0d0) if (ikflg.eq.1) go to 20 fnn = dble(float(nn)) gnn = fnu + fnn - 1.0d0 gnu = dmax1(gnn,fnn) 20 continue c----------------------------------------------------------------------- c only the magnitude of arg and phi are needed along with the c real parts of zeta1, zeta2 and zb. no attempt is made to get c the sign of the imaginary part correct. c----------------------------------------------------------------------- if (iform.eq.2) go to 30 init = 0 call zunik(zrr, zri, gnu, ikflg, 1, tol, init, phir, phii, * zeta1r, zeta1i, zeta2r, zeta2i, sumr, sumi, cwrkr, cwrki) czr = -zeta1r + zeta2r czi = -zeta1i + zeta2i go to 50 30 continue znr = zri zni = -zrr if (zi.gt.0.0d0) go to 40 znr = -znr 40 continue call zunhj(znr, zni, gnu, 1, tol, phir, phii, argr, argi, zeta1r, * zeta1i, zeta2r, zeta2i, asumr, asumi, bsumr, bsumi) czr = -zeta1r + zeta2r czi = -zeta1i + zeta2i aarg = zabs2(argr,argi) 50 continue if (kode.eq.1) go to 60 czr = czr - zbr czi = czi - zbi 60 continue if (ikflg.eq.1) go to 70 czr = -czr czi = -czi 70 continue aphi = zabs2(phir,phii) rcz = czr c----------------------------------------------------------------------- c overflow test c----------------------------------------------------------------------- if (rcz.gt.elim) go to 210 if (rcz.lt.alim) go to 80 rcz = rcz + dlog(aphi) if (iform.eq.2) rcz = rcz - 0.25d0*dlog(aarg) - aic if (rcz.gt.elim) go to 210 go to 130 80 continue c----------------------------------------------------------------------- c underflow test c----------------------------------------------------------------------- if (rcz.lt.(-elim)) go to 90 if (rcz.gt.(-alim)) go to 130 rcz = rcz + dlog(aphi) if (iform.eq.2) rcz = rcz - 0.25d0*dlog(aarg) - aic if (rcz.gt.(-elim)) go to 110 90 continue do 100 i=1,nn yr(i) = zeror yi(i) = zeroi 100 continue nuf = nn return 110 continue ascle = 1.0d+3*d1mach(1)/tol call zlog(phir, phii, str, sti, idum) czr = czr + str czi = czi + sti if (iform.eq.1) go to 120 call zlog(argr, argi, str, sti, idum) czr = czr - 0.25d0*str - aic czi = czi - 0.25d0*sti 120 continue ax = dexp(rcz)/tol ay = czi czr = ax*dcos(ay) czi = ax*dsin(ay) call zuchk(czr, czi, nw, ascle, tol) if (nw.ne.0) go to 90 130 continue if (ikflg.eq.2) return if (n.eq.1) return c----------------------------------------------------------------------- c set underflows on i sequence c----------------------------------------------------------------------- 140 continue gnu = fnu + dble(float(nn-1)) if (iform.eq.2) go to 150 init = 0 call zunik(zrr, zri, gnu, ikflg, 1, tol, init, phir, phii, * zeta1r, zeta1i, zeta2r, zeta2i, sumr, sumi, cwrkr, cwrki) czr = -zeta1r + zeta2r czi = -zeta1i + zeta2i go to 160 150 continue call zunhj(znr, zni, gnu, 1, tol, phir, phii, argr, argi, zeta1r, * zeta1i, zeta2r, zeta2i, asumr, asumi, bsumr, bsumi) czr = -zeta1r + zeta2r czi = -zeta1i + zeta2i aarg = zabs2(argr,argi) 160 continue if (kode.eq.1) go to 170 czr = czr - zbr czi = czi - zbi 170 continue aphi = zabs2(phir,phii) rcz = czr if (rcz.lt.(-elim)) go to 180 if (rcz.gt.(-alim)) return rcz = rcz + dlog(aphi) if (iform.eq.2) rcz = rcz - 0.25d0*dlog(aarg) - aic if (rcz.gt.(-elim)) go to 190 180 continue yr(nn) = zeror yi(nn) = zeroi nn = nn - 1 nuf = nuf + 1 if (nn.eq.0) return go to 140 190 continue ascle = 1.0d+3*d1mach(1)/tol call zlog(phir, phii, str, sti, idum) czr = czr + str czi = czi + sti if (iform.eq.1) go to 200 call zlog(argr, argi, str, sti, idum) czr = czr - 0.25d0*str - aic czi = czi - 0.25d0*sti 200 continue ax = dexp(rcz)/tol ay = czi czr = ax*dcos(ay) czi = ax*dsin(ay) call zuchk(czr, czi, nw, ascle, tol) if (nw.ne.0) go to 180 return 210 continue nuf = -1 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zbesj(zr, zi, fnu, kode, n, cyr, cyi, nz, ierr) c j-Bessel function of complex argument and first kind c Author Amos, Donald E., Sandia National Laboratories c c on kode=1, cbesj computes an n member sequence of complex c bessel functions cy(i)=j(fnu+i-1,z) for real, nonnegative c orders fnu+i-1, i=1,...,n and complex z in the cut plane c -pi.lt.arg(z).le.pi. on kode=2, cbesj returns the scaled c functions c c cy(i)=exp(-abs(y))*j(fnu+i-1,z) i = 1,...,n , y=aimag(z) c c which remove the exponential growth in both the upper and c lower half planes for z to infinity. c c Input zr,zi,fnu are double precision c zr,zi - z=cmplx(zr,zi), -pi.lt.arg(z).le.pi c fnu - order of initial j function, fnu.ge.0.0d0 c kode - a parameter to indicate the scaling option c kode= 1 returns c cy(i)=j(fnu+i-1,z), i=1,...,n c = 2 returns c cy(i)=j(fnu+i-1,z)exp(-abs(y)), i=1,...,n c n - number of members of the sequence, n.ge.1 c c Output cyr,cyi are double precision c cyr,cyi- double precision vectors whose first n components c contain real and imaginary parts for the sequence c cy(i)=j(fnu+i-1,z) or c cy(i)=j(fnu+i-1,z)exp(-abs(y)) i=1,...,n c depending on kode, y=aimag(z). c nz - number of components set to zero due to underflow, c nz= 0 , normal return c nz.gt.0 , last nz components of cy set zero due c to underflow, cy(i)=cmplx(0.0d0,0.0d0), c i = n-nz+1,...,n c ierr - error flag c ierr=0, normal return - computation completed c ierr=1, input error - no computation c ierr=2, overflow - no computation, aimag(z) c too large on kode=1 c ierr=3, cabs(z) or fnu+n-1 large - computation done c but losses of signifcance by argument c reduction produce less than half of machine c accuracy c ierr=4, cabs(z) or fnu+n-1 too large - no computa- c tion because of complete losses of signifi- c cance by argument reduction c ierr=5, error - no computation, c algorithm termination condition not met c c c the computation is carried out by the formula c c j(fnu,z)=exp( fnu*pi*i/2)*i(fnu,-i*z) aimag(z).ge.0.0 c c j(fnu,z)=exp(-fnu*pi*i/2)*i(fnu, i*z) aimag(z).lt.0.0 c c where i**2 = -1 and i(fnu,z) is the i bessel function. c c for negative orders,the formula c c j(-fnu,z) = j(fnu,z)*cos(pi*fnu) - y(fnu,z)*sin(pi*fnu) c c can be used. however,for large orders close to integers, the c the function changes radically. when fnu is a large positive c integer,the magnitude of j(-fnu,z)=j(fnu,z)*cos(pi*fnu) is a c large negative power of ten. but when fnu is not an integer, c y(fnu,z) dominates in magnitude with a large positive power of c ten and the most that the second term can be reduced is by c unit roundoff from the coefficient. thus, wide changes can c occur within unit roundoff of a large integer for fnu. here, c large means fnu.gt.cabs(z). c c in most complex variable computation, one must evaluate ele- c mentary functions. when the magnitude of z or fnu+n-1 is c large, losses of significance by argument reduction occur. c consequently, if either one exceeds u1=sqrt(0.5/ur), then c losses exceeding half precision are likely and an error flag c ierr=3 is triggered where ur=dmax1(d1mach(4),1.0d-18) is c double precision unit roundoff limited to 18 digits precision. c if either is larger than u2=0.5/ur, then all significance is c lost and ierr=4. in order to use the int function, arguments c must be further restricted not to exceed the largest machine c integer, u3=i1mach(9). thus, the magnitude of z and fnu+n-1 is c restricted by min(u2,u3). on 32 bit machines, u1,u2, and u3 c are approximately 2.0e+3, 4.2e+6, 2.1e+9 in single precision c arithmetic and 1.3e+8, 1.8e+16, 2.1e+9 in double precision c arithmetic respectively. this makes u2 and u3 limiting in c their respective arithmetics. this means that one can expect c to retain, in the worst cases on 32 bit machines, no digits c in single and only 7 digits in double precision arithmetic. c similar considerations hold for other machines. c c the approximate relative error in the magnitude of a complex c bessel function can be expressed by p*10**s where p=max(unit c roundoff,1.0e-18) is the nominal precision and 10**s repre- c sents the increase in error due to argument reduction in the c elementary functions. here, s=max(1,abs(log10(cabs(z))), c abs(log10(fnu))) approximately (i.e. s=max(1,abs(exponent of c cabs(z),abs(exponent of fnu)) ). however, the phase angle may c have only absolute accuracy. this is most likely to occur when c one component (in absolute value) is larger than the other by c several orders of magnitude. if one component is 10**k larger c than the other, then one can expect only max(abs(log10(p))-k, c 0) significant digits; or, stated another way, when k exceeds c the exponent of p, no significant digits remain in the smaller c component. however, the phase angle retains absolute accuracy c because, in complex arithmetic with precision p, the smaller c component will not (as a rule) decrease below p times the c magnitude of the larger component. in these extreme cases, c the principal phase angle is on the order of +p, -p, pi/2-p, c or -pi/2+p. c c***routines called zbinu,i1mach,d1mach c c complex ci,csgn,cy,z,zn double precision aa, alim, arg, cii, csgni, csgnr, cyi, cyr, dig, * elim, fnu, fnul, hpi, rl, r1m5, str, tol, zi, zni, znr, zr, * d1mach, bb, fn, az, zabs2, ascle, rtol, atol, sti integer i, ierr, inu, inuh, ir, k, kode, k1, k2, n, nl, nz, i1mach dimension cyr(n), cyi(n) data hpi /1.57079632679489662d0/ c write(*,*)'zr, zi, fnu, kode, n, nz',zr, zi, fnu, kode, n,nz c write(*,*)'cyr',(cyr(i),i=1,n) c write(*,*)'cyi',(cyi(i),i=1,n) c ierr = 0 nz=0 if (fnu.lt.0.0d0) ierr=1 if (kode.lt.1 .or. kode.gt.2) ierr=1 if (n.lt.1) ierr=1 if (ierr.ne.0) return c----------------------------------------------------------------------- c set parameters related to machine constants. c tol is the approximate unit roundoff limited to 1.0e-18. c elim is the approximate exponential over- and underflow limit. c exp(-elim).lt.exp(-alim)=exp(-elim)/tol and c exp(elim).gt.exp(alim)=exp(elim)*tol are intervals near c underflow and overflow limits where scaled arithmetic is done. c rl is the lower boundary of the asymptotic expansion for large z. c dig = number of base 10 digits in tol = 10**(-dig). c fnul is the lower boundary of the asymptotic series for large fnu. c----------------------------------------------------------------------- tol = dmax1(d1mach(4),1.0d-18) k1 = i1mach(15) k2 = i1mach(16) r1m5 = d1mach(5) k = min0(iabs(k1),iabs(k2)) elim = 2.303d0*(dble(float(k))*r1m5-3.0d0) k1 = i1mach(14) - 1 aa = r1m5*dble(float(k1)) dig = dmin1(aa,18.0d0) aa = aa*2.303d0 alim = elim + dmax1(-aa,-41.45d0) rl = 1.2d0*dig + 3.0d0 fnul = 10.0d0 + 6.0d0*(dig-3.0d0) c----------------------------------------------------------------------- c test for proper range c----------------------------------------------------------------------- az = zabs2(zr,zi) fn = fnu+dble(float(n-1)) aa = 0.5d0/tol bb=dble(float(i1mach(9)))*0.5d0 aa = dmin1(aa,bb) if (az.gt.aa) go to 260 if (fn.gt.aa) go to 260 aa = dsqrt(aa) if (az.gt.aa) ierr=3 if (fn.gt.aa) ierr=3 c----------------------------------------------------------------------- c calculate csgn=exp(fnu*hpi*i) to minimize losses of significance c when fnu is large c----------------------------------------------------------------------- cii = 1.0d0 inu = int(sngl(fnu)) inuh = inu/2 ir = inu - 2*inuh arg = (fnu-dble(float(inu-ir)))*hpi csgnr = dcos(arg) csgni = dsin(arg) if (mod(inuh,2).eq.0) go to 40 csgnr = -csgnr csgni = -csgni 40 continue c----------------------------------------------------------------------- c zn is in the right half plane c----------------------------------------------------------------------- znr = zi zni = -zr if (zi.ge.0.0d0) go to 50 znr = -znr zni = -zni csgni = -csgni cii = -cii 50 continue call zbinu(znr, zni, fnu, kode, n, cyr, cyi, nz, rl, fnul, tol, * elim, alim) if (nz.lt.0) go to 130 nl = n - nz if (nl.eq.0) return rtol = 1.0d0/tol ascle = d1mach(1)*rtol*1.0d+3 do 60 i=1,nl c str = cyr(i)*csgnr - cyi(i)*csgni c cyi(i) = cyr(i)*csgni + cyi(i)*csgnr c cyr(i) = str aa = cyr(i) bb = cyi(i) atol = 1.0d0 if (dmax1(dabs(aa),dabs(bb)).gt.ascle) go to 55 aa = aa*rtol bb = bb*rtol atol = tol 55 continue str = aa*csgnr - bb*csgni sti = aa*csgni + bb*csgnr cyr(i) = str*atol cyi(i) = sti*atol str = -csgni*cii csgni = csgnr*cii csgnr = str 60 continue return 130 continue if(nz.eq.(-2)) go to 140 nz = 0 ierr = 2 return 140 continue nz=0 ierr=5 return 260 continue nz=0 ierr=4 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zbesy(zr, zi, fnu, kode, n, cyr, cyi, nz, cwrkr, cwrki, * ierr) c y-Bessel function of complex argument and of second kind c Author Amos, Donald E., Sandia National Laboratories c c on kode=1, cbesy computes an n member sequence of complex c bessel functions cy(i)=y(fnu+i-1,z) for real, nonnegative c orders fnu+i-1, i=1,...,n and complex z in the cut plane c -pi.lt.arg(z).le.pi. on kode=2, cbesy returns the scaled c functions c c cy(i)=exp(-abs(y))*y(fnu+i-1,z) i = 1,...,n , y=aimag(z) c c which remove the exponential growth in both the upper and c lower half planes for z to infinity. c c input zr,zi,fnu are double precision c zr,zi - z=cmplx(zr,zi), z.ne.cmplx(0.0d0,0.0d0), c -pi.lt.arg(z).le.pi c fnu - order of initial y function, fnu.ge.0.0d0 c kode - a parameter to indicate the scaling option c kode= 1 returns c cy(i)=y(fnu+i-1,z), i=1,...,n c = 2 returns c cy(i)=y(fnu+i-1,z)*exp(-abs(y)), i=1,...,n c where y=aimag(z) c n - number of members of the sequence, n.ge.1 c cwrkr, - double precision work vectors of dimension at c cwrki at least n c c output cyr,cyi are double precision c cyr,cyi- double precision vectors whose first n components c contain real and imaginary parts for the sequence c cy(i)=y(fnu+i-1,z) or c cy(i)=y(fnu+i-1,z)*exp(-abs(y)) i=1,...,n c depending on kode. c nz - nz=0 , a normal return c nz.gt.0 , nz components of cy set to zero due to c underflow (generally on kode=2) c ierr - error flag c ierr=0, normal return - computation completed c ierr=1, input error - no computation c ierr=2, overflow - no computation, fnu is c too large or cabs(z) is too small or both c ierr=3, cabs(z) or fnu+n-1 large - computation done c but losses of signifcance by argument c reduction produce less than half of machine c accuracy c ierr=4, cabs(z) or fnu+n-1 too large - no computa- c tion because of complete losses of signifi- c cance by argument reduction c ierr=5, error - no computation, c algorithm termination condition not met c c c the computation is carried out by the formula c c y(fnu,z)=0.5*(h(1,fnu,z)-h(2,fnu,z))/i c c where i**2 = -1 and the hankel bessel functions h(1,fnu,z) c and h(2,fnu,z) are calculated in cbesh. c c for negative orders,the formula c c y(-fnu,z) = y(fnu,z)*cos(pi*fnu) + j(fnu,z)*sin(pi*fnu) c c can be used. however,for large orders close to half odd c integers the function changes radically. when fnu is a large c positive half odd integer,the magnitude of y(-fnu,z)=j(fnu,z)* c sin(pi*fnu) is a large negative power of ten. but when fnu is c not a half odd integer, y(fnu,z) dominates in magnitude with a c large positive power of ten and the most that the second term c can be reduced is by unit roundoff from the coefficient. thus, c wide changes can occur within unit roundoff of a large half c odd integer. here, large means fnu.gt.cabs(z). c c in most complex variable computation, one must evaluate ele- c mentary functions. when the magnitude of z or fnu+n-1 is c large, losses of significance by argument reduction occur. c consequently, if either one exceeds u1=sqrt(0.5/ur), then c losses exceeding half precision are likely and an error flag c ierr=3 is triggered where ur=dmax1(d1mach(4),1.0d-18) is c double precision unit roundoff limited to 18 digits precision. c if either is larger than u2=0.5/ur, then all significance is c lost and ierr=4. in order to use the int function, arguments c must be further restricted not to exceed the largest machine c integer, u3=i1mach(9). thus, the magnitude of z and fnu+n-1 is c restricted by min(u2,u3). on 32 bit machines, u1,u2, and u3 c are approximately 2.0e+3, 4.2e+6, 2.1e+9 in single precision c arithmetic and 1.3e+8, 1.8e+16, 2.1e+9 in double precision c arithmetic respectively. this makes u2 and u3 limiting in c their respective arithmetics. this means that one can expect c to retain, in the worst cases on 32 bit machines, no digits c in single and only 7 digits in double precision arithmetic. c similar considerations hold for other machines. c c the approximate relative error in the magnitude of a complex c bessel function can be expressed by p*10**s where p=max(unit c roundoff,1.0e-18) is the nominal precision and 10**s repre- c sents the increase in error due to argument reduction in the c elementary functions. here, s=max(1,abs(log10(cabs(z))), c abs(log10(fnu))) approximately (i.e. s=max(1,abs(exponent of c cabs(z),abs(exponent of fnu)) ). however, the phase angle may c have only absolute accuracy. this is most likely to occur when c one component (in absolute value) is larger than the other by c several orders of magnitude. if one component is 10**k larger c than the other, then one can expect only max(abs(log10(p))-k, c 0) significant digits; or, stated another way, when k exceeds c the exponent of p, no significant digits remain in the smaller c component. however, the phase angle retains absolute accuracy c because, in complex arithmetic with precision p, the smaller c component will not (as a rule) decrease below p times the c magnitude of the larger component. in these extreme cases, c the principal phase angle is on the order of +p, -p, pi/2-p, c or -pi/2+p. c c***routines called zbesh,i1mach,d1mach c c complex cwrk,cy,c1,c2,ex,hci,z,zu,zv double precision cwrki, cwrkr, cyi, cyr, c1i, c1r, c2i, c2r, * elim, exi, exr, ey, fnu, hcii, sti, str, tay, zi, zr, dexp, * d1mach, ascle, rtol, atol, aa, bb, tol integer i, ierr, k, kode, k1, k2, n, nz, nz1, nz2, i1mach dimension cyr(n), cyi(n), cwrkr(n), cwrki(n) c ierr = 0 nz=0 if (zr.eq.0.0d0 .and. zi.eq.0.0d0) ierr=1 if (fnu.lt.0.0d0) ierr=1 if (kode.lt.1 .or. kode.gt.2) ierr=1 if (n.lt.1) ierr=1 if (ierr.ne.0) return hcii = 0.5d0 call zbesh(zr, zi, fnu, kode, 1, n, cyr, cyi, nz1, ierr) if (ierr.ne.0.and.ierr.ne.3) go to 170 call zbesh(zr, zi, fnu, kode, 2, n, cwrkr, cwrki, nz2, ierr) if (ierr.ne.0.and.ierr.ne.3) go to 170 nz = min0(nz1,nz2) if (kode.eq.2) go to 60 do 50 i=1,n str = cwrkr(i) - cyr(i) sti = cwrki(i) - cyi(i) cyr(i) = -sti*hcii cyi(i) = str*hcii 50 continue return 60 continue tol = dmax1(d1mach(4),1.0d-18) k1 = i1mach(15) k2 = i1mach(16) k = min0(iabs(k1),iabs(k2)) r1m5 = d1mach(5) c----------------------------------------------------------------------- c elim is the approximate exponential under- and overflow limit c----------------------------------------------------------------------- elim = 2.303d0*(dble(float(k))*r1m5-3.0d0) exr = dcos(zr) exi = dsin(zr) ey = 0.0d0 tay = dabs(zi+zi) if (tay.lt.elim) ey = dexp(-tay) if (zi.lt.0.0d0) go to 90 c1r = exr*ey c1i = exi*ey c2r = exr c2i = -exi 70 continue nz = 0 rtol = 1.0d0/tol ascle = d1mach(1)*rtol*1.0d+3 do 80 i=1,n c str = c1r*cyr(i) - c1i*cyi(i) c sti = c1r*cyi(i) + c1i*cyr(i) c str = -str + c2r*cwrkr(i) - c2i*cwrki(i) c sti = -sti + c2r*cwrki(i) + c2i*cwrkr(i) c cyr(i) = -sti*hcii c cyi(i) = str*hcii aa = cwrkr(i) bb = cwrki(i) atol = 1.0d0 if (dmax1(dabs(aa),dabs(bb)).gt.ascle) go to 75 aa = aa*rtol bb = bb*rtol atol = tol 75 continue str = (aa*c2r - bb*c2i)*atol sti = (aa*c2i + bb*c2r)*atol aa = cyr(i) bb = cyi(i) atol = 1.0d0 if (dmax1(dabs(aa),dabs(bb)).gt.ascle) go to 85 aa = aa*rtol bb = bb*rtol atol = tol 85 continue str = str - (aa*c1r - bb*c1i)*atol sti = sti - (aa*c1i + bb*c1r)*atol cyr(i) = -sti*hcii cyi(i) = str*hcii if (str.eq.0.0d0 .and. sti.eq.0.0d0 .and. ey.eq.0.0d0) nz = nz * + 1 80 continue return 90 continue c1r = exr c1i = exi c2r = exr*ey c2i = -exi*ey go to 70 170 continue nz = 0 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zbesh(zr, zi, fnu, kode, m, n, cyr, cyi, nz, ierr) c h-Bessel functions of complex argument and third kind,hankel functions c Author Amos, Donald E., Sandia National Laboratories c c on kode=1, zbesh computes an n member sequence of complex c hankel (bessel) functions cy(j)=h(m,fnu+j-1,z) for kinds m=1 c or 2, real, nonnegative orders fnu+j-1, j=1,...,n, and complex c z.ne.cmplx(0.0,0.0) in the cut plane -pi.lt.arg(z).le.pi. c on kode=2, zbesh returns the scaled hankel functions c c cy(i)=exp(-mm*z*i)*h(m,fnu+j-1,z) mm=3-2*m, i**2=-1. c c which removes the exponential behavior in both the upper and c lower half planes. c c input zr,zi,fnu are double precision c zr,zi - z=cmplx(zr,zi), z.ne.cmplx(0.0d0,0.0d0), c -pt.lt.arg(z).le.pi c fnu - order of initial h function, fnu.ge.0.0d0 c kode - a parameter to indicate the scaling option c kode= 1 returns c cy(j)=h(m,fnu+j-1,z), j=1,...,n c = 2 returns c cy(j)=h(m,fnu+j-1,z)*exp(-i*z*(3-2m)) c j=1,...,n , i**2=-1 c m - kind of hankel function, m=1 or 2 c n - number of members in the sequence, n.ge.1 c c output cyr,cyi are double precision c cyr,cyi- double precision vectors whose first n components c contain real and imaginary parts for the sequence c cy(j)=h(m,fnu+j-1,z) or c cy(j)=h(m,fnu+j-1,z)*exp(-i*z*(3-2m)) j=1,...,n c depending on kode, i**2=-1. c nz - number of components set to zero due to underflow, c nz= 0 , normal return c nz.gt.0 , first nz components of cy set to zero due c to underflow, cy(j)=cmplx(0.0d0,0.0d0) c j=1,...,nz when y.gt.0.0 and m=1 or c y.lt.0.0 and m=2. for the complmentary c half planes, nz states only the number c of underflows. c ierr - error flag c ierr=0, normal return - computation completed c ierr=1, input error - no computation c ierr=2, overflow - no computation, fnu too c large or cabs(z) too small or both c ierr=3, cabs(z) or fnu+n-1 large - computation done c but losses of signifcance by argument c reduction produce less than half of machine c accuracy c ierr=4, cabs(z) or fnu+n-1 too large - no computa- c tion because of complete losses of signifi- c cance by argument reduction c ierr=5, error - no computation, c algorithm termination condition not met c c c the computation is carried out by the relation c c h(m,fnu,z)=(1/mp)*exp(-mp*fnu)*k(fnu,z*exp(-mp)) c mp=mm*hpi*i, mm=3-2*m, hpi=pi/2, i**2=-1 c c for m=1 or 2 where the k bessel function is computed for the c right half plane re(z).ge.0.0. the k function is continued c to the left half plane by the relation c c k(fnu,z*exp(mp)) = exp(-mp*fnu)*k(fnu,z)-mp*i(fnu,z) c mp=mr*pi*i, mr=+1 or -1, re(z).gt.0, i**2=-1 c c where i(fnu,z) is the i bessel function. c c exponential decay of h(m,fnu,z) occurs in the upper half z c plane for m=1 and the lower half z plane for m=2. exponential c growth occurs in the complementary half planes. scaling c by exp(-mm*z*i) removes the exponential behavior in the c whole z plane for z to infinity. c c for negative orders,the formulae c c h(1,-fnu,z) = h(1,fnu,z)*cexp( pi*fnu*i) c h(2,-fnu,z) = h(2,fnu,z)*cexp(-pi*fnu*i) c i**2=-1 c c can be used. c c in most complex variable computation, one must evaluate ele- c mentary functions. when the magnitude of z or fnu+n-1 is c large, losses of significance by argument reduction occur. c consequently, if either one exceeds u1=sqrt(0.5/ur), then c losses exceeding half precision are likely and an error flag c ierr=3 is triggered where ur=dmax1(d1mach(4),1.0d-18) is c double precision unit roundoff limited to 18 digits precision. c if either is larger than u2=0.5/ur, then all significance is c lost and ierr=4. in order to use the int function, arguments c must be further restricted not to exceed the largest machine c integer, u3=i1mach(9). thus, the magnitude of z and fnu+n-1 is c restricted by min(u2,u3). on 32 bit machines, u1,u2, and u3 c are approximately 2.0e+3, 4.2e+6, 2.1e+9 in single precision c arithmetic and 1.3e+8, 1.8e+16, 2.1e+9 in double precision c arithmetic respectively. this makes u2 and u3 limiting in c their respective arithmetics. this means that one can expect c to retain, in the worst cases on 32 bit machines, no digits c in single and only 7 digits in double precision arithmetic. c similar considerations hold for other machines. c c the approximate relative error in the magnitude of a complex c bessel function can be expressed by p*10**s where p=max(unit c roundoff,1.0d-18) is the nominal precision and 10**s repre- c sents the increase in error due to argument reduction in the c elementary functions. here, s=max(1,abs(log10(cabs(z))), c abs(log10(fnu))) approximately (i.e. s=max(1,abs(exponent of c cabs(z),abs(exponent of fnu)) ). however, the phase angle may c have only absolute accuracy. this is most likely to occur when c one component (in absolute value) is larger than the other by c several orders of magnitude. if one component is 10**k larger c than the other, then one can expect only max(abs(log10(p))-k, c 0) significant digits; or, stated another way, when k exceeds c the exponent of p, no significant digits remain in the smaller c component. however, the phase angle retains absolute accuracy c because, in complex arithmetic with precision p, the smaller c component will not (as a rule) decrease below p times the c magnitude of the larger component. in these extreme cases, c the principal phase angle is on the order of +p, -p, pi/2-p, c or -pi/2+p. c c***routines called zacon,zbknu,zbunk,zuoik,zabs2,i1mach,d1mach c c complex cy,z,zn,zt,csgn double precision aa, alim, aln, arg, az, cyi, cyr, dig, elim, * fmm, fn, fnu, fnul, hpi, rhpi, rl, r1m5, sgn, str, tol, ufl, zi, * zni, znr, zr, zti, d1mach, zabs2, bb, ascle, rtol, atol, sti, * csgnr, csgni integer i, ierr, inu, inuh, ir, k, kode, k1, k2, m, * mm, mr, n, nn, nuf, nw, nz, i1mach dimension cyr(n), cyi(n) data hpi /1.57079632679489662d0/ c ierr = 0 nz=0 if (zr.eq.0.0d0 .and. zi.eq.0.0d0) ierr=1 if (fnu.lt.0.0d0) ierr=1 if (m.lt.1 .or. m.gt.2) ierr=1 if (kode.lt.1 .or. kode.gt.2) ierr=1 if (n.lt.1) ierr=1 if (ierr.ne.0) return nn = n c----------------------------------------------------------------------- c set parameters related to machine constants. c tol is the approximate unit roundoff limited to 1.0e-18. c elim is the approximate exponential over- and underflow limit. c exp(-elim).lt.exp(-alim)=exp(-elim)/tol and c exp(elim).gt.exp(alim)=exp(elim)*tol are intervals near c underflow and overflow limits where scaled arithmetic is done. c rl is the lower boundary of the asymptotic expansion for large z. c dig = number of base 10 digits in tol = 10**(-dig). c fnul is the lower boundary of the asymptotic series for large fnu c----------------------------------------------------------------------- tol = dmax1(d1mach(4),1.0d-18) k1 = i1mach(15) k2 = i1mach(16) r1m5 = d1mach(5) k = min0(iabs(k1),iabs(k2)) elim = 2.303d0*(dble(float(k))*r1m5-3.0d0) k1 = i1mach(14) - 1 aa = r1m5*dble(float(k1)) dig = dmin1(aa,18.0d0) aa = aa*2.303d0 alim = elim + dmax1(-aa,-41.45d0) fnul = 10.0d0 + 6.0d0*(dig-3.0d0) rl = 1.2d0*dig + 3.0d0 fn = fnu + dble(float(nn-1)) mm = 3 - m - m fmm = dble(float(mm)) znr = fmm*zi zni = -fmm*zr c----------------------------------------------------------------------- c test for proper range c----------------------------------------------------------------------- az = zabs2(zr,zi) aa = 0.5d0/tol bb=dble(float(i1mach(9)))*0.5d0 aa = dmin1(aa,bb) if (az.gt.aa) go to 260 if (fn.gt.aa) go to 260 aa = dsqrt(aa) if (az.gt.aa) ierr=3 if (fn.gt.aa) ierr=3 c----------------------------------------------------------------------- c overflow test on the last member of the sequence c----------------------------------------------------------------------- ufl = d1mach(1)*1.0d+3 if (az.lt.ufl) go to 230 if (fnu.gt.fnul) go to 90 if (fn.le.1.0d0) go to 70 if (fn.gt.2.0d0) go to 60 if (az.gt.tol) go to 70 arg = 0.5d0*az aln = -fn*dlog(arg) if (aln.gt.elim) go to 230 go to 70 60 continue call zuoik(znr, zni, fnu, kode, 2, nn, cyr, cyi, nuf, tol, elim, * alim) if (nuf.lt.0) go to 230 nz = nz + nuf nn = nn - nuf c----------------------------------------------------------------------- c here nn=n or nn=0 since nuf=0,nn, or -1 on return from cuoik c if nuf=nn, then cy(i)=czero for all i c----------------------------------------------------------------------- if (nn.eq.0) go to 140 70 continue if ((znr.lt.0.0d0) .or. (znr.eq.0.0d0 .and. zni.lt.0.0d0 .and. * m.eq.2)) go to 80 c----------------------------------------------------------------------- c right half plane computation, xn.ge.0. .and. (xn.ne.0. .or. c yn.ge.0. .or. m=1) c----------------------------------------------------------------------- call zbknu(znr, zni, fnu, kode, nn, cyr, cyi, nz, tol, elim, alim) go to 110 c----------------------------------------------------------------------- c left half plane computation c----------------------------------------------------------------------- 80 continue mr = -mm call zacon(znr, zni, fnu, kode, mr, nn, cyr, cyi, nw, rl, fnul, * tol, elim, alim) if (nw.lt.0) go to 240 nz=nw go to 110 90 continue c----------------------------------------------------------------------- c uniform asymptotic expansions for fnu.gt.fnul c----------------------------------------------------------------------- mr = 0 if ((znr.ge.0.0d0) .and. (znr.ne.0.0d0 .or. zni.ge.0.0d0 .or. * m.ne.2)) go to 100 mr = -mm if (znr.ne.0.0d0 .or. zni.ge.0.0d0) go to 100 znr = -znr zni = -zni 100 continue call zbunk(znr, zni, fnu, kode, mr, nn, cyr, cyi, nw, tol, elim, * alim) if (nw.lt.0) go to 240 nz = nz + nw 110 continue c----------------------------------------------------------------------- c h(m,fnu,z) = -fmm*(i/hpi)*(zt**fnu)*k(fnu,-z*zt) c c zt=exp(-fmm*hpi*i) = cmplx(0.0,-fmm), fmm=3-2*m, m=1,2 c----------------------------------------------------------------------- sgn = dsign(hpi,-fmm) c----------------------------------------------------------------------- c calculate exp(fnu*hpi*i) to minimize losses of significance c when fnu is large c----------------------------------------------------------------------- inu = int(sngl(fnu)) inuh = inu/2 ir = inu - 2*inuh arg = (fnu-dble(float(inu-ir)))*sgn rhpi = 1.0d0/sgn c zni = rhpi*dcos(arg) c znr = -rhpi*dsin(arg) csgni = rhpi*dcos(arg) csgnr = -rhpi*dsin(arg) if (mod(inuh,2).eq.0) go to 120 c znr = -znr c zni = -zni csgnr = -csgnr csgni = -csgni 120 continue zti = -fmm rtol = 1.0d0/tol ascle = ufl*rtol do 130 i=1,nn c str = cyr(i)*znr - cyi(i)*zni c cyi(i) = cyr(i)*zni + cyi(i)*znr c cyr(i) = str c str = -zni*zti c zni = znr*zti c znr = str aa = cyr(i) bb = cyi(i) atol = 1.0d0 if (dmax1(dabs(aa),dabs(bb)).gt.ascle) go to 135 aa = aa*rtol bb = bb*rtol atol = tol 135 continue str = aa*csgnr - bb*csgni sti = aa*csgni + bb*csgnr cyr(i) = str*atol cyi(i) = sti*atol str = -csgni*zti csgni = csgnr*zti csgnr = str 130 continue return 140 continue if (znr.lt.0.0d0) go to 230 return 230 continue nz=0 ierr=2 return 240 continue if(nw.eq.(-1)) go to 230 nz=0 ierr=5 return 260 continue nz=0 ierr=4 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zbesi(zr, zi, fnu, kode, n, cyr, cyi, nz, ierr) c i-Bessel function,complex bessel function, c modified bessel function of the first kind c Author Amos, Donald E., Sandia National Laboratories c c on kode=1, zbesi computes an n member sequence of complex c bessel functions cy(j)=i(fnu+j-1,z) for real, nonnegative c orders fnu+j-1, j=1,...,n and complex z in the cut plane c -pi.lt.arg(z).le.pi. on kode=2, zbesi returns the scaled c functions c c cy(j)=exp(-abs(x))*i(fnu+j-1,z) j = 1,...,n , x=real(z) c c with the exponential growth removed in both the left and c right half planes for z to infinity. definitions and notation c are found in the nbs handbook of mathematical functions c (ref. 1). c c input zr,zi,fnu are double precision c zr,zi - z=cmplx(zr,zi), -pi.lt.arg(z).le.pi c fnu - order of initial i function, fnu.ge.0.0d0 c kode - a parameter to indicate the scaling option c kode= 1 returns c cy(j)=i(fnu+j-1,z), j=1,...,n c = 2 returns c cy(j)=i(fnu+j-1,z)*exp(-abs(x)), j=1,...,n c n - number of members of the sequence, n.ge.1 c c output cyr,cyi are double precision c cyr,cyi- double precision vectors whose first n components c contain real and imaginary parts for the sequence c cy(j)=i(fnu+j-1,z) or c cy(j)=i(fnu+j-1,z)*exp(-abs(x)) j=1,...,n c depending on kode, x=real(z) c nz - number of components set to zero due to underflow, c nz= 0 , normal return c nz.gt.0 , last nz components of cy set to zero c to underflow, cy(j)=cmplx(0.0d0,0.0d0) c j = n-nz+1,...,n c ierr - error flag c ierr=0, normal return - computation completed c ierr=1, input error - no computation c ierr=2, overflow - no computation, real(z) too c large on kode=1 c ierr=3, cabs(z) or fnu+n-1 large - computation done c but losses of signifcance by argument c reduction produce less than half of machine c accuracy c ierr=4, cabs(z) or fnu+n-1 too large - no computa- c tion because of complete losses of signifi- c cance by argument reduction c ierr=5, error - no computation, c algorithm termination condition not met c c c the computation is carried out by the power series for c small cabs(z), the asymptotic expansion for large cabs(z), c the miller algorithm normalized by the wronskian and a c neumann series for imtermediate magnitudes, and the c uniform asymptotic expansions for i(fnu,z) and j(fnu,z) c for large orders. backward recurrence is used to generate c sequences or reduce orders when necessary. c c the calculations above are done in the right half plane and c continued into the left half plane by the formula c c i(fnu,z*exp(m*pi)) = exp(m*pi*fnu)*i(fnu,z) real(z).gt.0.0 c m = +i or -i, i**2=-1 c c for negative orders,the formula c c i(-fnu,z) = i(fnu,z) + (2/pi)*sin(pi*fnu)*k(fnu,z) c c can be used. however,for large orders close to integers, the c the function changes radically. when fnu is a large positive c integer,the magnitude of i(-fnu,z)=i(fnu,z) is a large c negative power of ten. but when fnu is not an integer, c k(fnu,z) dominates in magnitude with a large positive power of c ten and the most that the second term can be reduced is by c unit roundoff from the coefficient. thus, wide changes can c occur within unit roundoff of a large integer for fnu. here, c large means fnu.gt.cabs(z). c c in most complex variable computation, one must evaluate ele- c mentary functions. when the magnitude of z or fnu+n-1 is c large, losses of significance by argument reduction occur. c consequently, if either one exceeds u1=sqrt(0.5/ur), then c losses exceeding half precision are likely and an error flag c ierr=3 is triggered where ur=dmax1(d1mach(4),1.0d-18) is c double precision unit roundoff limited to 18 digits precision. c if either is larger than u2=0.5/ur, then all significance is c lost and ierr=4. in order to use the int function, arguments c must be further restricted not to exceed the largest machine c integer, u3=i1mach(9). thus, the magnitude of z and fnu+n-1 is c restricted by min(u2,u3). on 32 bit machines, u1,u2, and u3 c are approximately 2.0e+3, 4.2e+6, 2.1e+9 in single precision c arithmetic and 1.3e+8, 1.8e+16, 2.1e+9 in double precision c arithmetic respectively. this makes u2 and u3 limiting in c their respective arithmetics. this means that one can expect c to retain, in the worst cases on 32 bit machines, no digits c in single and only 7 digits in double precision arithmetic. c similar considerations hold for other machines. c c the approximate relative error in the magnitude of a complex c bessel function can be expressed by p*10**s where p=max(unit c roundoff,1.0e-18) is the nominal precision and 10**s repre- c sents the increase in error due to argument reduction in the c elementary functions. here, s=max(1,abs(log10(cabs(z))), c abs(log10(fnu))) approximately (i.e. s=max(1,abs(exponent of c cabs(z),abs(exponent of fnu)) ). however, the phase angle may c have only absolute accuracy. this is most likely to occur when c one component (in absolute value) is larger than the other by c several orders of magnitude. if one component is 10**k larger c than the other, then one can expect only max(abs(log10(p))-k, c 0) significant digits; or, stated another way, when k exceeds c the exponent of p, no significant digits remain in the smaller c component. however, the phase angle retains absolute accuracy c because, in complex arithmetic with precision p, the smaller c component will not (as a rule) decrease below p times the c magnitude of the larger component. in these extreme cases, c the principal phase angle is on the order of +p, -p, pi/2-p, c or -pi/2+p. c c***routines called zbinu,i1mach,d1mach c complex cone,csgn,cw,cy,czero,z,zn double precision aa, alim, arg, conei, coner, csgni, csgnr, cyi, * cyr, dig, elim, fnu, fnul, pi, rl, r1m5, str, tol, zi, zni, znr, * zr, d1mach, az, bb, fn, zabs2, ascle, rtol, atol, sti integer i, ierr, inu, k, kode, k1,k2,n,nz,nn, i1mach dimension cyr(n), cyi(n) data pi /3.14159265358979324d0/ data coner, conei /1.0d0,0.0d0/ c ierr = 0 nz=0 if (fnu.lt.0.0d0) ierr=1 if (kode.lt.1 .or. kode.gt.2) ierr=1 if (n.lt.1) ierr=1 if (ierr.ne.0) return c----------------------------------------------------------------------- c set parameters related to machine constants. c tol is the approximate unit roundoff limited to 1.0e-18. c elim is the approximate exponential over- and underflow limit. c exp(-elim).lt.exp(-alim)=exp(-elim)/tol and c exp(elim).gt.exp(alim)=exp(elim)*tol are intervals near c underflow and overflow limits where scaled arithmetic is done. c rl is the lower boundary of the asymptotic expansion for large z. c dig = number of base 10 digits in tol = 10**(-dig). c fnul is the lower boundary of the asymptotic series for large fnu. c----------------------------------------------------------------------- tol = dmax1(d1mach(4),1.0d-18) k1 = i1mach(15) k2 = i1mach(16) r1m5 = d1mach(5) k = min0(iabs(k1),iabs(k2)) elim = 2.303d0*(dble(float(k))*r1m5-3.0d0) k1 = i1mach(14) - 1 aa = r1m5*dble(float(k1)) dig = dmin1(aa,18.0d0) aa = aa*2.303d0 alim = elim + dmax1(-aa,-41.45d0) rl = 1.2d0*dig + 3.0d0 fnul = 10.0d0 + 6.0d0*(dig-3.0d0) c----------------------------------------------------------------------------- c test for proper range c----------------------------------------------------------------------- az = zabs2(zr,zi) fn = fnu+dble(float(n-1)) aa = 0.5d0/tol bb=dble(float(i1mach(9)))*0.5d0 aa = dmin1(aa,bb) if (az.gt.aa) go to 260 if (fn.gt.aa) go to 260 aa = dsqrt(aa) if (az.gt.aa) ierr=3 if (fn.gt.aa) ierr=3 znr = zr zni = zi csgnr = coner csgni = conei if (zr.ge.0.0d0) go to 40 znr = -zr zni = -zi c----------------------------------------------------------------------- c calculate csgn=exp(fnu*pi*i) to minimize losses of significance c when fnu is large c----------------------------------------------------------------------- inu = int(sngl(fnu)) arg = (fnu-dble(float(inu)))*pi if (zi.lt.0.0d0) arg = -arg csgnr = dcos(arg) csgni = dsin(arg) if (mod(inu,2).eq.0) go to 40 csgnr = -csgnr csgni = -csgni 40 continue call zbinu(znr, zni, fnu, kode, n, cyr, cyi, nz, rl, fnul, tol, * elim, alim) if (nz.lt.0) go to 120 if (zr.ge.0.0d0) return c----------------------------------------------------------------------- c analytic continuation to the left half plane c----------------------------------------------------------------------- nn = n - nz if (nn.eq.0) return rtol = 1.0d0/tol ascle = d1mach(1)*rtol*1.0d+3 do 50 i=1,nn c str = cyr(i)*csgnr - cyi(i)*csgni c cyi(i) = cyr(i)*csgni + cyi(i)*csgnr c cyr(i) = str aa = cyr(i) bb = cyi(i) atol = 1.0d0 if (dmax1(dabs(aa),dabs(bb)).gt.ascle) go to 55 aa = aa*rtol bb = bb*rtol atol = tol 55 continue str = aa*csgnr - bb*csgni sti = aa*csgni + bb*csgnr cyr(i) = str*atol cyi(i) = sti*atol csgnr = -csgnr csgni = -csgni 50 continue return 120 continue if(nz.eq.(-2)) go to 130 nz = 0 ierr=2 return 130 continue nz=0 ierr=5 return 260 continue nz=0 ierr=4 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zbesk(zr, zi, fnu, kode, n, cyr, cyi, nz, ierr) c k-Bessel function,complex bessel function, c modified bessel function of the second kind, c bessel function of the third kind c Author Amos, Donald E., Sandia National Laboratories c c on kode=1, cbesk computes an n member sequence of complex c bessel functions cy(j)=k(fnu+j-1,z) for real, nonnegative c orders fnu+j-1, j=1,...,n and complex z.ne.cmplx(0.0,0.0) c in the cut plane -pi.lt.arg(z).le.pi. on kode=2, cbesk c returns the scaled k functions, c c cy(j)=exp(z)*k(fnu+j-1,z) , j=1,...,n, c c which remove the exponential behavior in both the left and c right half planes for z to infinity. c c input zr,zi,fnu are double precision c zr,zi - z=cmplx(zr,zi), z.ne.cmplx(0.0d0,0.0d0), c -pi.lt.arg(z).le.pi c fnu - order of initial k function, fnu.ge.0.0d0 c n - number of members of the sequence, n.ge.1 c kode - a parameter to indicate the scaling option c kode= 1 returns c cy(i)=k(fnu+i-1,z), i=1,...,n c = 2 returns c cy(i)=k(fnu+i-1,z)*exp(z), i=1,...,n c c output cyr,cyi are double precision c cyr,cyi- double precision vectors whose first n components c contain real and imaginary parts for the sequence c cy(i)=k(fnu+i-1,z), i=1,...,n or c cy(i)=k(fnu+i-1,z)*exp(z), i=1,...,n c depending on kode c nz - number of components set to zero due to underflow. c nz= 0 , normal return c nz.gt.0 , first nz components of cy set to zero due c to underflow, cy(i)=cmplx(0.0d0,0.0d0), c i=1,...,n when x.ge.0.0. when x.lt.0.0 c nz states only the number of underflows c in the sequence. c c ierr - error flag c ierr=0, normal return - computation completed c ierr=1, input error - no computation c ierr=2, overflow - no computation, fnu is c too large or cabs(z) is too small or both c ierr=3, cabs(z) or fnu+n-1 large - computation done c but losses of signifcance by argument c reduction produce less than half of machine c accuracy c ierr=4, cabs(z) or fnu+n-1 too large - no computa- c tion because of complete losses of signifi- c cance by argument reduction c ierr=5, error - no computation, c algorithm termination condition not met c c c equations of the reference are implemented for small orders c dnu and dnu+1.0 in the right half plane x.ge.0.0. forward c recurrence generates higher orders. k is continued to the left c half plane by the relation c c k(fnu,z*exp(mp)) = exp(-mp*fnu)*k(fnu,z)-mp*i(fnu,z) c mp=mr*pi*i, mr=+1 or -1, re(z).gt.0, i**2=-1 c c where i(fnu,z) is the i bessel function. c c for large orders, fnu.gt.fnul, the k function is computed c by means of its uniform asymptotic expansions. c c for negative orders, the formula c c k(-fnu,z) = k(fnu,z) c c can be used. c c cbesk assumes that a significant digit sinh(x) function is c available. c c in most complex variable computation, one must evaluate ele- c mentary functions. when the magnitude of z or fnu+n-1 is c large, losses of significance by argument reduction occur. c consequently, if either one exceeds u1=sqrt(0.5/ur), then c losses exceeding half precision are likely and an error flag c ierr=3 is triggered where ur=dmax1(d1mach(4),1.0d-18) is c double precision unit roundoff limited to 18 digits precision. c if either is larger than u2=0.5/ur, then all significance is c lost and ierr=4. in order to use the int function, arguments c must be further restricted not to exceed the largest machine c integer, u3=i1mach(9). thus, the magnitude of z and fnu+n-1 is c restricted by min(u2,u3). on 32 bit machines, u1,u2, and u3 c are approximately 2.0e+3, 4.2e+6, 2.1e+9 in single precision c arithmetic and 1.3e+8, 1.8e+16, 2.1e+9 in double precision c arithmetic respectively. this makes u2 and u3 limiting in c their respective arithmetics. this means that one can expect c to retain, in the worst cases on 32 bit machines, no digits c in single and only 7 digits in double precision arithmetic. c similar considerations hold for other machines. c c the approximate relative error in the magnitude of a complex c bessel function can be expressed by p*10**s where p=max(unit c roundoff,1.0e-18) is the nominal precision and 10**s repre- c sents the increase in error due to argument reduction in the c elementary functions. here, s=max(1,abs(log10(cabs(z))), c abs(log10(fnu))) approximately (i.e. s=max(1,abs(exponent of c cabs(z),abs(exponent of fnu)) ). however, the phase angle may c have only absolute accuracy. this is most likely to occur when c one component (in absolute value) is larger than the other by c several orders of magnitude. if one component is 10**k larger c than the other, then one can expect only max(abs(log10(p))-k, c 0) significant digits; or, stated another way, when k exceeds c the exponent of p, no significant digits remain in the smaller c component. however, the phase angle retains absolute accuracy c because, in complex arithmetic with precision p, the smaller c component will not (as a rule) decrease below p times the c magnitude of the larger component. in these extreme cases, c the principal phase angle is on the order of +p, -p, pi/2-p, c or -pi/2+p. c c***routines called zacon,zbknu,zbunk,zuoik,zabs2,i1mach,d1mach c c complex cy,z double precision aa, alim, aln, arg, az, cyi, cyr, dig, elim, fn, * fnu, fnul, rl, r1m5, tol, ufl, zi, zr, d1mach, zabs2, bb integer ierr, k, kode, k1, k2, mr, n, nn, nuf, nw, nz, i1mach dimension cyr(n), cyi(n) c ierr = 0 nz=0 if (zi.eq.0.0e0 .and. zr.eq.0.0e0) ierr=1 if (fnu.lt.0.0d0) ierr=1 if (kode.lt.1 .or. kode.gt.2) ierr=1 if (n.lt.1) ierr=1 if (ierr.ne.0) return nn = n c----------------------------------------------------------------------- c set parameters related to machine constants. c tol is the approximate unit roundoff limited to 1.0e-18. c elim is the approximate exponential over- and underflow limit. c exp(-elim).lt.exp(-alim)=exp(-elim)/tol and c exp(elim).gt.exp(alim)=exp(elim)*tol are intervals near c underflow and overflow limits where scaled arithmetic is done. c rl is the lower boundary of the asymptotic expansion for large z. c dig = number of base 10 digits in tol = 10**(-dig). c fnul is the lower boundary of the asymptotic series for large fnu c----------------------------------------------------------------------- tol = dmax1(d1mach(4),1.0d-18) k1 = i1mach(15) k2 = i1mach(16) r1m5 = d1mach(5) k = min0(iabs(k1),iabs(k2)) elim = 2.303d0*(dble(float(k))*r1m5-3.0d0) k1 = i1mach(14) - 1 aa = r1m5*dble(float(k1)) dig = dmin1(aa,18.0d0) aa = aa*2.303d0 alim = elim + dmax1(-aa,-41.45d0) fnul = 10.0d0 + 6.0d0*(dig-3.0d0) rl = 1.2d0*dig + 3.0d0 c----------------------------------------------------------------------------- c test for proper range c----------------------------------------------------------------------- az = zabs2(zr,zi) fn = fnu + dble(float(nn-1)) aa = 0.5d0/tol bb=dble(float(i1mach(9)))*0.5d0 aa = dmin1(aa,bb) if (az.gt.aa) go to 260 if (fn.gt.aa) go to 260 aa = dsqrt(aa) if (az.gt.aa) ierr=3 if (fn.gt.aa) ierr=3 c----------------------------------------------------------------------- c overflow test on the last member of the sequence c----------------------------------------------------------------------- c ufl = dexp(-elim) ufl = d1mach(1)*1.0d+3 if (az.lt.ufl) go to 180 if (fnu.gt.fnul) go to 80 if (fn.le.1.0d0) go to 60 if (fn.gt.2.0d0) go to 50 if (az.gt.tol) go to 60 arg = 0.5d0*az aln = -fn*dlog(arg) if (aln.gt.elim) go to 180 go to 60 50 continue call zuoik(zr, zi, fnu, kode, 2, nn, cyr, cyi, nuf, tol, elim, * alim) if (nuf.lt.0) go to 180 nz = nz + nuf nn = nn - nuf c----------------------------------------------------------------------- c here nn=n or nn=0 since nuf=0,nn, or -1 on return from cuoik c if nuf=nn, then cy(i)=czero for all i c----------------------------------------------------------------------- if (nn.eq.0) go to 100 60 continue if (zr.lt.0.0d0) go to 70 c----------------------------------------------------------------------- c right half plane computation, real(z).ge.0. c----------------------------------------------------------------------- call zbknu(zr, zi, fnu, kode, nn, cyr, cyi, nw, tol, elim, alim) if (nw.lt.0) go to 200 nz=nw return c----------------------------------------------------------------------- c left half plane computation c pi/2.lt.arg(z).le.pi and -pi.lt.arg(z).lt.-pi/2. c----------------------------------------------------------------------- 70 continue if (nz.ne.0) go to 180 mr = 1 if (zi.lt.0.0d0) mr = -1 call zacon(zr, zi, fnu, kode, mr, nn, cyr, cyi, nw, rl, fnul, * tol, elim, alim) if (nw.lt.0) go to 200 nz=nw return c----------------------------------------------------------------------- c uniform asymptotic expansions for fnu.gt.fnul c----------------------------------------------------------------------- 80 continue mr = 0 if (zr.ge.0.0d0) go to 90 mr = 1 if (zi.lt.0.0d0) mr = -1 90 continue call zbunk(zr, zi, fnu, kode, mr, nn, cyr, cyi, nw, tol, elim, * alim) if (nw.lt.0) go to 200 nz = nz + nw return 100 continue if (zr.lt.0.0d0) go to 180 return 180 continue nz = 0 ierr=2 return 200 continue if(nw.eq.(-1)) go to 180 nz=0 ierr=5 return 260 continue nz=0 ierr=4 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zasyi(zr, zi, fnu, kode, n, yr, yi, nz, rl, tol, elim, * alim) c geuz for g77 EXTERNAL zsqrt EXTERNAL zexp c Refer to zbesi,zbesk c c zasyi computes the i bessel function for real(z).ge.0.0 by c means of the asymptotic expansion for large cabs(z) in the c region cabs(z).gt.max(rl,fnu*fnu/2). nz=0 is a normal return. c nz.lt.0 indicates an overflow on kode=1. c c***routines called d1mach,zabs2,zdiv,zexp,zmlt,zsqrt c c complex ak1,ck,cone,cs1,cs2,cz,czero,dk,ez,p1,rz,s2,y,z double precision aa, aez, ak, ak1i, ak1r, alim, arg, arm, atol, * az, bb, bk, cki, ckr, conei, coner, cs1i, cs1r, cs2i, cs2r, czi, * czr, dfnu, dki, dkr, dnu2, elim, ezi, ezr, fdn, fnu, pi, p1i, * p1r, raz, rl, rtpi, rtr1, rzi, rzr, s, sgn, sqk, sti, str, s2i, * s2r, tol, tzi, tzr, yi, yr, zeroi, zeror, zi, zr, d1mach, zabs2 integer i, ib, il, inu, j, jl, k, kode, koded, m, n, nn, nz dimension yr(n), yi(n) data pi, rtpi /3.14159265358979324d0 , 0.159154943091895336d0 / data zeror,zeroi,coner,conei / 0.0d0, 0.0d0, 1.0d0, 0.0d0 / c nz = 0 az = zabs2(zr,zi) arm = 1.0d+3*d1mach(1) rtr1 = dsqrt(arm) il = min0(2,n) dfnu = fnu + dble(float(n-il)) c----------------------------------------------------------------------- c overflow test c----------------------------------------------------------------------- raz = 1.0d0/az str = zr*raz sti = -zi*raz ak1r = rtpi*str*raz ak1i = rtpi*sti*raz call zsqrt(ak1r, ak1i, ak1r, ak1i) czr = zr czi = zi if (kode.ne.2) go to 10 czr = zeror czi = zi 10 continue if (dabs(czr).gt.elim) go to 100 dnu2 = dfnu + dfnu koded = 1 if ((dabs(czr).gt.alim) .and. (n.gt.2)) go to 20 koded = 0 call zexp(czr, czi, str, sti) call zmlt(ak1r, ak1i, str, sti, ak1r, ak1i) 20 continue fdn = 0.0d0 if (dnu2.gt.rtr1) fdn = dnu2*dnu2 ezr = zr*8.0d0 ezi = zi*8.0d0 c----------------------------------------------------------------------- c when z is imaginary, the error test must be made relative to the c first reciprocal power since this is the leading term of the c expansion for the imaginary part. c----------------------------------------------------------------------- aez = 8.0d0*az s = tol/aez jl = int(sngl(rl+rl)) + 2 p1r = zeror p1i = zeroi if (zi.eq.0.0d0) go to 30 c----------------------------------------------------------------------- c calculate exp(pi*(0.5+fnu+n-il)*i) to minimize losses of c significance when fnu or n is large c----------------------------------------------------------------------- inu = int(sngl(fnu)) arg = (fnu-dble(float(inu)))*pi inu = inu + n - il ak = -dsin(arg) bk = dcos(arg) if (zi.lt.0.0d0) bk = -bk p1r = ak p1i = bk if (mod(inu,2).eq.0) go to 30 p1r = -p1r p1i = -p1i 30 continue do 70 k=1,il sqk = fdn - 1.0d0 atol = s*dabs(sqk) sgn = 1.0d0 cs1r = coner cs1i = conei cs2r = coner cs2i = conei ckr = coner cki = conei ak = 0.0d0 aa = 1.0d0 bb = aez dkr = ezr dki = ezi do 40 j=1,jl call zdiv(ckr, cki, dkr, dki, str, sti) ckr = str*sqk cki = sti*sqk cs2r = cs2r + ckr cs2i = cs2i + cki sgn = -sgn cs1r = cs1r + ckr*sgn cs1i = cs1i + cki*sgn dkr = dkr + ezr dki = dki + ezi aa = aa*dabs(sqk)/bb bb = bb + aez ak = ak + 8.0d0 sqk = sqk - ak if (aa.le.atol) go to 50 40 continue go to 110 50 continue s2r = cs1r s2i = cs1i if (zr+zr.ge.elim) go to 60 tzr = zr + zr tzi = zi + zi call zexp(-tzr, -tzi, str, sti) call zmlt(str, sti, p1r, p1i, str, sti) call zmlt(str, sti, cs2r, cs2i, str, sti) s2r = s2r + str s2i = s2i + sti 60 continue fdn = fdn + 8.0d0*dfnu + 4.0d0 p1r = -p1r p1i = -p1i m = n - il + k yr(m) = s2r*ak1r - s2i*ak1i yi(m) = s2r*ak1i + s2i*ak1r 70 continue if (n.le.2) return nn = n k = nn - 2 ak = dble(float(k)) str = zr*raz sti = -zi*raz rzr = (str+str)*raz rzi = (sti+sti)*raz ib = 3 do 80 i=ib,nn yr(k) = (ak+fnu)*(rzr*yr(k+1)-rzi*yi(k+1)) + yr(k+2) yi(k) = (ak+fnu)*(rzr*yi(k+1)+rzi*yr(k+1)) + yi(k+2) ak = ak - 1.0d0 k = k - 1 80 continue if (koded.eq.0) return call zexp(czr, czi, ckr, cki) do 90 i=1,nn str = yr(i)*ckr - yi(i)*cki yi(i) = yr(i)*cki + yi(i)*ckr yr(i) = str 90 continue return 100 continue nz = -1 return 110 continue nz=-2 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zbinu(zr, zi, fnu, kode, n, cyr, cyi, nz, rl, fnul, * tol, elim, alim) c***refer to zbesh,zbesi,zbesj,zbesk,zairy,zbiry c c zbinu computes the i function in the right half z plane c c***routines called zabs2,zasyi,zbuni,zmlri,zseri,zuoik,zwrsk c double precision alim, az, cwi, cwr, cyi, cyr, dfnu, elim, fnu, * fnul, rl, tol, zeroi, zeror, zi, zr, zabs2 integer i, inw, kode, n, nlast, nn, nui, nw, nz dimension cyr(n), cyi(n), cwr(2), cwi(2) data zeror,zeroi / 0.0d0, 0.0d0 / c nz = 0 az = zabs2(zr,zi) nn = n dfnu = fnu + dble(float(n-1)) if (az.le.2.0d0) go to 10 if (az*az*0.25d0.gt.dfnu+1.0d0) go to 20 10 continue c----------------------------------------------------------------------- c power series c----------------------------------------------------------------------- call zseri(zr, zi, fnu, kode, nn, cyr, cyi, nw, tol, elim, alim) inw = iabs(nw) nz = nz + inw nn = nn - inw if (nn.eq.0) return if (nw.ge.0) go to 120 dfnu = fnu + dble(float(nn-1)) 20 continue if (az.lt.rl) go to 40 if (dfnu.le.1.0d0) go to 30 if (az+az.lt.dfnu*dfnu) go to 50 c----------------------------------------------------------------------- c asymptotic expansion for large z c----------------------------------------------------------------------- 30 continue call zasyi(zr, zi, fnu, kode, nn, cyr, cyi, nw, rl, tol, elim, * alim) if (nw.lt.0) go to 130 go to 120 40 continue if (dfnu.le.1.0d0) go to 70 50 continue c----------------------------------------------------------------------- c overflow and underflow test on i sequence for miller algorithm c----------------------------------------------------------------------- call zuoik(zr, zi, fnu, kode, 1, nn, cyr, cyi, nw, tol, elim, * alim) if (nw.lt.0) go to 130 nz = nz + nw nn = nn - nw if (nn.eq.0) return dfnu = fnu+dble(float(nn-1)) if (dfnu.gt.fnul) go to 110 if (az.gt.fnul) go to 110 60 continue if (az.gt.rl) go to 80 70 continue c----------------------------------------------------------------------- c miller algorithm normalized by the series c----------------------------------------------------------------------- call zmlri(zr, zi, fnu, kode, nn, cyr, cyi, nw, tol) if(nw.lt.0) go to 130 go to 120 80 continue c----------------------------------------------------------------------- c miller algorithm normalized by the wronskian c----------------------------------------------------------------------- c----------------------------------------------------------------------- c overflow test on k functions used in wronskian c----------------------------------------------------------------------- call zuoik(zr, zi, fnu, kode, 2, 2, cwr, cwi, nw, tol, elim, * alim) if (nw.ge.0) go to 100 nz = nn do 90 i=1,nn cyr(i) = zeror cyi(i) = zeroi 90 continue return 100 continue if (nw.gt.0) go to 130 call zwrsk(zr, zi, fnu, kode, nn, cyr, cyi, nw, cwr, cwi, tol, * elim, alim) if (nw.lt.0) go to 130 go to 120 110 continue c----------------------------------------------------------------------- c increment fnu+nn-1 up to fnul, compute and recur backward c----------------------------------------------------------------------- nui = int(sngl(fnul-dfnu)) + 1 nui = max0(nui,0) call zbuni(zr, zi, fnu, kode, nn, cyr, cyi, nw, nui, nlast, fnul, * tol, elim, alim) if (nw.lt.0) go to 130 nz = nz + nw if (nlast.eq.0) go to 120 nn = nlast go to 60 120 continue return 130 continue nz = -1 if(nw.eq.(-2)) nz=-2 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zbknu(zr, zi, fnu, kode, n, yr, yi, nz, tol, elim, * alim) c geuz for g77 EXTERNAL zsqrt EXTERNAL zexp EXTERNAL zlog c Refer to zbesi,zbesk,zairy,zbesh c c zbknu computes the k bessel function in the right half z plane. c c***routines called dgamln,i1mach,d1mach,zkscl,zshch,zuchk,zabs2,zdiv, c zexp,zlog,zmlt,zsqrt c double precision aa, ak, alim, ascle, a1, a2, bb, bk, bry, caz, * cbi, cbr, cc, cchi, cchr, cki, ckr, coefi, coefr, conei, coner, * crscr, csclr, cshi, cshr, csi, csr, csrr, cssr, ctwor, * czeroi, czeror, czi, czr, dnu, dnu2, dpi, elim, etest, fc, fhs, * fi, fk, fks, fmui, fmur, fnu, fpi, fr, g1, g2, hpi, pi, pr, pti, * ptr, p1i, p1r, p2i, p2m, p2r, qi, qr, rak, rcaz, rthpi, rzi, * rzr, r1, s, smui, smur, spi, sti, str, s1i, s1r, s2i, s2r, tm, * tol, tth, t1, t2, yi, yr, zi, zr, dgamln, d1mach, zabs2, elm, * celmr, zdr, zdi, as, alas, helim, cyr, cyi integer i, iflag, inu, k, kflag, kk, kmax, kode, koded, n, nz, * idum, i1mach, j, ic, inub, nw dimension yr(n), yi(n), cc(8), cssr(3), csrr(3), bry(3), cyr(2), * cyi(2) c complex z,y,a,b,rz,smu,fu,fmu,f,flrz,cz,s1,s2,csh,cch c complex ck,p,q,coef,p1,p2,cbk,pt,czero,cone,ctwo,st,ez,cs,dk c data kmax / 30 / data czeror,czeroi,coner,conei,ctwor,r1/ 1 0.0d0 , 0.0d0 , 1.0d0 , 0.0d0 , 2.0d0 , 2.0d0 / data dpi, rthpi, spi ,hpi, fpi, tth / 1 3.14159265358979324d0, 1.25331413731550025d0, 2 1.90985931710274403d0, 1.57079632679489662d0, 3 1.89769999331517738d0, 6.66666666666666666d-01/ data cc(1), cc(2), cc(3), cc(4), cc(5), cc(6), cc(7), cc(8)/ 1 5.77215664901532861d-01, -4.20026350340952355d-02, 2 -4.21977345555443367d-02, 7.21894324666309954d-03, 3 -2.15241674114950973d-04, -2.01348547807882387d-05, 4 1.13302723198169588d-06, 6.11609510448141582d-09/ c caz = zabs2(zr,zi) csclr = 1.0d0/tol crscr = tol cssr(1) = csclr cssr(2) = 1.0d0 cssr(3) = crscr csrr(1) = crscr csrr(2) = 1.0d0 csrr(3) = csclr bry(1) = 1.0d+3*d1mach(1)/tol bry(2) = 1.0d0/bry(1) bry(3) = d1mach(2) nz = 0 iflag = 0 koded = kode rcaz = 1.0d0/caz str = zr*rcaz sti = -zi*rcaz rzr = (str+str)*rcaz rzi = (sti+sti)*rcaz inu = int(sngl(fnu+0.5d0)) dnu = fnu - dble(float(inu)) if (dabs(dnu).eq.0.5d0) go to 110 dnu2 = 0.0d0 if (dabs(dnu).gt.tol) dnu2 = dnu*dnu if (caz.gt.r1) go to 110 c----------------------------------------------------------------------- c series for cabs(z).le.r1 c----------------------------------------------------------------------- fc = 1.0d0 call zlog(rzr, rzi, smur, smui, idum) fmur = smur*dnu fmui = smui*dnu call zshch(fmur, fmui, cshr, cshi, cchr, cchi) if (dnu.eq.0.0d0) go to 10 fc = dnu*dpi fc = fc/dsin(fc) smur = cshr/dnu smui = cshi/dnu 10 continue a2 = 1.0d0 + dnu c----------------------------------------------------------------------- c gam(1-z)*gam(1+z)=pi*z/sin(pi*z), t1=1/gam(1-dnu), t2=1/gam(1+dnu) c----------------------------------------------------------------------- t2 = dexp(-dgamln(a2,idum)) t1 = 1.0d0/(t2*fc) if (dabs(dnu).gt.0.1d0) go to 40 c----------------------------------------------------------------------- c series for f0 to resolve indeterminacy for small abs(dnu) c----------------------------------------------------------------------- ak = 1.0d0 s = cc(1) do 20 k=2,8 ak = ak*dnu2 tm = cc(k)*ak s = s + tm if (dabs(tm).lt.tol) go to 30 20 continue 30 g1 = -s go to 50 40 continue g1 = (t1-t2)/(dnu+dnu) 50 continue g2 = (t1+t2)*0.5d0 fr = fc*(cchr*g1+smur*g2) fi = fc*(cchi*g1+smui*g2) call zexp(fmur, fmui, str, sti) pr = 0.5d0*str/t2 pi = 0.5d0*sti/t2 call zdiv(0.5d0, 0.0d0, str, sti, ptr, pti) qr = ptr/t1 qi = pti/t1 s1r = fr s1i = fi s2r = pr s2i = pi ak = 1.0d0 a1 = 1.0d0 ckr = coner cki = conei bk = 1.0d0 - dnu2 if (inu.gt.0 .or. n.gt.1) go to 80 c----------------------------------------------------------------------- c generate k(fnu,z), 0.0d0 .le. fnu .lt. 0.5d0 and n=1 c----------------------------------------------------------------------- if (caz.lt.tol) go to 70 call zmlt(zr, zi, zr, zi, czr, czi) czr = 0.25d0*czr czi = 0.25d0*czi t1 = 0.25d0*caz*caz 60 continue fr = (fr*ak+pr+qr)/bk fi = (fi*ak+pi+qi)/bk str = 1.0d0/(ak-dnu) pr = pr*str pi = pi*str str = 1.0d0/(ak+dnu) qr = qr*str qi = qi*str str = ckr*czr - cki*czi rak = 1.0d0/ak cki = (ckr*czi+cki*czr)*rak ckr = str*rak s1r = ckr*fr - cki*fi + s1r s1i = ckr*fi + cki*fr + s1i a1 = a1*t1*rak bk = bk + ak + ak + 1.0d0 ak = ak + 1.0d0 if (a1.gt.tol) go to 60 70 continue yr(1) = s1r yi(1) = s1i if (koded.eq.1) return call zexp(zr, zi, str, sti) call zmlt(s1r, s1i, str, sti, yr(1), yi(1)) return c----------------------------------------------------------------------- c generate k(dnu,z) and k(dnu+1,z) for forward recurrence c----------------------------------------------------------------------- 80 continue if (caz.lt.tol) go to 100 call zmlt(zr, zi, zr, zi, czr, czi) czr = 0.25d0*czr czi = 0.25d0*czi t1 = 0.25d0*caz*caz 90 continue fr = (fr*ak+pr+qr)/bk fi = (fi*ak+pi+qi)/bk str = 1.0d0/(ak-dnu) pr = pr*str pi = pi*str str = 1.0d0/(ak+dnu) qr = qr*str qi = qi*str str = ckr*czr - cki*czi rak = 1.0d0/ak cki = (ckr*czi+cki*czr)*rak ckr = str*rak s1r = ckr*fr - cki*fi + s1r s1i = ckr*fi + cki*fr + s1i str = pr - fr*ak sti = pi - fi*ak s2r = ckr*str - cki*sti + s2r s2i = ckr*sti + cki*str + s2i a1 = a1*t1*rak bk = bk + ak + ak + 1.0d0 ak = ak + 1.0d0 if (a1.gt.tol) go to 90 100 continue kflag = 2 a1 = fnu + 1.0d0 ak = a1*dabs(smur) if (ak.gt.alim) kflag = 3 str = cssr(kflag) p2r = s2r*str p2i = s2i*str call zmlt(p2r, p2i, rzr, rzi, s2r, s2i) s1r = s1r*str s1i = s1i*str if (koded.eq.1) go to 210 call zexp(zr, zi, fr, fi) call zmlt(s1r, s1i, fr, fi, s1r, s1i) call zmlt(s2r, s2i, fr, fi, s2r, s2i) go to 210 c----------------------------------------------------------------------- c iflag=0 means no underflow occurred c iflag=1 means an underflow occurred- computation proceeds with c koded=2 and a test for on scale values is made during forward c recursion c----------------------------------------------------------------------- 110 continue call zsqrt(zr, zi, str, sti) call zdiv(rthpi, czeroi, str, sti, coefr, coefi) kflag = 2 if (koded.eq.2) go to 120 if (zr.gt.alim) go to 290 c blank line str = dexp(-zr)*cssr(kflag) sti = -str*dsin(zi) str = str*dcos(zi) call zmlt(coefr, coefi, str, sti, coefr, coefi) 120 continue if (dabs(dnu).eq.0.5d0) go to 300 c----------------------------------------------------------------------- c miller algorithm for cabs(z).gt.r1 c----------------------------------------------------------------------- ak = dcos(dpi*dnu) ak = dabs(ak) if (ak.eq.czeror) go to 300 fhs = dabs(0.25d0-dnu2) if (fhs.eq.czeror) go to 300 c----------------------------------------------------------------------- c compute r2=f(e). if cabs(z).ge.r2, use forward recurrence to c determine the backward index k. r2=f(e) is a straight line on c 12.le.e.le.60. e is computed from 2**(-e)=b**(1-i1mach(14))= c tol where b is the base of the arithmetic. c----------------------------------------------------------------------- t1 = dble(float(i1mach(14)-1)) t1 = t1*d1mach(5)*3.321928094d0 t1 = dmax1(t1,12.0d0) t1 = dmin1(t1,60.0d0) t2 = tth*t1 - 6.0d0 if (zr.ne.0.0d0) go to 130 t1 = hpi go to 140 130 continue t1 = datan(zi/zr) t1 = dabs(t1) 140 continue if (t2.gt.caz) go to 170 c----------------------------------------------------------------------- c forward recurrence loop when cabs(z).ge.r2 c----------------------------------------------------------------------- etest = ak/(dpi*caz*tol) fk = coner if (etest.lt.coner) go to 180 fks = ctwor ckr = caz + caz + ctwor p1r = czeror p2r = coner do 150 i=1,kmax ak = fhs/fks cbr = ckr/(fk+coner) ptr = p2r p2r = cbr*p2r - p1r*ak p1r = ptr ckr = ckr + ctwor fks = fks + fk + fk + ctwor fhs = fhs + fk + fk fk = fk + coner str = dabs(p2r)*fk if (etest.lt.str) go to 160 150 continue go to 310 160 continue fk = fk + spi*t1*dsqrt(t2/caz) fhs = dabs(0.25d0-dnu2) go to 180 170 continue c----------------------------------------------------------------------- c compute backward index k for cabs(z).lt.r2 c----------------------------------------------------------------------- a2 = dsqrt(caz) ak = fpi*ak/(tol*dsqrt(a2)) aa = 3.0d0*t1/(1.0d0+caz) bb = 14.7d0*t1/(28.0d0+caz) ak = (dlog(ak)+caz*dcos(aa)/(1.0d0+0.008d0*caz))/dcos(bb) fk = 0.12125d0*ak*ak/caz + 1.5d0 180 continue c----------------------------------------------------------------------- c backward recurrence loop for miller algorithm c----------------------------------------------------------------------- k = int(sngl(fk)) fk = dble(float(k)) fks = fk*fk p1r = czeror p1i = czeroi p2r = tol p2i = czeroi csr = p2r csi = p2i do 190 i=1,k a1 = fks - fk ak = (fks+fk)/(a1+fhs) rak = 2.0d0/(fk+coner) cbr = (fk+zr)*rak cbi = zi*rak ptr = p2r pti = p2i p2r = (ptr*cbr-pti*cbi-p1r)*ak p2i = (pti*cbr+ptr*cbi-p1i)*ak p1r = ptr p1i = pti csr = csr + p2r csi = csi + p2i fks = a1 - fk + coner fk = fk - coner 190 continue c----------------------------------------------------------------------- c compute (p2/cs)=(p2/cabs(cs))*(conjg(cs)/cabs(cs)) for better c scaling c----------------------------------------------------------------------- tm = zabs2(csr,csi) ptr = 1.0d0/tm s1r = p2r*ptr s1i = p2i*ptr csr = csr*ptr csi = -csi*ptr call zmlt(coefr, coefi, s1r, s1i, str, sti) call zmlt(str, sti, csr, csi, s1r, s1i) if (inu.gt.0 .or. n.gt.1) go to 200 zdr = zr zdi = zi if(iflag.eq.1) go to 270 go to 240 200 continue c----------------------------------------------------------------------- c compute p1/p2=(p1/cabs(p2)*conjg(p2)/cabs(p2) for scaling c----------------------------------------------------------------------- tm = zabs2(p2r,p2i) ptr = 1.0d0/tm p1r = p1r*ptr p1i = p1i*ptr p2r = p2r*ptr p2i = -p2i*ptr call zmlt(p1r, p1i, p2r, p2i, ptr, pti) str = dnu + 0.5d0 - ptr sti = -pti call zdiv(str, sti, zr, zi, str, sti) str = str + 1.0d0 call zmlt(str, sti, s1r, s1i, s2r, s2i) c----------------------------------------------------------------------- c forward recursion on the three term recursion with relation with c scaling near exponent extremes on kflag=1 or kflag=3 c----------------------------------------------------------------------- 210 continue str = dnu + 1.0d0 ckr = str*rzr cki = str*rzi if (n.eq.1) inu = inu - 1 if (inu.gt.0) go to 220 if (n.gt.1) go to 215 s1r = s2r s1i = s2i 215 continue zdr = zr zdi = zi if(iflag.eq.1) go to 270 go to 240 220 continue inub = 1 if(iflag.eq.1) go to 261 225 continue p1r = csrr(kflag) ascle = bry(kflag) do 230 i=inub,inu str = s2r sti = s2i s2r = ckr*str - cki*sti + s1r s2i = ckr*sti + cki*str + s1i s1r = str s1i = sti ckr = ckr + rzr cki = cki + rzi if (kflag.ge.3) go to 230 p2r = s2r*p1r p2i = s2i*p1r str = dabs(p2r) sti = dabs(p2i) p2m = dmax1(str,sti) if (p2m.le.ascle) go to 230 kflag = kflag + 1 ascle = bry(kflag) s1r = s1r*p1r s1i = s1i*p1r s2r = p2r s2i = p2i str = cssr(kflag) s1r = s1r*str s1i = s1i*str s2r = s2r*str s2i = s2i*str p1r = csrr(kflag) 230 continue if (n.ne.1) go to 240 s1r = s2r s1i = s2i 240 continue str = csrr(kflag) yr(1) = s1r*str yi(1) = s1i*str if (n.eq.1) return yr(2) = s2r*str yi(2) = s2i*str if (n.eq.2) return kk = 2 250 continue kk = kk + 1 if (kk.gt.n) return p1r = csrr(kflag) ascle = bry(kflag) do 260 i=kk,n p2r = s2r p2i = s2i s2r = ckr*p2r - cki*p2i + s1r s2i = cki*p2r + ckr*p2i + s1i s1r = p2r s1i = p2i ckr = ckr + rzr cki = cki + rzi p2r = s2r*p1r p2i = s2i*p1r yr(i) = p2r yi(i) = p2i if (kflag.ge.3) go to 260 str = dabs(p2r) sti = dabs(p2i) p2m = dmax1(str,sti) if (p2m.le.ascle) go to 260 kflag = kflag + 1 ascle = bry(kflag) s1r = s1r*p1r s1i = s1i*p1r s2r = p2r s2i = p2i str = cssr(kflag) s1r = s1r*str s1i = s1i*str s2r = s2r*str s2i = s2i*str p1r = csrr(kflag) 260 continue return c----------------------------------------------------------------------- c iflag=1 cases, forward recurrence on scaled values on underflow c----------------------------------------------------------------------- 261 continue helim = 0.5d0*elim elm = dexp(-elim) celmr = elm ascle = bry(1) zdr = zr zdi = zi ic = -1 j = 2 do 262 i=1,inu str = s2r sti = s2i s2r = str*ckr-sti*cki+s1r s2i = sti*ckr+str*cki+s1i s1r = str s1i = sti ckr = ckr+rzr cki = cki+rzi as = zabs2(s2r,s2i) alas = dlog(as) p2r = -zdr+alas if(p2r.lt.(-elim)) go to 263 call zlog(s2r,s2i,str,sti,idum) p2r = -zdr+str p2i = -zdi+sti p2m = dexp(p2r)/tol p1r = p2m*dcos(p2i) p1i = p2m*dsin(p2i) call zuchk(p1r,p1i,nw,ascle,tol) if(nw.ne.0) go to 263 j = 3 - j cyr(j) = p1r cyi(j) = p1i if(ic.eq.(i-1)) go to 264 ic = i go to 262 263 continue if(alas.lt.helim) go to 262 zdr = zdr-elim s1r = s1r*celmr s1i = s1i*celmr s2r = s2r*celmr s2i = s2i*celmr 262 continue if(n.ne.1) go to 270 s1r = s2r s1i = s2i go to 270 264 continue kflag = 1 inub = i+1 s2r = cyr(j) s2i = cyi(j) j = 3 - j s1r = cyr(j) s1i = cyi(j) if(inub.le.inu) go to 225 if(n.ne.1) go to 240 s1r = s2r s1i = s2i go to 240 270 continue yr(1) = s1r yi(1) = s1i if(n.eq.1) go to 280 yr(2) = s2r yi(2) = s2i 280 continue ascle = bry(1) call zkscl(zdr,zdi,fnu,n,yr,yi,nz,rzr,rzi,ascle,tol,elim) inu = n - nz if (inu.le.0) return kk = nz + 1 s1r = yr(kk) s1i = yi(kk) yr(kk) = s1r*csrr(1) yi(kk) = s1i*csrr(1) if (inu.eq.1) return kk = nz + 2 s2r = yr(kk) s2i = yi(kk) yr(kk) = s2r*csrr(1) yi(kk) = s2i*csrr(1) if (inu.eq.2) return t2 = fnu + dble(float(kk-1)) ckr = t2*rzr cki = t2*rzi kflag = 1 go to 250 290 continue c----------------------------------------------------------------------- c scale by dexp(z), iflag = 1 cases c----------------------------------------------------------------------- koded = 2 iflag = 1 kflag = 2 go to 120 c----------------------------------------------------------------------- c fnu=half odd integer case, dnu=-0.5 c----------------------------------------------------------------------- 300 continue s1r = coefr s1i = coefi s2r = coefr s2i = coefi go to 210 c c 310 continue nz=-2 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zbuni(zr, zi, fnu, kode, n, yr, yi, nz, nui, nlast, * fnul, tol, elim, alim) c Refer to zbesi,zbesk c c zbuni computes the i bessel function for large cabs(z).gt. c fnul and fnu+n-1.lt.fnul. the order is increased from c fnu+n-1 greater than fnul by adding nui and computing c according to the uniform asymptotic expansion for i(fnu,z) c on iform=1 and the expansion for j(fnu,z) on iform=2 c c***routines called zuni1,zuni2,zabs2,d1mach c c complex cscl,cscr,cy,rz,st,s1,s2,y,z double precision alim, ax, ay, csclr, cscrr, cyi, cyr, dfnu, * elim, fnu, fnui, fnul, gnu, raz, rzi, rzr, sti, str, s1i, s1r, * s2i, s2r, tol, yi, yr, zi, zr, zabs2, ascle, bry, c1r, c1i, c1m, * d1mach integer i, iflag, iform, k, kode, n, nl, nlast, nui, nw, nz dimension yr(n), yi(n), cyr(2), cyi(2), bry(3) nz = 0 ax = dabs(zr)*1.7321d0 ay = dabs(zi) iform = 1 if (ay.gt.ax) iform = 2 if (nui.eq.0) go to 60 fnui = dble(float(nui)) dfnu = fnu + dble(float(n-1)) gnu = dfnu + fnui if (iform.eq.2) go to 10 c----------------------------------------------------------------------- c asymptotic expansion for i(fnu,z) for large fnu applied in c -pi/3.le.arg(z).le.pi/3 c----------------------------------------------------------------------- call zuni1(zr, zi, gnu, kode, 2, cyr, cyi, nw, nlast, fnul, tol, * elim, alim) go to 20 10 continue c----------------------------------------------------------------------- c asymptotic expansion for j(fnu,z*exp(m*hpi)) for large fnu c applied in pi/3.lt.abs(arg(z)).le.pi/2 where m=+i or -i c and hpi=pi/2 c----------------------------------------------------------------------- call zuni2(zr, zi, gnu, kode, 2, cyr, cyi, nw, nlast, fnul, tol, * elim, alim) 20 continue if (nw.lt.0) go to 50 if (nw.ne.0) go to 90 str = zabs2(cyr(1),cyi(1)) c---------------------------------------------------------------------- c scale backward recurrence, bry(3) is defined but never used c---------------------------------------------------------------------- bry(1)=1.0d+3*d1mach(1)/tol bry(2) = 1.0d0/bry(1) bry(3) = bry(2) iflag = 2 ascle = bry(2) csclr = 1.0d0 if (str.gt.bry(1)) go to 21 iflag = 1 ascle = bry(1) csclr = 1.0d0/tol go to 25 21 continue if (str.lt.bry(2)) go to 25 iflag = 3 ascle=bry(3) csclr = tol 25 continue cscrr = 1.0d0/csclr s1r = cyr(2)*csclr s1i = cyi(2)*csclr s2r = cyr(1)*csclr s2i = cyi(1)*csclr raz = 1.0d0/zabs2(zr,zi) str = zr*raz sti = -zi*raz rzr = (str+str)*raz rzi = (sti+sti)*raz do 30 i=1,nui str = s2r sti = s2i s2r = (dfnu+fnui)*(rzr*str-rzi*sti) + s1r s2i = (dfnu+fnui)*(rzr*sti+rzi*str) + s1i s1r = str s1i = sti fnui = fnui - 1.0d0 if (iflag.ge.3) go to 30 str = s2r*cscrr sti = s2i*cscrr c1r = dabs(str) c1i = dabs(sti) c1m = dmax1(c1r,c1i) if (c1m.le.ascle) go to 30 iflag = iflag+1 ascle = bry(iflag) s1r = s1r*cscrr s1i = s1i*cscrr s2r = str s2i = sti csclr = csclr*tol cscrr = 1.0d0/csclr s1r = s1r*csclr s1i = s1i*csclr s2r = s2r*csclr s2i = s2i*csclr 30 continue yr(n) = s2r*cscrr yi(n) = s2i*cscrr if (n.eq.1) return nl = n - 1 fnui = dble(float(nl)) k = nl do 40 i=1,nl str = s2r sti = s2i s2r = (fnu+fnui)*(rzr*str-rzi*sti) + s1r s2i = (fnu+fnui)*(rzr*sti+rzi*str) + s1i s1r = str s1i = sti str = s2r*cscrr sti = s2i*cscrr yr(k) = str yi(k) = sti fnui = fnui - 1.0d0 k = k - 1 if (iflag.ge.3) go to 40 c1r = dabs(str) c1i = dabs(sti) c1m = dmax1(c1r,c1i) if (c1m.le.ascle) go to 40 iflag = iflag+1 ascle = bry(iflag) s1r = s1r*cscrr s1i = s1i*cscrr s2r = str s2i = sti csclr = csclr*tol cscrr = 1.0d0/csclr s1r = s1r*csclr s1i = s1i*csclr s2r = s2r*csclr s2i = s2i*csclr 40 continue return 50 continue nz = -1 if(nw.eq.(-2)) nz=-2 return 60 continue if (iform.eq.2) go to 70 c----------------------------------------------------------------------- c asymptotic expansion for i(fnu,z) for large fnu applied in c -pi/3.le.arg(z).le.pi/3 c----------------------------------------------------------------------- call zuni1(zr, zi, fnu, kode, n, yr, yi, nw, nlast, fnul, tol, * elim, alim) go to 80 70 continue c----------------------------------------------------------------------- c asymptotic expansion for j(fnu,z*exp(m*hpi)) for large fnu c applied in pi/3.lt.abs(arg(z)).le.pi/2 where m=+i or -i c and hpi=pi/2 c----------------------------------------------------------------------- call zuni2(zr, zi, fnu, kode, n, yr, yi, nw, nlast, fnul, tol, * elim, alim) 80 continue if (nw.lt.0) go to 50 nz = nw return 90 continue nlast = n return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zbunk(zr, zi, fnu, kode, mr, n, yr, yi, nz, tol, elim, * alim) c Refer to zbesk,zbesh c c zbunk computes the k bessel function for fnu.gt.fnul. c according to the uniform asymptotic expansion for k(fnu,z) c in zunk1 and the expansion for h(2,fnu,z) in zunk2 c c***routines called zunk1,zunk2 c c complex y,z double precision alim, ax, ay, elim, fnu, tol, yi, yr, zi, zr integer kode, mr, n, nz dimension yr(n), yi(n) nz = 0 ax = dabs(zr)*1.7321d0 ay = dabs(zi) if (ay.gt.ax) go to 10 c----------------------------------------------------------------------- c asymptotic expansion for k(fnu,z) for large fnu applied in c -pi/3.le.arg(z).le.pi/3 c----------------------------------------------------------------------- call zunk1(zr, zi, fnu, kode, mr, n, yr, yi, nz, tol, elim, alim) go to 20 10 continue c----------------------------------------------------------------------- c asymptotic expansion for h(2,fnu,z*exp(m*hpi)) for large fnu c applied in pi/3.lt.abs(arg(z)).le.pi/2 where m=+i or -i c and hpi=pi/2 c----------------------------------------------------------------------- call zunk2(zr, zi, fnu, kode, mr, n, yr, yi, nz, tol, elim, alim) 20 continue return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zmlri(zr, zi, fnu, kode, n, yr, yi, nz, tol) c geuz for g77 EXTERNAL zexp EXTERNAL zlog c Refer to zbesi,zbesk c c zmlri computes the i bessel function for re(z).ge.0.0 by the c miller algorithm normalized by a neumann series. c c***routines called dgamln,d1mach,zabs2,zexp,zlog,zmlt c c complex ck,cnorm,cone,ctwo,czero,pt,p1,p2,rz,sum,y,z double precision ack, ak, ap, at, az, bk, cki, ckr, cnormi, * cnormr, conei, coner, fkap, fkk, flam, fnf, fnu, pti, ptr, p1i, * p1r, p2i, p2r, raz, rho, rho2, rzi, rzr, scle, sti, str, sumi, * sumr, tfnf, tol, tst, yi, yr, zeroi, zeror, zi, zr, dgamln, * d1mach, zabs2 integer i, iaz, idum, ifnu, inu, itime, k, kk, km, kode, m, n, nz dimension yr(n), yi(n) data zeror,zeroi,coner,conei / 0.0d0, 0.0d0, 1.0d0, 0.0d0 / scle = d1mach(1)/tol nz=0 az = zabs2(zr,zi) iaz = int(sngl(az)) ifnu = int(sngl(fnu)) inu = ifnu + n - 1 at = dble(float(iaz)) + 1.0d0 raz = 1.0d0/az str = zr*raz sti = -zi*raz ckr = str*at*raz cki = sti*at*raz rzr = (str+str)*raz rzi = (sti+sti)*raz p1r = zeror p1i = zeroi p2r = coner p2i = conei ack = (at+1.0d0)*raz rho = ack + dsqrt(ack*ack-1.0d0) rho2 = rho*rho tst = (rho2+rho2)/((rho2-1.0d0)*(rho-1.0d0)) tst = tst/tol c----------------------------------------------------------------------- c compute relative truncation error index for series c----------------------------------------------------------------------- ak = at do 10 i=1,80 ptr = p2r pti = p2i p2r = p1r - (ckr*ptr-cki*pti) p2i = p1i - (cki*ptr+ckr*pti) p1r = ptr p1i = pti ckr = ckr + rzr cki = cki + rzi ap = zabs2(p2r,p2i) if (ap.gt.tst*ak*ak) go to 20 ak = ak + 1.0d0 10 continue go to 110 20 continue i = i + 1 k = 0 if (inu.lt.iaz) go to 40 c----------------------------------------------------------------------- c compute relative truncation error for ratios c----------------------------------------------------------------------- p1r = zeror p1i = zeroi p2r = coner p2i = conei at = dble(float(inu)) + 1.0d0 str = zr*raz sti = -zi*raz ckr = str*at*raz cki = sti*at*raz ack = at*raz tst = dsqrt(ack/tol) itime = 1 do 30 k=1,80 ptr = p2r pti = p2i p2r = p1r - (ckr*ptr-cki*pti) p2i = p1i - (ckr*pti+cki*ptr) p1r = ptr p1i = pti ckr = ckr + rzr cki = cki + rzi ap = zabs2(p2r,p2i) if (ap.lt.tst) go to 30 if (itime.eq.2) go to 40 ack = zabs2(ckr,cki) flam = ack + dsqrt(ack*ack-1.0d0) fkap = ap/zabs2(p1r,p1i) rho = dmin1(flam,fkap) tst = tst*dsqrt(rho/(rho*rho-1.0d0)) itime = 2 30 continue go to 110 40 continue c----------------------------------------------------------------------- c backward recurrence and sum normalizing relation c----------------------------------------------------------------------- k = k + 1 kk = max0(i+iaz,k+inu) fkk = dble(float(kk)) p1r = zeror p1i = zeroi c----------------------------------------------------------------------- c scale p2 and sum by scle c----------------------------------------------------------------------- p2r = scle p2i = zeroi fnf = fnu - dble(float(ifnu)) tfnf = fnf + fnf bk = dgamln(fkk+tfnf+1.0d0,idum) - dgamln(fkk+1.0d0,idum) - * dgamln(tfnf+1.0d0,idum) bk = dexp(bk) sumr = zeror sumi = zeroi km = kk - inu do 50 i=1,km ptr = p2r pti = p2i p2r = p1r + (fkk+fnf)*(rzr*ptr-rzi*pti) p2i = p1i + (fkk+fnf)*(rzi*ptr+rzr*pti) p1r = ptr p1i = pti ak = 1.0d0 - tfnf/(fkk+tfnf) ack = bk*ak sumr = sumr + (ack+bk)*p1r sumi = sumi + (ack+bk)*p1i bk = ack fkk = fkk - 1.0d0 50 continue yr(n) = p2r yi(n) = p2i if (n.eq.1) go to 70 do 60 i=2,n ptr = p2r pti = p2i p2r = p1r + (fkk+fnf)*(rzr*ptr-rzi*pti) p2i = p1i + (fkk+fnf)*(rzi*ptr+rzr*pti) p1r = ptr p1i = pti ak = 1.0d0 - tfnf/(fkk+tfnf) ack = bk*ak sumr = sumr + (ack+bk)*p1r sumi = sumi + (ack+bk)*p1i bk = ack fkk = fkk - 1.0d0 m = n - i + 1 yr(m) = p2r yi(m) = p2i 60 continue 70 continue if (ifnu.le.0) go to 90 do 80 i=1,ifnu ptr = p2r pti = p2i p2r = p1r + (fkk+fnf)*(rzr*ptr-rzi*pti) p2i = p1i + (fkk+fnf)*(rzr*pti+rzi*ptr) p1r = ptr p1i = pti ak = 1.0d0 - tfnf/(fkk+tfnf) ack = bk*ak sumr = sumr + (ack+bk)*p1r sumi = sumi + (ack+bk)*p1i bk = ack fkk = fkk - 1.0d0 80 continue 90 continue ptr = zr pti = zi if (kode.eq.2) ptr = zeror call zlog(rzr, rzi, str, sti, idum) p1r = -fnf*str + ptr p1i = -fnf*sti + pti ap = dgamln(1.0d0+fnf,idum) ptr = p1r - ap pti = p1i c----------------------------------------------------------------------- c the division cexp(pt)/(sum+p2) is altered to avoid overflow c in the denominator by squaring large quantities c----------------------------------------------------------------------- p2r = p2r + sumr p2i = p2i + sumi ap = zabs2(p2r,p2i) p1r = 1.0d0/ap call zexp(ptr, pti, str, sti) ckr = str*p1r cki = sti*p1r ptr = p2r*p1r pti = -p2i*p1r call zmlt(ckr, cki, ptr, pti, cnormr, cnormi) do 100 i=1,n str = yr(i)*cnormr - yi(i)*cnormi yi(i) = yr(i)*cnormi + yi(i)*cnormr yr(i) = str 100 continue return 110 continue nz=-2 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zseri(zr, zi, fnu, kode, n, yr, yi, nz, tol, elim, * alim) c geuz for g77 EXTERNAL zlog c Refer to zbesi,zbesk c c zseri computes the i bessel function for real(z).ge.0.0 by c means of the power series for large cabs(z) in the c region cabs(z).le.2*sqrt(fnu+1). nz=0 is a normal return. c nz.gt.0 means that the last nz components were set to zero c due to underflow. nz.lt.0 means underflow occurred, but the c condition cabs(z).le.2*sqrt(fnu+1) was violated and the c computation must be completed in another routine with n=n-abs(nz). c c***routines called dgamln,d1mach,zuchk,zabs2,zdiv,zlog,zmlt c c complex ak1,ck,coef,cone,crsc,cscl,cz,czero,hz,rz,s1,s2,y,z double precision aa, acz, ak, ak1i, ak1r, alim, arm, ascle, atol, * az, cki, ckr, coefi, coefr, conei, coner, crscr, czi, czr, dfnu, * elim, fnu, fnup, hzi, hzr, raz, rs, rtr1, rzi, rzr, s, ss, sti, * str, s1i, s1r, s2i, s2r, tol, yi, yr, wi, wr, zeroi, zeror, zi, * zr, dgamln, d1mach, zabs2 integer i, ib, idum, iflag, il, k, kode, l, m, n, nn, nz, nw dimension yr(n), yi(n), wr(2), wi(2) data zeror,zeroi,coner,conei / 0.0d0, 0.0d0, 1.0d0, 0.0d0 / c nz = 0 az = zabs2(zr,zi) if (az.eq.0.0d0) go to 160 arm = 1.0d+3*d1mach(1) rtr1 = dsqrt(arm) crscr = 1.0d0 iflag = 0 if (az.lt.arm) go to 150 hzr = 0.5d0*zr hzi = 0.5d0*zi czr = zeror czi = zeroi if (az.le.rtr1) go to 10 call zmlt(hzr, hzi, hzr, hzi, czr, czi) 10 continue acz = zabs2(czr,czi) nn = n call zlog(hzr, hzi, ckr, cki, idum) 20 continue dfnu = fnu + dble(float(nn-1)) fnup = dfnu + 1.0d0 c----------------------------------------------------------------------- c underflow test c----------------------------------------------------------------------- ak1r = ckr*dfnu ak1i = cki*dfnu ak = dgamln(fnup,idum) ak1r = ak1r - ak if (kode.eq.2) ak1r = ak1r - zr if (ak1r.gt.(-elim)) go to 40 30 continue nz = nz + 1 yr(nn) = zeror yi(nn) = zeroi if (acz.gt.dfnu) go to 190 nn = nn - 1 if (nn.eq.0) return go to 20 40 continue if (ak1r.gt.(-alim)) go to 50 iflag = 1 ss = 1.0d0/tol crscr = tol ascle = arm*ss 50 continue aa = dexp(ak1r) if (iflag.eq.1) aa = aa*ss coefr = aa*dcos(ak1i) coefi = aa*dsin(ak1i) atol = tol*acz/fnup il = min0(2,nn) do 90 i=1,il dfnu = fnu + dble(float(nn-i)) fnup = dfnu + 1.0d0 s1r = coner s1i = conei if (acz.lt.tol*fnup) go to 70 ak1r = coner ak1i = conei ak = fnup + 2.0d0 s = fnup aa = 2.0d0 60 continue rs = 1.0d0/s str = ak1r*czr - ak1i*czi sti = ak1r*czi + ak1i*czr ak1r = str*rs ak1i = sti*rs s1r = s1r + ak1r s1i = s1i + ak1i s = s + ak ak = ak + 2.0d0 aa = aa*acz*rs if (aa.gt.atol) go to 60 70 continue s2r = s1r*coefr - s1i*coefi s2i = s1r*coefi + s1i*coefr wr(i) = s2r wi(i) = s2i if (iflag.eq.0) go to 80 call zuchk(s2r, s2i, nw, ascle, tol) if (nw.ne.0) go to 30 80 continue m = nn - i + 1 yr(m) = s2r*crscr yi(m) = s2i*crscr if (i.eq.il) go to 90 call zdiv(coefr, coefi, hzr, hzi, str, sti) coefr = str*dfnu coefi = sti*dfnu 90 continue if (nn.le.2) return k = nn - 2 ak = dble(float(k)) raz = 1.0d0/az str = zr*raz sti = -zi*raz rzr = (str+str)*raz rzi = (sti+sti)*raz if (iflag.eq.1) go to 120 ib = 3 100 continue do 110 i=ib,nn yr(k) = (ak+fnu)*(rzr*yr(k+1)-rzi*yi(k+1)) + yr(k+2) yi(k) = (ak+fnu)*(rzr*yi(k+1)+rzi*yr(k+1)) + yi(k+2) ak = ak - 1.0d0 k = k - 1 110 continue return c----------------------------------------------------------------------- c recur backward with scaled values c----------------------------------------------------------------------- 120 continue c----------------------------------------------------------------------- c exp(-alim)=exp(-elim)/tol=approx. one precision above the c underflow limit = ascle = d1mach(1)*ss*1.0d+3 c----------------------------------------------------------------------- s1r = wr(1) s1i = wi(1) s2r = wr(2) s2i = wi(2) do 130 l=3,nn ckr = s2r cki = s2i s2r = s1r + (ak+fnu)*(rzr*ckr-rzi*cki) s2i = s1i + (ak+fnu)*(rzr*cki+rzi*ckr) s1r = ckr s1i = cki ckr = s2r*crscr cki = s2i*crscr yr(k) = ckr yi(k) = cki ak = ak - 1.0d0 k = k - 1 if (zabs2(ckr,cki).gt.ascle) go to 140 130 continue return 140 continue ib = l + 1 if (ib.gt.nn) return go to 100 150 continue nz = n if (fnu.eq.0.0d0) nz = nz - 1 160 continue yr(1) = zeror yi(1) = zeroi if (fnu.ne.0.0d0) go to 170 yr(1) = coner yi(1) = conei 170 continue if (n.eq.1) return do 180 i=2,n yr(i) = zeror yi(i) = zeroi 180 continue return c----------------------------------------------------------------------- c return with nz.lt.0 if cabs(z*z/4).gt.fnu+n-nz-1 complete c the calculation in cbinu with n=n-iabs(nz) c----------------------------------------------------------------------- 190 continue nz = -nz return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zwrsk(zrr, zri, fnu, kode, n, yr, yi, nz, cwr, cwi, * tol, elim, alim) c refer to zbesi,zbesk c c zwrsk computes the i bessel function for re(z).ge.0.0 by c normalizing the i function ratios from zrati by the wronskian c c***routines called d1mach,zbknu,zrati,zabs2 c complex cinu,cscl,ct,cw,c1,c2,rct,st,y,zr double precision act, acw, alim, ascle, cinui, cinur, csclr, cti, * ctr, cwi, cwr, c1i, c1r, c2i, c2r, elim, fnu, pti, ptr, ract, * sti, str, tol, yi, yr, zri, zrr, zabs2, d1mach integer i, kode, n, nw, nz dimension yr(n), yi(n), cwr(2), cwi(2) c----------------------------------------------------------------------- c i(fnu+i-1,z) by backward recurrence for ratios c y(i)=i(fnu+i,z)/i(fnu+i-1,z) from crati normalized by the c wronskian with k(fnu,z) and k(fnu+1,z) from cbknu. c----------------------------------------------------------------------- nz = 0 call zbknu(zrr, zri, fnu, kode, 2, cwr, cwi, nw, tol, elim, alim) if (nw.ne.0) go to 50 call zrati(zrr, zri, fnu, n, yr, yi, tol) c----------------------------------------------------------------------- c recur forward on i(fnu+1,z) = r(fnu,z)*i(fnu,z), c r(fnu+j-1,z)=y(j), j=1,...,n c----------------------------------------------------------------------- cinur = 1.0d0 cinui = 0.0d0 if (kode.eq.1) go to 10 cinur = dcos(zri) cinui = dsin(zri) 10 continue c----------------------------------------------------------------------- c on low exponent machines the k functions can be close to both c the under and overflow limits and the normalization must be c scaled to prevent over or underflow. cuoik has determined that c the result is on scale. c----------------------------------------------------------------------- acw = zabs2(cwr(2),cwi(2)) ascle = 1.0d+3*d1mach(1)/tol csclr = 1.0d0 if (acw.gt.ascle) go to 20 csclr = 1.0d0/tol go to 30 20 continue ascle = 1.0d0/ascle if (acw.lt.ascle) go to 30 csclr = tol 30 continue c1r = cwr(1)*csclr c1i = cwi(1)*csclr c2r = cwr(2)*csclr c2i = cwi(2)*csclr str = yr(1) sti = yi(1) c----------------------------------------------------------------------- c cinu=cinu*(conjg(ct)/cabs(ct))*(1.0d0/cabs(ct) prevents c under- or overflow prematurely by squaring cabs(ct) c----------------------------------------------------------------------- ptr = str*c1r - sti*c1i pti = str*c1i + sti*c1r ptr = ptr + c2r pti = pti + c2i ctr = zrr*ptr - zri*pti cti = zrr*pti + zri*ptr act = zabs2(ctr,cti) ract = 1.0d0/act ctr = ctr*ract cti = -cti*ract ptr = cinur*ract pti = cinui*ract cinur = ptr*ctr - pti*cti cinui = ptr*cti + pti*ctr yr(1) = cinur*csclr yi(1) = cinui*csclr if (n.eq.1) return do 40 i=2,n ptr = str*cinur - sti*cinui cinui = str*cinui + sti*cinur cinur = ptr str = yr(i) sti = yi(i) yr(i) = cinur*csclr yi(i) = cinui*csclr 40 continue return 50 continue nz = -1 if(nw.eq.(-2)) nz=-2 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zairy(zr, zi, id, kode, air, aii, nz, ierr) c geuz for g77 EXTERNAL zsqrt EXTERNAL zexp c Airy function,bessel functions of order one third c Author Amos, Donald E., Sandia National Laboratories c c on kode=1, zairy computes the complex airy function ai(z) or c its derivative dai(z)/dz on id=0 or id=1 respectively. on c kode=2, a scaling option cexp(zta)*ai(z) or cexp(zta)* c dai(z)/dz is provided to remove the exponential decay in c -pi/3.lt.arg(z).lt.pi/3 and the exponential growth in c pi/3.lt.abs(arg(z)).lt.pi where zta=(2/3)*z*csqrt(z). c c while the airy functions ai(z) and dai(z)/dz are analytic in c the whole z plane, the corresponding scaled functions defined c for kode=2 have a cut along the negative real axis. c c input zr,zi are double precision c zr,zi - z=cmplx(zr,zi) c id - order of derivative, id=0 or id=1 c kode - a parameter to indicate the scaling option c kode= 1 returns c ai=ai(z) on id=0 or c ai=dai(z)/dz on id=1 c = 2 returns c ai=cexp(zta)*ai(z) on id=0 or c ai=cexp(zta)*dai(z)/dz on id=1 where c zta=(2/3)*z*csqrt(z) c c output air,aii are double precision c air,aii- complex answer depending on the choices for id and c kode c nz - underflow indicator c nz= 0 , normal return c nz= 1 , ai=cmplx(0.0d0,0.0d0) due to underflow in c -pi/3.lt.arg(z).lt.pi/3 on kode=1 c ierr - error flag c ierr=0, normal return - computation completed c ierr=1, input error - no computation c ierr=2, overflow - no computation, real(zta) c too large on kode=1 c ierr=3, cabs(z) large - computation completed c losses of signifcance by argument reduction c produce less than half of machine accuracy c ierr=4, cabs(z) too large - no computation c complete loss of accuracy by argument c reduction c ierr=5, error - no computation, c algorithm termination condition not met c c c ai and dai are computed for cabs(z).gt.1.0 from the k bessel c functions by c c ai(z)=c*sqrt(z)*k(1/3,zta) , dai(z)=-c*z*k(2/3,zta) c c=1.0/(pi*sqrt(3.0)) c zta=(2/3)*z**(3/2) c c with the power series for cabs(z).le.1.0. c c in most complex variable computation, one must evaluate ele- c mentary functions. when the magnitude of z is large, losses c of significance by argument reduction occur. consequently, if c the magnitude of zeta=(2/3)*z**1.5 exceeds u1=sqrt(0.5/ur), c then losses exceeding half precision are likely and an error c flag ierr=3 is triggered where ur=dmax1(d1mach(4),1.0d-18) is c double precision unit roundoff limited to 18 digits precision. c also, if the magnitude of zeta is larger than u2=0.5/ur, then c all significance is lost and ierr=4. in order to use the int c function, zeta must be further restricted not to exceed the c largest integer, u3=i1mach(9). thus, the magnitude of zeta c must be restricted by min(u2,u3). on 32 bit machines, u1,u2, c and u3 are approximately 2.0e+3, 4.2e+6, 2.1e+9 in single c precision arithmetic and 1.3e+8, 1.8e+16, 2.1e+9 in double c precision arithmetic respectively. this makes u2 and u3 limit- c ing in their respective arithmetics. this means that the mag- c nitude of z cannot exceed 3.1e+4 in single and 2.1e+6 in c double precision arithmetic. this also means that one can c expect to retain, in the worst cases on 32 bit machines, c no digits in single precision and only 7 digits in double c precision arithmetic. similar considerations hold for other c machines. c c the approximate relative error in the magnitude of a complex c bessel function can be expressed by p*10**s where p=max(unit c roundoff,1.0e-18) is the nominal precision and 10**s repre- c sents the increase in error due to argument reduction in the c elementary functions. here, s=max(1,abs(log10(cabs(z))), c abs(log10(fnu))) approximately (i.e. s=max(1,abs(exponent of c cabs(z),abs(exponent of fnu)) ). however, the phase angle may c have only absolute accuracy. this is most likely to occur when c one component (in absolute value) is larger than the other by c several orders of magnitude. if one component is 10**k larger c than the other, then one can expect only max(abs(log10(p))-k, c 0) significant digits; or, stated another way, when k exceeds c the exponent of p, no significant digits remain in the smaller c component. however, the phase angle retains absolute accuracy c because, in complex arithmetic with precision p, the smaller c component will not (as a rule) decrease below p times the c magnitude of the larger component. in these extreme cases, c the principal phase angle is on the order of +p, -p, pi/2-p, c or -pi/2+p. c c***routines called zacai,zbknu,zexp,zsqrt,i1mach,d1mach c c complex ai,cone,csq,cy,s1,s2,trm1,trm2,z,zta,z3 double precision aa, ad, aii, air, ak, alim, atrm, az, az3, bk, * cc, ck, coef, conei, coner, csqi, csqr, cyi, cyr, c1, c2, dig, * dk, d1, d2, elim, fid, fnu, ptr, rl, r1m5, sfac, sti, str, * s1i, s1r, s2i, s2r, tol, trm1i, trm1r, trm2i, trm2r, tth, zeroi, * zeror, zi, zr, ztai, ztar, z3i, z3r, d1mach, zabs2, alaz, bb integer id, ierr, iflag, k, kode, k1, k2, mr, nn, nz, i1mach dimension cyr(1), cyi(1) data tth, c1, c2, coef /6.66666666666666667d-01, * 3.55028053887817240d-01,2.58819403792806799d-01, * 1.83776298473930683d-01/ data zeror, zeroi, coner, conei /0.0d0,0.0d0,1.0d0,0.0d0/ c***first executable statement zairy ierr = 0 nz=0 if (id.lt.0 .or. id.gt.1) ierr=1 if (kode.lt.1 .or. kode.gt.2) ierr=1 if (ierr.ne.0) return az = zabs2(zr,zi) tol = dmax1(d1mach(4),1.0d-18) fid = dble(float(id)) if (az.gt.1.0d0) go to 70 c----------------------------------------------------------------------- c power series for cabs(z).le.1. c----------------------------------------------------------------------- s1r = coner s1i = conei s2r = coner s2i = conei if (az.lt.tol) go to 170 aa = az*az if (aa.lt.tol/az) go to 40 trm1r = coner trm1i = conei trm2r = coner trm2i = conei atrm = 1.0d0 str = zr*zr - zi*zi sti = zr*zi + zi*zr z3r = str*zr - sti*zi z3i = str*zi + sti*zr az3 = az*aa ak = 2.0d0 + fid bk = 3.0d0 - fid - fid ck = 4.0d0 - fid dk = 3.0d0 + fid + fid d1 = ak*dk d2 = bk*ck ad = dmin1(d1,d2) ak = 24.0d0 + 9.0d0*fid bk = 30.0d0 - 9.0d0*fid do 30 k=1,25 str = (trm1r*z3r-trm1i*z3i)/d1 trm1i = (trm1r*z3i+trm1i*z3r)/d1 trm1r = str s1r = s1r + trm1r s1i = s1i + trm1i str = (trm2r*z3r-trm2i*z3i)/d2 trm2i = (trm2r*z3i+trm2i*z3r)/d2 trm2r = str s2r = s2r + trm2r s2i = s2i + trm2i atrm = atrm*az3/ad d1 = d1 + ak d2 = d2 + bk ad = dmin1(d1,d2) if (atrm.lt.tol*ad) go to 40 ak = ak + 18.0d0 bk = bk + 18.0d0 30 continue 40 continue if (id.eq.1) go to 50 air = s1r*c1 - c2*(zr*s2r-zi*s2i) aii = s1i*c1 - c2*(zr*s2i+zi*s2r) if (kode.eq.1) return call zsqrt(zr, zi, str, sti) ztar = tth*(zr*str-zi*sti) ztai = tth*(zr*sti+zi*str) call zexp(ztar, ztai, str, sti) ptr = air*str - aii*sti aii = air*sti + aii*str air = ptr return 50 continue air = -s2r*c2 aii = -s2i*c2 if (az.le.tol) go to 60 str = zr*s1r - zi*s1i sti = zr*s1i + zi*s1r cc = c1/(1.0d0+fid) air = air + cc*(str*zr-sti*zi) aii = aii + cc*(str*zi+sti*zr) 60 continue if (kode.eq.1) return call zsqrt(zr, zi, str, sti) ztar = tth*(zr*str-zi*sti) ztai = tth*(zr*sti+zi*str) call zexp(ztar, ztai, str, sti) ptr = str*air - sti*aii aii = str*aii + sti*air air = ptr return c----------------------------------------------------------------------- c case for cabs(z).gt.1.0 c----------------------------------------------------------------------- 70 continue fnu = (1.0d0+fid)/3.0d0 c----------------------------------------------------------------------- c set parameters related to machine constants. c tol is the approximate unit roundoff limited to 1.0d-18. c elim is the approximate exponential over- and underflow limit. c exp(-elim).lt.exp(-alim)=exp(-elim)/tol and c exp(elim).gt.exp(alim)=exp(elim)*tol are intervals near c underflow and overflow limits where scaled arithmetic is done. c rl is the lower boundary of the asymptotic expansion for large z. c dig = number of base 10 digits in tol = 10**(-dig). c----------------------------------------------------------------------- k1 = i1mach(15) k2 = i1mach(16) r1m5 = d1mach(5) k = min0(iabs(k1),iabs(k2)) elim = 2.303d0*(dble(float(k))*r1m5-3.0d0) k1 = i1mach(14) - 1 aa = r1m5*dble(float(k1)) dig = dmin1(aa,18.0d0) aa = aa*2.303d0 alim = elim + dmax1(-aa,-41.45d0) rl = 1.2d0*dig + 3.0d0 alaz = dlog(az) c-------------------------------------------------------------------------- c test for proper range c----------------------------------------------------------------------- aa=0.5d0/tol bb=dble(float(i1mach(9)))*0.5d0 aa=dmin1(aa,bb) aa=aa**tth if (az.gt.aa) go to 260 aa=dsqrt(aa) if (az.gt.aa) ierr=3 call zsqrt(zr, zi, csqr, csqi) ztar = tth*(zr*csqr-zi*csqi) ztai = tth*(zr*csqi+zi*csqr) c----------------------------------------------------------------------- c re(zta).le.0 when re(z).lt.0, especially when im(z) is small c----------------------------------------------------------------------- iflag = 0 sfac = 1.0d0 ak = ztai if (zr.ge.0.0d0) go to 80 bk = ztar ck = -dabs(bk) ztar = ck ztai = ak 80 continue if (zi.ne.0.0d0) go to 90 if (zr.gt.0.0d0) go to 90 ztar = 0.0d0 ztai = ak 90 continue aa = ztar if (aa.ge.0.0d0 .and. zr.gt.0.0d0) go to 110 if (kode.eq.2) go to 100 c----------------------------------------------------------------------- c overflow test c----------------------------------------------------------------------- if (aa.gt.(-alim)) go to 100 aa = -aa + 0.25d0*alaz iflag = 1 sfac = tol if (aa.gt.elim) go to 270 100 continue c----------------------------------------------------------------------- c cbknu and cacon return exp(zta)*k(fnu,zta) on kode=2 c----------------------------------------------------------------------- mr = 1 if (zi.lt.0.0d0) mr = -1 call zacai(ztar, ztai, fnu, kode, mr, 1, cyr, cyi, nn, rl, tol, * elim, alim) if (nn.lt.0) go to 280 nz = nz + nn go to 130 110 continue if (kode.eq.2) go to 120 c----------------------------------------------------------------------- c underflow test c----------------------------------------------------------------------- if (aa.lt.alim) go to 120 aa = -aa - 0.25d0*alaz iflag = 2 sfac = 1.0d0/tol if (aa.lt.(-elim)) go to 210 120 continue call zbknu(ztar, ztai, fnu, kode, 1, cyr, cyi, nz, tol, elim, * alim) 130 continue s1r = cyr(1)*coef s1i = cyi(1)*coef if (iflag.ne.0) go to 150 if (id.eq.1) go to 140 air = csqr*s1r - csqi*s1i aii = csqr*s1i + csqi*s1r return 140 continue air = -(zr*s1r-zi*s1i) aii = -(zr*s1i+zi*s1r) return 150 continue s1r = s1r*sfac s1i = s1i*sfac if (id.eq.1) go to 160 str = s1r*csqr - s1i*csqi s1i = s1r*csqi + s1i*csqr s1r = str air = s1r/sfac aii = s1i/sfac return 160 continue str = -(s1r*zr-s1i*zi) s1i = -(s1r*zi+s1i*zr) s1r = str air = s1r/sfac aii = s1i/sfac return 170 continue aa = 1.0d+3*d1mach(1) s1r = zeror s1i = zeroi if (id.eq.1) go to 190 if (az.le.aa) go to 180 s1r = c2*zr s1i = c2*zi 180 continue air = c1 - s1r aii = -s1i return 190 continue air = -c2 aii = 0.0d0 aa = dsqrt(aa) if (az.le.aa) go to 200 s1r = 0.5d0*(zr*zr-zi*zi) s1i = zr*zi 200 continue air = air + c1*s1r aii = aii + c1*s1i return 210 continue nz = 1 air = zeror aii = zeroi return 270 continue nz = 0 ierr=2 return 280 continue if(nn.eq.(-1)) go to 270 nz=0 ierr=5 return 260 continue ierr=4 nz=0 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine zbiry(zr, zi, id, kode, bir, bii, ierr) c geuz for g77 EXTERNAL zsqrt c Airy function,bessel functions of order one third c Author Amos, Donald E., Sandia National Laboratories c c on kode=1, cbiry computes the complex airy function bi(z) or c its derivative dbi(z)/dz on id=0 or id=1 respectively. on c kode=2, a scaling option cexp(-axzta)*bi(z) or cexp(-axzta)* c dbi(z)/dz is provided to remove the exponential behavior in c both the left and right half planes where c zta=(2/3)*z*csqrt(z)=cmplx(xzta,yzta) and axzta=abs(xzta). c c input zr,zi are double precision c zr,zi - z=cmplx(zr,zi) c id - order of derivative, id=0 or id=1 c kode - a parameter to indicate the scaling option c kode= 1 returns c bi=bi(z) on id=0 or c bi=dbi(z)/dz on id=1 c = 2 returns c bi=cexp(-axzta)*bi(z) on id=0 or c bi=cexp(-axzta)*dbi(z)/dz on id=1 where c zta=(2/3)*z*csqrt(z)=cmplx(xzta,yzta) c and axzta=abs(xzta) c c output bir,bii are double precision c bir,bii- complex answer depending on the choices for id and c kode c ierr - error flag c ierr=0, normal return - computation completed c ierr=1, input error - no computation c ierr=2, overflow - no computation, real(z) c too large on kode=1 c ierr=3, cabs(z) large - computation completed c losses of signifcance by argument reduction c produce less than half of machine accuracy c ierr=4, cabs(z) too large - no computation c complete loss of accuracy by argument c reduction c ierr=5, error - no computation, c algorithm termination condition not met c c bi and dbi are computed for cabs(z).gt.1.0 from the i bessel c functions by c c bi(z)=c*sqrt(z)*( i(-1/3,zta) + i(1/3,zta) ) c dbi(z)=c * z * ( i(-2/3,zta) + i(2/3,zta) ) c c=1.0/sqrt(3.0) c zta=(2/3)*z**(3/2) c c with the power series for cabs(z).le.1.0. c c in most complex variable computation, one must evaluate ele- c mentary functions. when the magnitude of z is large, losses c of significance by argument reduction occur. consequently, if c the magnitude of zeta=(2/3)*z**1.5 exceeds u1=sqrt(0.5/ur), c then losses exceeding half precision are likely and an error c flag ierr=3 is triggered where ur=dmax1(d1mach(4),1.0d-18) is c double precision unit roundoff limited to 18 digits precision. c also, if the magnitude of zeta is larger than u2=0.5/ur, then c all significance is lost and ierr=4. in order to use the int c function, zeta must be further restricted not to exceed the c largest integer, u3=i1mach(9). thus, the magnitude of zeta c must be restricted by min(u2,u3). on 32 bit machines, u1,u2, c and u3 are approximately 2.0e+3, 4.2e+6, 2.1e+9 in single c precision arithmetic and 1.3e+8, 1.8e+16, 2.1e+9 in double c precision arithmetic respectively. this makes u2 and u3 limit- c ing in their respective arithmetics. this means that the mag- c nitude of z cannot exceed 3.1e+4 in single and 2.1e+6 in c double precision arithmetic. this also means that one can c expect to retain, in the worst cases on 32 bit machines, c no digits in single precision and only 7 digits in double c precision arithmetic. similar considerations hold for other c machines. c c the approximate relative error in the magnitude of a complex c bessel function can be expressed by p*10**s where p=max(unit c roundoff,1.0e-18) is the nominal precision and 10**s repre- c sents the increase in error due to argument reduction in the c elementary functions. here, s=max(1,abs(log10(cabs(z))), c abs(log10(fnu))) approximately (i.e. s=max(1,abs(exponent of c cabs(z),abs(exponent of fnu)) ). however, the phase angle may c have only absolute accuracy. this is most likely to occur when c one component (in absolute value) is larger than the other by c several orders of magnitude. if one component is 10**k larger c than the other, then one can expect only max(abs(log10(p))-k, c 0) significant digits; or, stated another way, when k exceeds c the exponent of p, no significant digits remain in the smaller c component. however, the phase angle retains absolute accuracy c because, in complex arithmetic with precision p, the smaller c component will not (as a rule) decrease below p times the c magnitude of the larger component. in these extreme cases, c the principal phase angle is on the order of +p, -p, pi/2-p, c or -pi/2+p. c c***routines called zbinu,zabs2,zdiv,zsqrt,d1mach,i1mach c c complex bi,cone,csq,cy,s1,s2,trm1,trm2,z,zta,z3 double precision aa, ad, ak, alim, atrm, az, az3, bb, bii, bir, * bk, cc, ck, coef, conei, coner, csqi, csqr, cyi, cyr, c1, c2, * dig, dk, d1, d2, eaa, elim, fid, fmr, fnu, fnul, pi, rl, r1m5, * sfac, sti, str, s1i, s1r, s2i, s2r, tol, trm1i, trm1r, trm2i, * trm2r, tth, zi, zr, ztai, ztar, z3i, z3r, d1mach, zabs2 integer id, ierr, k, kode, k1, k2, nz, i1mach dimension cyr(2), cyi(2) data tth, c1, c2, coef, pi /6.66666666666666667d-01, * 6.14926627446000736d-01,4.48288357353826359d-01, * 5.77350269189625765d-01,3.14159265358979324d+00/ data coner, conei /1.0d0,0.0d0/ c ierr = 0 nz=0 if (id.lt.0 .or. id.gt.1) ierr=1 if (kode.lt.1 .or. kode.gt.2) ierr=1 if (ierr.ne.0) return az = zabs2(zr,zi) tol = dmax1(d1mach(4),1.0d-18) fid = dble(float(id)) if (az.gt.1.0e0) go to 70 c----------------------------------------------------------------------- c power series for cabs(z).le.1. c----------------------------------------------------------------------- s1r = coner s1i = conei s2r = coner s2i = conei if (az.lt.tol) go to 130 aa = az*az if (aa.lt.tol/az) go to 40 trm1r = coner trm1i = conei trm2r = coner trm2i = conei atrm = 1.0d0 str = zr*zr - zi*zi sti = zr*zi + zi*zr z3r = str*zr - sti*zi z3i = str*zi + sti*zr az3 = az*aa ak = 2.0d0 + fid bk = 3.0d0 - fid - fid ck = 4.0d0 - fid dk = 3.0d0 + fid + fid d1 = ak*dk d2 = bk*ck ad = dmin1(d1,d2) ak = 24.0d0 + 9.0d0*fid bk = 30.0d0 - 9.0d0*fid do 30 k=1,25 str = (trm1r*z3r-trm1i*z3i)/d1 trm1i = (trm1r*z3i+trm1i*z3r)/d1 trm1r = str s1r = s1r + trm1r s1i = s1i + trm1i str = (trm2r*z3r-trm2i*z3i)/d2 trm2i = (trm2r*z3i+trm2i*z3r)/d2 trm2r = str s2r = s2r + trm2r s2i = s2i + trm2i atrm = atrm*az3/ad d1 = d1 + ak d2 = d2 + bk ad = dmin1(d1,d2) if (atrm.lt.tol*ad) go to 40 ak = ak + 18.0d0 bk = bk + 18.0d0 30 continue 40 continue if (id.eq.1) go to 50 bir = c1*s1r + c2*(zr*s2r-zi*s2i) bii = c1*s1i + c2*(zr*s2i+zi*s2r) if (kode.eq.1) return call zsqrt(zr, zi, str, sti) ztar = tth*(zr*str-zi*sti) ztai = tth*(zr*sti+zi*str) aa = ztar aa = -dabs(aa) eaa = dexp(aa) bir = bir*eaa bii = bii*eaa return 50 continue bir = s2r*c2 bii = s2i*c2 if (az.le.tol) go to 60 cc = c1/(1.0d0+fid) str = s1r*zr - s1i*zi sti = s1r*zi + s1i*zr bir = bir + cc*(str*zr-sti*zi) bii = bii + cc*(str*zi+sti*zr) 60 continue if (kode.eq.1) return call zsqrt(zr, zi, str, sti) ztar = tth*(zr*str-zi*sti) ztai = tth*(zr*sti+zi*str) aa = ztar aa = -dabs(aa) eaa = dexp(aa) bir = bir*eaa bii = bii*eaa return c----------------------------------------------------------------------- c case for cabs(z).gt.1.0 c----------------------------------------------------------------------- 70 continue fnu = (1.0d0+fid)/3.0d0 c----------------------------------------------------------------------- c set parameters related to machine constants. c tol is the approximate unit roundoff limited to 1.0e-18. c elim is the approximate exponential over- and underflow limit. c exp(-elim).lt.exp(-alim)=exp(-elim)/tol and c exp(elim).gt.exp(alim)=exp(elim)*tol are intervals near c underflow and overflow limits where scaled arithmetic is done. c rl is the lower boundary of the asymptotic expansion for large z. c dig = number of base 10 digits in tol = 10**(-dig). c fnul is the lower boundary of the asymptotic series for large fnu. c----------------------------------------------------------------------- k1 = i1mach(15) k2 = i1mach(16) r1m5 = d1mach(5) k = min0(iabs(k1),iabs(k2)) elim = 2.303d0*(dble(float(k))*r1m5-3.0d0) k1 = i1mach(14) - 1 aa = r1m5*dble(float(k1)) dig = dmin1(aa,18.0d0) aa = aa*2.303d0 alim = elim + dmax1(-aa,-41.45d0) rl = 1.2d0*dig + 3.0d0 fnul = 10.0d0 + 6.0d0*(dig-3.0d0) c----------------------------------------------------------------------- c test for range c----------------------------------------------------------------------- aa=0.5d0/tol bb=dble(float(i1mach(9)))*0.5d0 aa=dmin1(aa,bb) aa=aa**tth if (az.gt.aa) go to 260 aa=dsqrt(aa) if (az.gt.aa) ierr=3 call zsqrt(zr, zi, csqr, csqi) ztar = tth*(zr*csqr-zi*csqi) ztai = tth*(zr*csqi+zi*csqr) c----------------------------------------------------------------------- c re(zta).le.0 when re(z).lt.0, especially when im(z) is small c----------------------------------------------------------------------- sfac = 1.0d0 ak = ztai if (zr.ge.0.0d0) go to 80 bk = ztar ck = -dabs(bk) ztar = ck ztai = ak 80 continue if (zi.ne.0.0d0 .or. zr.gt.0.0d0) go to 90 ztar = 0.0d0 ztai = ak 90 continue aa = ztar if (kode.eq.2) go to 100 c----------------------------------------------------------------------- c overflow test c----------------------------------------------------------------------- bb = dabs(aa) if (bb.lt.alim) go to 100 bb = bb + 0.25d0*dlog(az) sfac = tol if (bb.gt.elim) go to 190 100 continue fmr = 0.0d0 if (aa.ge.0.0d0 .and. zr.gt.0.0d0) go to 110 fmr = pi if (zi.lt.0.0d0) fmr = -pi ztar = -ztar ztai = -ztai 110 continue c----------------------------------------------------------------------- c aa=factor for analytic continuation of i(fnu,zta) c kode=2 returns exp(-abs(xzta))*i(fnu,zta) from cbesi c----------------------------------------------------------------------- call zbinu(ztar, ztai, fnu, kode, 1, cyr, cyi, nz, rl, fnul, tol, * elim, alim) if (nz.lt.0) go to 200 aa = fmr*fnu z3r = sfac str = dcos(aa) sti = dsin(aa) s1r = (str*cyr(1)-sti*cyi(1))*z3r s1i = (str*cyi(1)+sti*cyr(1))*z3r fnu = (2.0d0-fid)/3.0d0 call zbinu(ztar, ztai, fnu, kode, 2, cyr, cyi, nz, rl, fnul, tol, * elim, alim) cyr(1) = cyr(1)*z3r cyi(1) = cyi(1)*z3r cyr(2) = cyr(2)*z3r cyi(2) = cyi(2)*z3r c----------------------------------------------------------------------- c backward recur one step for orders -1/3 or -2/3 c----------------------------------------------------------------------- call zdiv(cyr(1), cyi(1), ztar, ztai, str, sti) s2r = (fnu+fnu)*str + cyr(2) s2i = (fnu+fnu)*sti + cyi(2) aa = fmr*(fnu-1.0d0) str = dcos(aa) sti = dsin(aa) s1r = coef*(s1r+s2r*str-s2i*sti) s1i = coef*(s1i+s2r*sti+s2i*str) if (id.eq.1) go to 120 str = csqr*s1r - csqi*s1i s1i = csqr*s1i + csqi*s1r s1r = str bir = s1r/sfac bii = s1i/sfac return 120 continue str = zr*s1r - zi*s1i s1i = zr*s1i + zi*s1r s1r = str bir = s1r/sfac bii = s1i/sfac return 130 continue aa = c1*(1.0d0-fid) + fid*c2 bir = aa bii = 0.0d0 return 190 continue ierr=2 nz=0 return 200 continue if(nz.eq.(-1)) go to 190 nz=0 ierr=5 return 260 continue ierr=4 nz=0 return end c----------------------------------------------------------------------- c----------------------------------------------------------------------- getdp-2.4.2-source/Numeric/Adapt.cpp000644 001750 001750 00000012231 12116424200 020726 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . // // Contributor(s): // Jean-Francois Remacle // #include #include "Adapt.h" #include "NumericUtils.h" #include "Message.h" #define SQU(a) ((a)*(a)) static int NN ; static double MINH , *ERR , *HH , *PP , E0, DIM ; /* ------------------------------------------------------------------------ */ /* f XXX */ /* ------------------------------------------------------------------------ */ /* h-type version 1 : minimize the number of elements while keeping a given global error */ double fH1 (double l){ int i; double val1 = 0.0, val2 = 0.0; for(i = 1 ; i <= NN ; i++){ val1 += pow(2.*l*SQU(ERR[i])*PP[i]/DIM, DIM/(2.*PP[i]+DIM)); val2 += SQU(ERR[i]) * pow(2.*l*SQU(ERR[i])*PP[i]/DIM, -2.*PP[i]/(2.*PP[i]+DIM)); } return ( -(val1 + l * (val2 - SQU(E0))) ); } /* h-type version 2 : minimize the error while keeping a given number of elements */ double fH2 (double l){ int i; double val1 = 0.0, val2 = 0.0, qi; for(i = 1 ; i <= NN ; i++){ qi = pow(DIM*l/(2.*PP[i]*SQU(ERR[i])), -DIM/(DIM+2.*PP[i])); val1 += SQU(ERR[i]) * pow(qi, -2.*PP[i]/DIM); val2 += qi; } return ( -(val1 + l * (val2 - E0)) ); } /* p-type : minimize error by modifying the interpolation order vector */ double fP1 (double l){ int i; double val1 = 0.0, val2 = 0.0, qi, e; for(i = 1 ; i <= NN ; i++){ e = ERR[i]; if(e == 0.0) e=1.e-12; qi = - log(2.*l*log(HH[i]/MINH)*SQU(e)) / log(HH[i]/MINH); val1 -= 0.5 * qi; val2 += pow(HH[i]/MINH, qi) * SQU(e); } return ( -(val1 + l * (val2 - SQU(E0))) ); } /* ------------------------------------------------------------------------ */ /* A d a p t */ /* ------------------------------------------------------------------------ */ double min1d (int method, double (*funct)(double), double *xmin){ double xx, fx, fb, fa, bx, ax, tol = 1.e-4; switch(method){ case H1: case P1: ax=1.e-12; xx=1.e2; break; default: ax=1.e-15; xx=1.e-12; break; } mnbrak(&ax,&xx,&bx,&fa,&fx,&fb,funct); return ( brent(ax,xx,bx,funct,tol,xmin) ); } /* Adapt return the constraint (N0 ou e0) for the optimzed problem */ double Adapt (int N, /* Number of elements */ int method, /* H1, H2, P1 or P2 */ int dim, /* 2 or 3 */ double *err, /* elementary errors */ double *h, /* elementary mesh sizes */ double *p, /* elementary exponents */ double e0){ /* prescribed error or number of elements */ int i, maxdeg = 999; double contr=0., pivrai, lambda, minf, qi, ri, pi, obj, obj2, minri=0., maxri=0.; double errmin=0., errmax=0.; h[N+1] = 1.0; p[N+1] = 1.0; NN = N; ERR = err; HH = h; PP = p; E0 = e0; DIM = (double)dim; for(i = 1 ; i <= N ; i++){ if(i == 1) errmin = errmax = err[i]; else{ errmin = std::min(errmin, err[i]); errmax = std::max(errmax, err[i]); } } switch (method) { case H1 : minf = min1d (method, fH1, &lambda); obj = 0.0; for(i = 1 ; i <= N ; i++){ qi = pow(2.*lambda*SQU(err[i])*p[i]/DIM, DIM/(2.*p[i]+DIM)); ri = pow(qi,1./DIM); if(i==1) minri = maxri = ri; if(err[i] == 0.0) ri = .5; minri = std::min(minri, ri); maxri = std::max(maxri, ri); obj += SQU(err[i]) * pow(ri, -2.*p[i]) ; h[i] = sqrt(2.) * h[i]/ri; p[i] = ri; } contr = fabs(minf); Message::Info("H-Refinement 1, Error %g=>%g, Objective %g, Reduction Factor %g->%g", e0, sqrt(obj), -minf, minri, maxri); break; case H2 : minf = min1d (method, fH2, &lambda); obj = 0.0; for(i = 1 ; i <= N ; i++){ qi = pow((DIM*lambda)/(2.*SQU(err[i])*p[i]), -DIM/(DIM+2.*p[i])); ri = pow(qi, 1./DIM); if(i == 1) minri = maxri = ri; minri = std::min(minri, ri); maxri = std::max(maxri, ri); obj += pow(ri,DIM) ; h[i] = h[i]/ri; p[i] = p[i]; } contr = sqrt(fabs(minf)); Message::Info("H-Refinement 2, Elements %g=>%g, Objective %g, Reduction Factor %g->%g", e0, obj, 100. * sqrt(fabs(minf)), minri, maxri); break; case P1 : MINH = h[1]; for(i = 1 ; i <= N ; i++) MINH = std::min(h[i], MINH); MINH /= 2.; minf = min1d (method, fP1, &lambda); obj = obj2 = 0.0; for(i = 1 ; i <= N ; i++){ qi = -log(2.*lambda*SQU(err[i])*log(h[i]/MINH)) / log(h[i]/MINH); pi = p[i] - .5 * qi; pivrai = std::min(std::max(1., (double)(int)(pi+.99)), (double)maxdeg); obj2 += pow(h[i]/MINH, 2.*(p[i]-pivrai)) * SQU(err[i]); obj += SQU(err[i]) * pow(h[i]/MINH, qi); h[i] = h[i]; p[i] = pi; } contr = fabs(minf); Message::Info("P-Refinement, Error %g=%g=>%g, Objective %g", e0, sqrt(obj), sqrt(obj2), minf); break; case P2 : minf = min1d (method, fH1, &lambda); break; default : Message::Error("Unknown adaptation method"); } return (contr) ; } getdp-2.4.2-source/Main/Main.cpp000644 001750 001750 00000001531 12140705170 020051 0ustar00geuzainegeuzaine000000 000000 // GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine // // See the LICENSE.txt file for license information. Please report all // bugs and problems to the public mailing list . #include #include "MainLegacy.h" #include "Message.h" #include "GetDP.h" int main(int argc, char **argv) { #if 1 Message::SetExitOnError(true); MainLegacy(argc, argv); #endif #if 0 // debug memory leaks for(int i = 0; i < 100; i++){ printf("solving problem %d\n", i); MainLegacy(argc, argv); } #endif #if 0 // test simple standalone interface std::vector args; args.push_back("getdp"); args.push_back("benchmarks/machines/pmsm.pro"); args.push_back("-solve"); args.push_back("TimeDomain"); args.push_back("-pos"); args.push_back("Get_LocalFields"); for(int i = 1; i < 10; i++) GetDP(args); #endif } getdp-2.4.2-source/CMakeLists.txt000644 001750 001750 00000107046 12205340472 020347 0ustar00geuzainegeuzaine000000 000000 # GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine # # See the LICENSE.txt file for license information. Please report all # bugs and problems to the public mailing list . cmake_minimum_required(VERSION 2.8 FATAL_ERROR) # do not warn about non-definition of WIN32 on cygwin set(CMAKE_LEGACY_CYGWIN_WIN32 0) # if CMAKE_BUILD_TYPE is specified use it; otherwise set the default # build type to "RelWithDebInfo" ("-O2 -g" with gcc) prior to calling # project() if(DEFINED CMAKE_BUILD_TYPE) set(CMAKE_BUILD_TYPE ${CMAKE_BUILD_TYPE} CACHE STRING "Choose build type") else(DEFINED CMAKE_BUILD_TYPE) set(CMAKE_BUILD_TYPE RelWithDebInfo CACHE STRING "Choose build type") endif(DEFINED CMAKE_BUILD_TYPE) # this variable controls the default value of the options which are normally set # to ON (useful if you want to configure a minimal version of GetDP: e.g. "cmake # -DDEFAULT=0 -DENABLE_PETSC=1") set(DEFAULT ON CACHE INTERNAL "Default value for enabled-by-default options") macro(opt OPTION HELP VALUE) option(ENABLE_${OPTION} ${HELP} ${VALUE}) set(OPT_TEXI "${OPT_TEXI}\n@item ENABLE_${OPTION}\n${HELP} (default: ${VALUE})") endmacro(opt) opt(ARPACK "Enable Arpack eigensolver (requires Fortran)" ${DEFAULT}) opt(BLAS_LAPACK "Enable BLAS/Lapack for linear algebra (e.g. for Arpack)" ${DEFAULT}) opt(BUILD_LIB "Enable 'lib' target for building static GetDP library" OFF) opt(BUILD_SHARED "Enable 'shared' target for building shared GetDP library" OFF) opt(BUILD_ANDROID "Enable Android NDK library target (experimental)" OFF) opt(FORTRAN "Enable Fortran (needed for Arpack/Sparskit/Zitsol & Bessel)" ${DEFAULT}) opt(GMSH "Enable Gmsh functions (for field interpolation)" ${DEFAULT}) opt(GSL "Enable GSL functions (for some built-in functions)" ${DEFAULT}) opt(LEGACY "Use legacy assembler (required for actual computations)" ON) opt(MPI "Enable MPI parallelization (with PETSc/SLEPc)" OFF) opt(NR "Enable NR functions (if GSL is unavailable)" ${DEFAULT}) opt(NX "Enable proprietary NX extension" OFF) opt(OPENMP "Enable OpenMP parallelization of some functions (experimental)" OFF) opt(PETSC "Enable PETSc linear solver" ${DEFAULT}) opt(SLEPC "Enable SLEPc eigensolver" ${DEFAULT}) opt(SPARSKIT "Enable Sparskit solver instead of PETSc (requires Fortran)" ${DEFAULT}) opt(ZITSOL "Enable Zitsol solvers (requires PETSc and Fortran)" OFF) if(ENABLE_FORTRAN) project(getdp CXX C Fortran) else(ENABLE_FORTRAN) project(getdp CXX C) endif(ENABLE_FORTRAN) set(GETDP_MAJOR_VERSION 2) set(GETDP_MINOR_VERSION 4) set(GETDP_PATCH_VERSION 2) set(GETDP_EXTRA_VERSION "" CACHE STRING "GetDP extra version string") set(GETDP_VERSION "${GETDP_MAJOR_VERSION}.${GETDP_MINOR_VERSION}") set(GETDP_VERSION "${GETDP_VERSION}.${GETDP_PATCH_VERSION}${GETDP_EXTRA_VERSION}") set(GETDP_SHORT_LICENSE "GNU General Public License") set(GETDP_API ${CMAKE_CURRENT_BINARY_DIR}/Common/GetDPConfig.h ${CMAKE_CURRENT_BINARY_DIR}/Common/GetDPVersion.h Legacy/GetDP.h ) execute_process(COMMAND date "+%Y%m%d" OUTPUT_VARIABLE DATE OUTPUT_STRIP_TRAILING_WHITESPACE) execute_process(COMMAND hostname OUTPUT_VARIABLE HOSTNAME OUTPUT_STRIP_TRAILING_WHITESPACE) execute_process(COMMAND whoami OUTPUT_VARIABLE PACKAGER OUTPUT_STRIP_TRAILING_WHITESPACE) if(NOT DATE) set(DATE "unknown") endif(NOT DATE) set(GETDP_DATE "${DATE}") if(NOT HOSTNAME) set(HOSTNAME "unknown") endif(NOT HOSTNAME) set(GETDP_HOST "${HOSTNAME}") if(NOT PACKAGER) set(PACKAGER "unknown") endif(NOT PACKAGER) set(GETDP_PACKAGER "${PACKAGER}") if(APPLE) set(GETDP_OS "MacOSX") elseif(CYGWIN) set(GETDP_OS "Windows") else(APPLE) set(GETDP_OS "${CMAKE_SYSTEM_NAME}") endif(APPLE) include(CheckTypeSize) include(CheckFunctionExists) include(CheckIncludeFile) include(CheckCXXCompilerFlag) if(MSVC) if(ENABLE_MSVC_STATIC_RUNTIME) foreach(VAR CMAKE_CXX_FLAGS CMAKE_CXX_FLAGS_DEBUG CMAKE_CXX_FLAGS_RELEASE CMAKE_CXX_FLAGS_MINSIZEREL CMAKE_CXX_FLAGS_RELWITHDEBINFO CMAKE_C_FLAGS CMAKE_C_FLAGS_DEBUG CMAKE_C_FLAGS_RELEASE CMAKE_C_FLAGS_MINSIZEREL CMAKE_C_FLAGS_RELWITHDEBINFO) if(${VAR} MATCHES "/MD") string(REGEX REPLACE "/MD" "/MT" ${VAR} "${${VAR}}") endif(${VAR} MATCHES "/MD") endforeach(VAR) endif(ENABLE_MSVC_STATIC_RUNTIME) endif(MSVC) if(ENABLE_OPENMP) find_package(OpenMP) if(OPENMP_FOUND) set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} ${OpenMP_C_FLAGS}") set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} ${OpenMP_CXX_FLAGS}") endif(OPENMP_FOUND) endif(ENABLE_OPENMP) macro(append_getdp_src DIRNAME FILES) foreach(FILE ${FILES}) list(APPEND LIST ${DIRNAME}/${FILE}) endforeach(FILE) set(GETDP_SRC ${GETDP_SRC};${LIST} PARENT_SCOPE) set(GETDP_DIRS ${GETDP_DIRS};${DIRNAME} PARENT_SCOPE) endmacro(append_getdp_src) macro(find_all_libraries VARNAME LISTNAME PATH SUFFIX) set(${VARNAME}) list(LENGTH ${LISTNAME} NUM_LIST) foreach(LIB ${${LISTNAME}}) find_library(FOUND_LIB ${LIB} PATHS ${PATH} PATH_SUFFIXES ${SUFFIX}) if(FOUND_LIB) list(APPEND ${VARNAME} ${FOUND_LIB}) endif(FOUND_LIB) unset(FOUND_LIB CACHE) endforeach(LIB) list(LENGTH ${VARNAME} NUM_FOUND_LIBRARIES) if(NUM_FOUND_LIBRARIES LESS NUM_LIST) set(${VARNAME}) endif(NUM_FOUND_LIBRARIES LESS NUM_LIST) endmacro(find_all_libraries) macro(set_config_option VARNAME STRING) set(${VARNAME} TRUE) list(APPEND CONFIG_OPTIONS ${STRING}) message(STATUS "Found " ${STRING}) endmacro(set_config_option) # check if the machine is 64 bits (this is more reliable than using # CMAKE_SIZEOF_VOID_P, which does not seem to work e.g. on some Suse # machines) check_type_size("void*" SIZEOF_VOID_P) if(SIZEOF_VOID_P EQUAL 8) set_config_option(HAVE_64BIT_SIZE_T "64Bit") endif(SIZEOF_VOID_P EQUAL 8) if(ENABLE_BLAS_LAPACK) if(MSVC) # on Windows with Visual C++ try really hard to find blas/lapack # *without* requiring a Fortran compiler: 1) try to find the Intel # MKL libs using the standard search path; if not found 2) try to # get the reference blas/lapack libs (useful for users with no # Fortran compiler and no MKL license, who can just download our # precompiled "getdp-dep" package) if(HAVE_64BIT_SIZE_T) set(MKL_PATH em64t/lib) else(HAVE_64BIT_SIZE_T) set(MKL_PATH ia32/lib) endif(HAVE_64BIT_SIZE_T) set(MKL_LIBS_REQUIRED libguide40 mkl_intel_c mkl_intel_thread mkl_core) find_all_libraries(LAPACK_LIBRARIES MKL_LIBS_REQUIRED "" ${MKL_PATH}) if(LAPACK_LIBRARIES) set_config_option(HAVE_BLAS "Blas(IntelMKL)") set_config_option(HAVE_LAPACK "Lapack(IntelMKL)") else(LAPACK_LIBRARIES) set(REFLAPACK_LIBS_REQUIRED lapack blas g2c gcc) find_all_libraries(LAPACK_LIBRARIES REFLAPACK_LIBS_REQUIRED "" "") if(LAPACK_LIBRARIES) set_config_option(HAVE_BLAS "Blas(Ref)") set_config_option(HAVE_LAPACK "Lapack(Ref)") endif(LAPACK_LIBRARIES) endif(LAPACK_LIBRARIES) elseif(${CMAKE_SYSTEM_NAME} MATCHES "Linux") # on Linux try to find the Intel MKL without a Fortran compiler if(HAVE_64BIT_SIZE_T) set(MKL_PATH lib/em64t) else(HAVE_64BIT_SIZE_T) set(MKL_PATH lib/32) endif(HAVE_64BIT_SIZE_T) set(MKL_LIBS_REQUIRED mkl_gf_lp64 iomp5 mkl_gnu_thread mkl_core guide pthread) find_all_libraries(LAPACK_LIBRARIES MKL_LIBS_REQUIRED "" ${MKL_PATH}) if(NOT LAPACK_LIBRARIES) # match lapack 9.0 on 64bit set(MKL_LIBS_REQUIRED mkl_lapack mkl_em64t guide) find_all_libraries(LAPACK_LIBRARIES MKL_LIBS_REQUIRED "" ${MKL_PATH}) endif(NOT LAPACK_LIBRARIES) if(LAPACK_LIBRARIES) set_config_option(HAVE_BLAS "Blas(IntelMKL)") set_config_option(HAVE_LAPACK "Lapack(IntelMKL)") else(LAPACK_LIBRARIES) # on Linux also try to find ATLAS without a Fortran compiler, # because cmake ships with a buggy FindBLAS e.g. on Ubuntu Lucid # Lynx set(ATLAS_LIBS_REQUIRED lapack f77blas cblas atlas) find_all_libraries(LAPACK_LIBRARIES ATLAS_LIBS_REQUIRED "" "") if(LAPACK_LIBRARIES) set_config_option(HAVE_BLAS "Blas(ATLAS)") set_config_option(HAVE_LAPACK "Lapack(ATLAS)") else(LAPACK_LIBRARIES) # try with generic names set(GENERIC_LIBS_REQUIRED lapack blas pthread) find_all_libraries(LAPACK_LIBRARIES GENERIC_LIBS_REQUIRED "" "") if(LAPACK_LIBRARIES) set_config_option(HAVE_BLAS "Blas(Generic)") set_config_option(HAVE_LAPACK "Lapack(Generic)") find_library(GFORTRAN_LIB gfortran) if(GFORTRAN_LIB) list(APPEND LAPACK_LIBRARIES ${GFORTRAN_LIB}) endif(GFORTRAN_LIB) endif(LAPACK_LIBRARIES) endif(LAPACK_LIBRARIES) endif(LAPACK_LIBRARIES) elseif(${CMAKE_SYSTEM_NAME} MATCHES "SunOS") # on SunOS we know blas and lapack are available in sunperf set(LAPACK_FLAGS -library=sunperf) set_config_option(HAVE_BLAS "Blas(SubPerf)") set_config_option(HAVE_LAPACK "Lapack(SunPerf)") elseif(APPLE) # on Mac we also know that blas and lapack are available set(LAPACK_LIBRARIES "-framework vecLib") set_config_option(HAVE_BLAS "Blas(VecLib)") set_config_option(HAVE_LAPACK "Lapack(VecLib)") endif(MSVC) if(NOT HAVE_BLAS OR NOT HAVE_LAPACK) # if we haven't found blas and lapack without using the standard # cmake tests, do it (this requires a working Fortran compiler) enable_language(Fortran) find_package(BLAS) if(BLAS_FOUND) set_config_option(HAVE_BLAS "Blas") find_package(LAPACK) if(LAPACK_FOUND) set_config_option(HAVE_LAPACK "Lapack") else(LAPACK_FOUND) set(LAPACK_LIBRARIES ${BLAS_LIBRARIES}) endif(LAPACK_FOUND) endif(BLAS_FOUND) endif(NOT HAVE_BLAS OR NOT HAVE_LAPACK) endif(ENABLE_BLAS_LAPACK) add_subdirectory(Common) add_subdirectory(Interface) add_subdirectory(Numeric) if(ENABLE_LEGACY) add_subdirectory(Legacy) set_config_option(HAVE_LEGACY "Legacy") endif(ENABLE_LEGACY) if(ENABLE_MPI) find_package(MPI) if(MPI_FOUND) set_config_option(HAVE_MPI "MPI") list(APPEND EXTERNAL_INCLUDES ${MPI_INCLUDE_DIR}) list(APPEND EXTERNAL_LIBRARIES ${MPI_LIBRARIES}) include(CMakeForceCompiler) cmake_force_c_compiler(${MPI_C_COMPILER} "MPI C Compiler") cmake_force_cxx_compiler(${MPI_CXX_COMPILER} "MPI C++ Compiler") cmake_force_fortran_compiler(${MPI_Fortran_COMPILER} "MPI Fortran Compiler") endif(MPI_FOUND) endif(ENABLE_MPI) if(ENABLE_GMSH) find_library(GMSH_LIB Gmsh PATH_SUFFIXES lib) find_path(GMSH_INC "Gmsh.h" PATH_SUFFIXES include gmsh include/gmsh) if(GMSH_LIB AND GMSH_INC) list(APPEND EXTERNAL_LIBRARIES ${GMSH_LIB}) list(APPEND EXTERNAL_INCLUDES ${GMSH_INC}) set_config_option(HAVE_GMSH "Gmsh") endif(GMSH_LIB AND GMSH_INC) endif(ENABLE_GMSH) if(ENABLE_PETSC) if(PETSC_DIR) set(ENV_PETSC_DIR ${PETSC_DIR}) else(PETSC_DIR) set(ENV_PETSC_DIR $ENV{PETSC_DIR}) endif(PETSC_DIR) if(PETSC_ARCH) set(ENV_PETSC_ARCH ${PETSC_ARCH}) else(PETSC_ARCH) set(ENV_PETSC_ARCH $ENV{PETSC_ARCH}) endif(PETSC_ARCH) if(EXISTS ${ENV_PETSC_DIR}/${ENV_PETSC_ARCH}/conf/petscvariables) # old-style PETSc installations (using PETSC_DIR and PETSC_ARCH) message(STATUS "Using PETSc dir: ${ENV_PETSC_DIR}") message(STATUS "Using PETSc arch: ${ENV_PETSC_ARCH}") file(STRINGS ${ENV_PETSC_DIR}/${ENV_PETSC_ARCH}/conf/petscvariables PETSC_VARIABLES NEWLINE_CONSUME) # find include directories list(APPEND EXTERNAL_INCLUDES ${ENV_PETSC_DIR}/include) list(APPEND EXTERNAL_INCLUDES ${ENV_PETSC_DIR}/${ENV_PETSC_ARCH}/include) string(REGEX MATCH "PACKAGES_INCLUDES = [^\n\r]*" PETSC_PACKAGES_INCLUDES ${PETSC_VARIABLES}) if(PETSC_PACKAGES_INCLUDES) string(REPLACE "PACKAGES_INCLUDES = " "" PETSC_PACKAGES_INCLUDES ${PETSC_PACKAGES_INCLUDES}) if(PETSC_PACKAGES_INCLUDES) string(REPLACE "-I" "" PETSC_PACKAGES_INCLUDES ${PETSC_PACKAGES_INCLUDES}) string(REPLACE " " ";" PETSC_PACKAGES_INCLUDES ${PETSC_PACKAGES_INCLUDES}) foreach(VAR ${PETSC_PACKAGES_INCLUDES}) list(APPEND EXTERNAL_INCLUDES ${VAR}) endforeach(VAR) endif(PETSC_PACKAGES_INCLUDES) endif(PETSC_PACKAGES_INCLUDES) # find libraries (<= 3.0) set(PETSC_LIBS_REQUIRED petscksp petscdm petscmat petscvec petsc) find_all_libraries(PETSC_LIBS PETSC_LIBS_REQUIRED ${ENV_PETSC_DIR}/${ENV_PETSC_ARCH}/lib "") # petsc 3.1 creates only one library (libpetsc) if(NOT PETSC_LIBS) find_library(PETSC_LIBS petsc PATHS ${ENV_PETSC_DIR}/${ENV_PETSC_ARCH}/lib) endif(NOT PETSC_LIBS) if(PETSC_LIBS) set_config_option(HAVE_PETSC "PETSc") endif(PETSC_LIBS) # find slepc (needs to be linked in before petsc) if(ENABLE_SLEPC) if(SLEPC_DIR) set(ENV_SLEPC_DIR ${SLEPC_DIR}) else(SLEPC_DIR) set(ENV_SLEPC_DIR $ENV{SLEPC_DIR}) endif(SLEPC_DIR) find_library(SLEPC_LIB slepc PATHS ${ENV_SLEPC_DIR}/${ENV_PETSC_ARCH}/lib) if(SLEPC_LIB) find_path(SLEPC_INC "slepc.h" PATHS ${ENV_SLEPC_DIR} PATH_SUFFIXES include ${ENV_PETSC_ARCH}/include include/slepc) if(SLEPC_INC) message(STATUS "Using SLEPc dir: ${ENV_SLEPC_DIR}") set_config_option(HAVE_SLEPC "SLEPc") list(APPEND EXTERNAL_LIBRARIES ${SLEPC_LIB}) list(APPEND EXTERNAL_INCLUDES ${SLEPC_INC}) find_path(SLEPC_INC2 "slepcconf.h" PATHS ${ENV_SLEPC_DIR} PATH_SUFFIXES ${ENV_PETSC_ARCH}/include) if(SLEPC_INC2) list(APPEND EXTERNAL_INCLUDES ${SLEPC_INC2}) endif(SLEPC_INC2) endif(SLEPC_INC) endif(SLEPC_LIB) endif(ENABLE_SLEPC) list(APPEND EXTERNAL_LIBRARIES ${PETSC_LIBS}) # find additional libraries to link with string(REGEX MATCH "PACKAGES_LIBS = [^\n\r]*" PLIBS ${PETSC_VARIABLES}) if(PLIBS) string(REPLACE "PACKAGES_LIBS = " "" PLIBS ${PLIBS}) string(STRIP ${PLIBS} PLIBS) list(APPEND EXTERNAL_LIBRARIES "${PLIBS}") endif(PLIBS) string(REGEX MATCH "PETSC_EXTERNAL_LIB_BASIC = [^\n\r]*" PLIBS_BASIC ${PETSC_VARIABLES}) if(PLIBS_BASIC) string(REPLACE "PETSC_EXTERNAL_LIB_BASIC = " "" PLIBS_BASIC ${PLIBS_BASIC}) string(STRIP ${PLIBS_BASIC} PLIBS_BASIC) list(APPEND EXTERNAL_LIBRARIES "${PLIBS_BASIC}") endif(PLIBS_BASIC) string(REGEX MATCH "PCC_LINKER_LIBS = [^\n\r]*" LLIBS ${PETSC_VARIABLES}) if(LLIBS) string(REPLACE "PCC_LINKER_LIBS = " "" LLIBS ${LLIBS}) string(STRIP ${LLIBS} LLIBS) list(APPEND EXTERNAL_LIBRARIES "${LLIBS}") endif(LLIBS) else(EXISTS ${ENV_PETSC_DIR}/${ENV_PETSC_ARCH}/conf/petscvariables) # new-style PETSc installations (in standard system directories) find_library(PETSC_LIBS petsc) find_path(PETSC_INC "petsc.h" PATH_SUFFIXES include/petsc) if(PETSC_LIBS AND PETSC_INC) set_config_option(HAVE_PETSC "PETSc") if(ENABLE_SLEPC) find_library(SLEPC_LIB slepc) find_path(SLEPC_INC "slepc.h" PATH_SUFFIXES include/slepc) if(SLEPC_LIB AND SLEPC_INC) set_config_option(HAVE_SLEPC "SLEPc") list(APPEND EXTERNAL_LIBRARIES ${SLEPC_LIB}) list(APPEND EXTERNAL_INCLUDES ${SLEPC_INC}) endif(SLEPC_LIB AND SLEPC_INC) endif(ENABLE_SLEPC) list(APPEND EXTERNAL_LIBRARIES ${PETSC_LIBS}) list(APPEND EXTERNAL_INCLUDES ${PETSC_INC}) endif(PETSC_LIBS AND PETSC_INC) endif(EXISTS ${ENV_PETSC_DIR}/${ENV_PETSC_ARCH}/conf/petscvariables) endif(ENABLE_PETSC) if(ENABLE_ARPACK) if(HAVE_LAPACK OR HAVE_PETSC) find_library(ARPACK_LIB arpack PATH_SUFFIXES lib) if(ARPACK_LIB) list(APPEND EXTERNAL_LIBRARIES ${ARPACK_LIB}) set_config_option(HAVE_ARPACK "Arpack") endif(ARPACK_LIB) endif(HAVE_LAPACK OR HAVE_PETSC) endif(ENABLE_ARPACK) if(ENABLE_FORTRAN) if(ENABLE_SPARSKIT AND NOT HAVE_PETSC) add_subdirectory(contrib/Sparskit) include_directories(contrib/Sparskit) set_config_option(HAVE_SPARSKIT "Sparskit") file(GLOB_RECURSE SPARSKIT_SRC contrib/Sparskit/*.cpp contrib/Sparskit/*.f contrib/Sparskit/*.F) set_source_files_properties(${SPARSKIT_SRC} COMPILE_FLAGS "-DHAVE_ILU_FLOAT") endif(ENABLE_SPARSKIT AND NOT HAVE_PETSC) if(ENABLE_ZITSOL AND HAVE_PETSC) if(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/contrib/ZITSOL_1/getdp.c) add_subdirectory(contrib/ZITSOL_1) set_config_option(HAVE_ZITSOL "Zitsol") endif(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/contrib/ZITSOL_1/getdp.c) endif(ENABLE_ZITSOL AND HAVE_PETSC) if(ENABLE_ARPACK) if(HAVE_LAPACK OR HAVE_PETSC) if(NOT ARPACK_LIB) message(STATUS "System ARPACK not found: using contrib/ARPACK instead") add_subdirectory(contrib/Arpack) set_config_option(HAVE_ARPACK "Arpack") endif(NOT ARPACK_LIB) endif(HAVE_LAPACK OR HAVE_PETSC) endif(ENABLE_ARPACK) if(CMAKE_Fortran_COMPILER_ID MATCHES "GNU") if(CMAKE_Fortran_COMPILER MATCHES "gfortran") list(APPEND LAPACK_LIBRARIES gfortran) elseif(CMAKE_Fortran_COMPILER MATCHES "f95") list(APPEND LAPACK_LIBRARIES gfortran) elseif(CMAKE_Fortran_COMPILER MATCHES "g77") list(APPEND LAPACK_LIBRARIES g2c) endif(CMAKE_Fortran_COMPILER MATCHES "gfortran") endif(CMAKE_Fortran_COMPILER_ID MATCHES "GNU") else(ENABLE_FORTRAN) set_config_option(HAVE_NO_FORTRAN "NoFortran") endif(ENABLE_FORTRAN) if(NOT HAVE_PETSC AND NOT HAVE_SPARSKIT) message(STATUS "Warning: building without PETSc and without Sparskit") endif(NOT HAVE_PETSC AND NOT HAVE_SPARSKIT) if(ENABLE_NX) if(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/contrib/NX/Unv_Format.cpp) message(STATUS "Note: Building non-free version of GetDP with code " "(C) 2012 Dr. Binde Ingenieure.") add_subdirectory(contrib/NX) set_config_option(HAVE_NX "NX") endif(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/contrib/NX/Unv_Format.cpp) endif(ENABLE_NX) if(ENABLE_GSL) find_library(GSL_LIB gsl PATH_SUFFIXES lib) find_library(GSLCBLAS_LIB gslcblas PATH_SUFFIXES lib) find_path(GSL_INC "gsl_min.h" PATH_SUFFIXES include gsl include/gsl) if(GSL_LIB AND GSLCBLAS_LIB AND GSL_INC) list(APPEND EXTERNAL_LIBRARIES ${GSL_LIB} ${GSLCBLAS_LIB}) list(APPEND EXTERNAL_INCLUDES ${GSL_INC}) set_config_option(HAVE_GSL "Gsl") endif(GSL_LIB AND GSLCBLAS_LIB AND GSL_INC) endif(ENABLE_GSL) if(ENABLE_NR AND NOT HAVE_GSL) if(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/contrib/NR/newt.cpp) message(STATUS "Note: Building non-free version of GetDP, with code " "(C) 1986-92 Numerical Recipes Software.") add_subdirectory(contrib/NR) set_config_option(HAVE_NR "NR") endif(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/contrib/NR/newt.cpp) endif(ENABLE_NR AND NOT HAVE_GSL) check_function_exists(vsnprintf HAVE_VSNPRINTF) if(NOT HAVE_VSNPRINTF) set_config_option(HAVE_NO_VSNPRINTF "NoVsnprintf") endif(NOT HAVE_VSNPRINTF) check_include_file(sys/socket.h HAVE_SYS_SOCKET_H) if(HAVE_SYS_SOCKET_H) set(CMAKE_EXTRA_INCLUDE_FILES sys/socket.h) endif(HAVE_SYS_SOCKET_H) check_type_size(socklen_t SOCKLEN_T_SIZE) set(CMAKE_EXTRA_INCLUDE_FILES) if(NOT SOCKLEN_T_SIZE) set_config_option(HAVE_NO_SOCKLEN_T "NoSocklenT") endif(NOT SOCKLEN_T_SIZE) check_include_file(stdint.h HAVE_STDINT_H) if(HAVE_STDINT_H) set(CMAKE_EXTRA_INCLUDE_FILES stdint.h) else(HAVE_STDINT_H) set_config_option(HAVE_NO_STDINT_H "NoStdintH") endif(HAVE_STDINT_H) check_type_size(intptr_t INTPTR_T_SIZE) set(CMAKE_EXTRA_INCLUDE_FILES) if(NOT INTPTR_T_SIZE) set_config_option(HAVE_NO_INTPTR_T "NoIntptrT") endif(NOT INTPTR_T_SIZE) if(MSVC) add_definitions(-D_USE_MATH_DEFINES -DNOMINMAX -D_CRT_SECURE_NO_DEPRECATE -D_SCL_SECURE_NO_DEPRECATE) endif(MSVC) if(WIN32 OR CYGWIN) list(APPEND EXTERNAL_LIBRARIES winmm wsock32 ws2_32 psapi) endif(WIN32 OR CYGWIN) # disable compile optimization on some known problematic files check_cxx_compiler_flag("-O0" NOOPT) if(NOOPT) file(GLOB_RECURSE NON_OPTIMIZED_SRC contrib/NR/*.cpp) set_source_files_properties(${NON_OPTIMIZED_SRC} COMPILE_FLAGS "-O0") endif(NOOPT) # force full warnings to encourage everybody to write clean(er) code check_cxx_compiler_flag("-Wall" WALL) if(WALL) file(GLOB_RECURSE WALL_SRC Common/*.cpp Interface/*.cpp Legacy/*.cpp Main/*.cpp Numeric/*.cpp) set_source_files_properties(${WALL_SRC} COMPILE_FLAGS "-Wall") endif(WALL) # don't issue warnings for contributed libraries check_cxx_compiler_flag("-w" NOWARN) if(NOWARN) file(GLOB_RECURSE NOWARN_SRC contrib/*.cpp contrib/*.c contrib/*.f) set_source_files_properties(${NOWARN_SRC} PROPERTIES COMPILE_FLAGS "-w") endif(NOWARN) list(SORT CONFIG_OPTIONS) set(GETDP_CONFIG_OPTIONS "") foreach(OPT ${CONFIG_OPTIONS}) set(GETDP_CONFIG_OPTIONS "${GETDP_CONFIG_OPTIONS} ${OPT}") endforeach(OPT) configure_file(${CMAKE_CURRENT_SOURCE_DIR}/Common/GetDPConfig.h.in ${CMAKE_CURRENT_BINARY_DIR}/Common/GetDPConfig.h) configure_file(${CMAKE_CURRENT_SOURCE_DIR}/Common/GetDPVersion.h.in ${CMAKE_CURRENT_BINARY_DIR}/Common/GetDPVersion.h) # process cmake environment variables so we can append them to the -I # include commands. This is not recommended (we should only use the # cache variables) but it is very convenient: otherwise we have to # remember providing the -D... options to cmake for each new build. set(ENV_CMAKE_PREFIX_PATH $ENV{CMAKE_PREFIX_PATH}) set(ENV_CMAKE_INCLUDE_PATH $ENV{CMAKE_INCLUDE_PATH}) if(UNIX) if(ENV_CMAKE_PREFIX_PATH) string(REPLACE ":" ";" ENV_CMAKE_PREFIX_PATH ${ENV_CMAKE_PREFIX_PATH}) endif(ENV_CMAKE_PREFIX_PATH) if(ENV_CMAKE_INCLUDE_PATH) string(REPLACE ":" ";" ENV_CMAKE_INCLUDE_PATH ${ENV_CMAKE_INCLUDE_PATH}) endif(ENV_CMAKE_INCLUDE_PATH) endif(UNIX) list(APPEND EXTERNAL_INCLUDES ${CMAKE_INCLUDE_PATH} ${ENV_CMAKE_INCLUDE_PATH}) list(APPEND EXTERNAL_INCLUDES ${CMAKE_PREFIX_PATH} ${ENV_CMAKE_PREFIX_PATH}) foreach(DIR ${CMAKE_PREFIX_PATH} ${ENV_CMAKE_PREFIX_PATH}) list(APPEND EXTERNAL_INCLUDES ${DIR}/include) endforeach(DIR) if(EXTERNAL_INCLUDES) list(REMOVE_DUPLICATES EXTERNAL_INCLUDES) endif(EXTERNAL_INCLUDES) set(LINK_LIBRARIES ${EXTERNAL_LIBRARIES} ${LAPACK_LIBRARIES}) # we could specify include dirs more selectively, but this is simpler include_directories(Common Interface Legacy Numeric ${EXTERNAL_INCLUDES} ${CMAKE_CURRENT_BINARY_DIR}/Common) # set this for external codes that might include this CMakeList file set(GETDP_EXTERNAL_INCLUDE_DIRS ${EXTERNAL_INCLUDES} CACHE STRING "External include directories" FORCE) set(GETDP_EXTERNAL_LIBRARIES ${EXTERNAL_LIBRARIES} CACHE STRING "External libraries" FORCE) # group sources for easier navigation in IDEs foreach(DIR ${GETDP_DIRS}) string(REGEX REPLACE "\\+" "\\\\+" DIR ${DIR}) source_group(${DIR} REGULAR_EXPRESSION ${DIR}/.*) endforeach(DIR) # static library target if(ENABLE_BUILD_LIB) add_library(lib STATIC ${GETDP_SRC}) set_target_properties(lib PROPERTIES OUTPUT_NAME GetDP) if(MSVC) set_target_properties(lib PROPERTIES DEBUG_POSTFIX d) if(ENABLE_MSVC_STATIC_RUNTIME) set_target_properties(lib PROPERTIES LINK_FLAGS_RELEASE "/nodefaultlib:LIBCMT") endif(ENABLE_MSVC_STATIC_RUNTIME) endif(MSVC) endif(ENABLE_BUILD_LIB) # shared library target if(ENABLE_BUILD_SHARED) add_library(shared SHARED ${GETDP_SRC}) set_target_properties(shared PROPERTIES OUTPUT_NAME GetDP) if(HAVE_LAPACK AND LAPACK_FLAGS) set_target_properties(shared PROPERTIES LINK_FLAGS ${LAPACK_FLAGS}) endif(HAVE_LAPACK AND LAPACK_FLAGS) if(MSVC AND ENABLE_MSVC_STATIC_RUNTIME) message(STATUS "Note: By enabling ENABLE_MSVC_STATIC_RUNTIME, shared library " "won't link. In MSVC change /MT to /MD in the shared project properties") endif(MSVC AND ENABLE_MSVC_STATIC_RUNTIME) target_link_libraries(shared ${LINK_LIBRARIES}) endif(ENABLE_BUILD_SHARED) if(ENABLE_BUILD_ANDROID) find_file(CMAKE_TOOLCHAIN_FILE "android.toolchain.cmake") if(NOT CMAKE_TOOLCHAIN_FILE) message(SEND_ERROR "Cannot compile Getdp for android without a toolchain.") endif(NOT CMAKE_TOOLCHAIN_FILE) set(CMAKE_BUILD_TYPE Release) set(LIBRARY_OUTPUT_PATH_ROOT ${CMAKE_CURRENT_BINARY_DIR}) set(LIBRARY_OUTPUT_PATH ${CMAKE_CURRENT_BINARY_DIR}/libs/) add_library(androidGetdp SHARED ${GETDP_SRC}) set_target_properties(androidGetdp PROPERTIES OUTPUT_NAME GetDP) target_link_libraries(androidGetdp ${LINK_LIBRARIES} ${LIBRARY_DEPS}) endif(ENABLE_BUILD_ANDROID) # static binary target add_executable(getdp Main/Main.cpp ${GETDP_SRC}) target_link_libraries(getdp ${LINK_LIBRARIES}) # force static linking of system libraries with cygwin/mingw if(WIN32 AND NOT MSVC OR CYGWIN) set_target_properties(getdp PROPERTIES LINK_FLAGS "-static") # remove stupid -Wl,-Bdynamic flags set(CMAKE_EXE_LINK_DYNAMIC_C_FLAGS) set(CMAKE_EXE_LINK_DYNAMIC_CXX_FLAGS) endif(WIN32 AND NOT MSVC OR CYGWIN) # dynamic binary target add_executable(getdp_dynamic EXCLUDE_FROM_ALL Main/Main.cpp) target_link_libraries(getdp_dynamic shared) # parser target find_program(BISON bison) find_program(FLEX flex) if(BISON AND FLEX) add_custom_target(parser COMMAND ${BISON} -p getdp_yy --output ProParser.tab.cpp -d ProParser.y COMMAND ${FLEX} -P getdp_yy -o ProParser.yy.cpp ProParser.l WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/Interface) endif(BISON AND FLEX) # miscellaneaous targets if(UNIX) # cannot use cmake's file search functions here (they would only # find files existing at configuration time) add_custom_target(purge COMMAND rm -f `find . -name *~ -o -name *~~` WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) add_custom_target(etags COMMAND etags `find . -name *.cpp -o -name *.h -o -name *.y` WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) endif(UNIX) set(WELCOME_FILE ${CMAKE_CURRENT_SOURCE_DIR}/doc/WELCOME.txt) set(LICENSE_FILE ${CMAKE_CURRENT_SOURCE_DIR}/doc/LICENSE.txt) set(CREDITS_FILE ${CMAKE_CURRENT_SOURCE_DIR}/doc/CREDITS.txt) file(GLOB DEMO_FILES ${CMAKE_CURRENT_SOURCE_DIR}/demos/*.pro ${CMAKE_CURRENT_SOURCE_DIR}/demos/*.geo ${CMAKE_CURRENT_SOURCE_DIR}/demos/*.msh) file(GLOB DEMO_FILES_TMP ${CMAKE_CURRENT_SOURCE_DIR}/demos/*.pre ${CMAKE_CURRENT_SOURCE_DIR}/demos/*.res ${CMAKE_CURRENT_SOURCE_DIR}/demos/*.txt ${CMAKE_CURRENT_SOURCE_DIR}/demos/*.pos ${CMAKE_CURRENT_SOURCE_DIR}/demos/*.par) set(TEX_DIR ${CMAKE_CURRENT_SOURCE_DIR}/doc/texinfo) file(GLOB TEX_SRC ${TEX_DIR}/*.texi) set(TEX_OBJ ${TEX_DIR}/getdp.aux ${TEX_DIR}/getdp.cp ${TEX_DIR}/getdp.cps ${TEX_DIR}/getdp.fn ${TEX_DIR}/getdp.html ${TEX_DIR}/getdp.info ${TEX_DIR}/getdp.ky ${TEX_DIR}/getdp.log ${TEX_DIR}/getdp.pdf ${TEX_DIR}/getdp.pg ${TEX_DIR}/getdp.toc ${TEX_DIR}/getdp.tp ${TEX_DIR}/getdp.tps ${TEX_DIR}/getdp.txt ${TEX_DIR}/getdp.vr ${TEX_DIR}/getdp.vrs) macro(unix2dos VARNAME) file(MAKE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/unix2dos) set(UNIX2DOS_FILES) foreach(FILE ${${VARNAME}}) file(READ ${FILE} F0) get_filename_component(N ${FILE} NAME) if(CYGWIN) string(REGEX REPLACE "\n" "\r\n" F1 "${F0}") file(WRITE ${CMAKE_CURRENT_BINARY_DIR}/unix2dos/${N} "${F1}") else(CYGWIN) # if not in cygwin, cmake adds '\r's automatically file(WRITE ${CMAKE_CURRENT_BINARY_DIR}/unix2dos/${N} "${F0}") endif(CYGWIN) list(APPEND UNIX2DOS_FILES ${CMAKE_CURRENT_BINARY_DIR}/unix2dos/${N}) endforeach(FILE) set(${VARNAME} ${UNIX2DOS_FILES}) endmacro(unix2dos) if(WIN32 OR CYGWIN) set(GETDP_BIN .) set(GETDP_LIB .) set(GETDP_DOC .) set(GETDP_MAN .) if(CYGWIN) unix2dos(GETDP_API) unix2dos(WELCOME_FILE) unix2dos(LICENSE_FILE) unix2dos(CREDITS_FILE) unix2dos(DEMO_FILES) endif(CYGWIN) else(WIN32 OR CYGWIN) set(GETDP_BIN bin) set(GETDP_LIB lib) set(GETDP_DOC share/doc/getdp) set(GETDP_MAN share/man/man1) endif(WIN32 OR CYGWIN) # mark targets as optional so we can install them separately if needed # (e.g. "make lib" or "make shared" followed by "make install/fast") install(TARGETS getdp DESTINATION ${GETDP_BIN} OPTIONAL) if(ENABLE_BUILD_LIB) install(TARGETS lib DESTINATION ${GMSH_LIB} OPTIONAL) endif(ENABLE_BUILD_LIB) if(ENABLE_BUILD_SHARED) install(TARGETS shared DESTINATION ${GMSH_LIB} OPTIONAL) endif(ENABLE_BUILD_SHARED) if(ENABLE_BUILD_LIB OR ENABLE_BUILD_SHARED) install(FILES ${GETDP_API} DESTINATION include/getdp) endif(ENABLE_BUILD_LIB OR ENABLE_BUILD_SHARED) install(FILES ${WELCOME_FILE} DESTINATION ${GETDP_DOC} RENAME README.txt) install(FILES ${LICENSE_FILE} DESTINATION ${GETDP_DOC}) install(FILES ${CREDITS_FILE} DESTINATION ${GETDP_DOC}) install(FILES ${DEMO_FILES} DESTINATION ${GETDP_DOC}/demos) if(UNIX AND NOT CYGWIN) install(FILES ${CMAKE_CURRENT_SOURCE_DIR}/doc/getdp.1 DESTINATION ${GETDP_MAN}) endif(UNIX AND NOT CYGWIN) add_custom_target(getHeaders COMMAND ${CMAKE_COMMAND} -E remove_directory Headers COMMAND ${CMAKE_COMMAND} -E make_directory Headers/getdp WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}) foreach(FILE ${GETDP_API}) add_custom_command(TARGET getHeaders POST_BUILD COMMAND ${CMAKE_COMMAND} -E copy ${FILE} ${CMAKE_CURRENT_BINARY_DIR}/Headers/getdp/ WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) endforeach(FILE) add_custom_target(clean_demos COMMAND ${CMAKE_COMMAND} -E remove ${DEMO_FILES_TMP}) find_program(MAKEINFO makeinfo) if(MAKEINFO) add_custom_command(OUTPUT ${TEX_DIR}/getdp.info DEPENDS ${TEX_SRC} COMMAND ${MAKEINFO} --split-size 1000000 ARGS ${TEX_DIR}/getdp.texi WORKING_DIRECTORY ${TEX_DIR}) add_custom_target(info DEPENDS ${TEX_DIR}/getdp.info) add_custom_command(OUTPUT ${TEX_DIR}/getdp.txt DEPENDS ${TEX_SRC} COMMAND ${MAKEINFO} --plaintext -o getdp.txt ARGS ${TEX_DIR}/getdp.texi WORKING_DIRECTORY ${TEX_DIR}) add_custom_target(txt DEPENDS ${TEX_DIR}/getdp.txt) add_custom_command(OUTPUT ${TEX_DIR}/getdp.html DEPENDS ${TEX_SRC} COMMAND ${MAKEINFO} --html --css-ref=http://geuz.org/geuz.css --no-split ARGS ${TEX_DIR}/getdp.texi WORKING_DIRECTORY ${TEX_DIR}) add_custom_target(html DEPENDS ${TEX_DIR}/getdp.html) install(FILES ${TEX_DIR}/getdp.html DESTINATION ${GETDP_DOC} OPTIONAL) endif(MAKEINFO) find_program(TEXI2PDF texi2pdf) if(TEXI2PDF) add_custom_command(OUTPUT ${TEX_DIR}/getdp.pdf DEPENDS ${TEX_SRC} COMMAND ${TEXI2PDF} ARGS ${TEX_DIR}/getdp.texi WORKING_DIRECTORY ${TEX_DIR}) add_custom_target(pdf DEPENDS ${TEX_DIR}/getdp.pdf) install(FILES ${TEX_DIR}/getdp.pdf DESTINATION ${GETDP_DOC} OPTIONAL) endif(TEXI2PDF) execute_process(COMMAND ${CMAKE_COMMAND} -E echo "${OPT_TEXI}" OUTPUT_FILE cmake_options.texi) if(MAKEINFO AND TEXI2PDF) add_custom_target(doc COMMAND ${CMAKE_COMMAND} -E tar zcf ${CMAKE_CURRENT_BINARY_DIR}/getdp-${GETDP_VERSION}-doc.tgz doc/CREDITS.txt doc/LICENSE.txt doc/VERSIONS.txt doc/getdp.1 doc/getdp.bib doc/texinfo/getdp.html doc/texinfo/getdp.info doc/texinfo/getdp.pdf doc/texinfo/getdp.txt COMMAND ${CMAKE_COMMAND} -E remove ${TEX_OBJ} DEPENDS ${TEX_DIR}/getdp.info ${TEX_DIR}/getdp.txt ${TEX_DIR}/getdp.html ${TEX_DIR}/getdp.pdf WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) endif(MAKEINFO AND TEXI2PDF) if(MAKEINFO OR TEXI2PDF) add_custom_target(clean_doc COMMAND ${CMAKE_COMMAND} -E remove ${TEX_OBJ}) endif(MAKEINFO OR TEXI2PDF) if(APPLE AND ENABLE_BUILD_LIB) file(READ ${CMAKE_CURRENT_SOURCE_DIR}/utils/misc/getdp_framework.plist F0) string(REPLACE GETDP_VERSION "${GETDP_VERSION}" F1 "${F0}") file(WRITE ${CMAKE_CURRENT_BINARY_DIR}/Info_framework.plist "${F1}") get_target_property(LIBNAME lib LOCATION) add_custom_target(framework DEPENDS lib COMMAND ${CMAKE_COMMAND} -E remove_directory GetDP.framework COMMAND ${CMAKE_COMMAND} -E make_directory GetDP.framework/Versions/A/Headers COMMAND ${CMAKE_COMMAND} -E make_directory GetDP.framework/Versions/A/Resources COMMAND ${CMAKE_COMMAND} -E copy ${LIBNAME} GetDP.framework/Versions/A/GetDP COMMAND ${CMAKE_COMMAND} -E copy Info_framework.plist GetDP.framework/Versions/A/Resources/Info.plist COMMAND ${CMAKE_COMMAND} -E create_symlink A GetDP.framework/Versions/Current COMMAND ${CMAKE_COMMAND} -E create_symlink Versions/Current/GetDP GetDP.framework/GetDP COMMAND ${CMAKE_COMMAND} -E create_symlink Versions/Current/Headers GetDP.framework/Headers COMMAND ${CMAKE_COMMAND} -E create_symlink Versions/Current/Resources GetDP.framework/Resources WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}) foreach(FILE ${GETDP_API}) add_custom_command(TARGET framework POST_BUILD COMMAND ${CMAKE_COMMAND} -E copy ${FILE} ${CMAKE_CURRENT_BINARY_DIR}/GetDP.framework/Versions/A/Headers/ WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) endforeach(FILE) endif(APPLE AND ENABLE_BUILD_LIB) set(CPACK_PACKAGE_VENDOR "Patrick Dular and Christophe Geuzaine") set(CPACK_PACKAGE_VERSION_MAJOR ${GETDP_MAJOR_VERSION}) set(CPACK_PACKAGE_VERSION_MINOR ${GETDP_MINOR_VERSION}) set(CPACK_PACKAGE_VERSION_PATCH ${GETDP_PATCH_VERSION}) set(CPACK_PACKAGE_DESCRIPTION_FILE ${WELCOME_FILE}) set(CPACK_PACKAGE_DESCRIPTION_SUMMARY "General Environment for the Treatment of Discrete Problems") set(CPACK_PACKAGE_FILE_NAME getdp-${GETDP_VERSION}-${GETDP_OS}) set(CPACK_PACKAGE_INSTALL_DIRECTORY "GetDP") set(CPACK_RESOURCE_FILE_LICENSE ${LICENSE_FILE}) set(CPACK_RESOURCE_FILE_README ${WELCOME_FILE}) set(CPACK_RESOURCE_FILE_WELCOME ${WELCOME_FILE}) set(CPACK_PACKAGE_EXECUTABLE "getdp;GetDP") set(CPACK_STRIP_FILES TRUE) set(CPACK_SOURCE_PACKAGE_FILE_NAME getdp-${GETDP_VERSION}-source) set(CPACK_SOURCE_GENERATOR TGZ) set(CPACK_SOURCE_IGNORE_FILES "${CMAKE_CURRENT_BINARY_DIR}" "/CVS/" "/.svn" "~$" "DS_Store$" "GetDPConfig.h$" "GetDPVersion.h$" "/benchmarks/" "/tmp/" "/bin/" "/lib/" "/nightly/" "GPATH" "GRTAGS" "GSYMS" "GTAGS" "/HTML/" "/contrib/NR/" "/contrib/NX/" "/contrib/ZITSOL_1/") if(UNIX) # make sure we remove previous installs before doing the next one # (on Mac for example "make package; make package_source" would lead # to huge file lists getting generated due to the 'Applications' # symlink in the bundle) set(CPACK_INSTALL_COMMANDS "rm -rf ${CMAKE_CURRENT_BINARY_DIR}/_CPack_Packages") endif(UNIX) if(WIN32 OR CYGWIN) set(CPACK_GENERATOR ZIP) else(WIN32 OR CYGWIN) set(CPACK_GENERATOR TGZ) endif(WIN32 OR CYGWIN) include(CPack) include(CTest) # we will need some common testing framwork to make actual tests file(GLOB_RECURSE TESTFILES demos/*.pro) foreach(TESTFILE ${TESTFILES}) add_test(${TESTFILE} getdp ${TESTFILE}) endforeach() message(STATUS "") message(STATUS "GetDP ${GETDP_VERSION} has been configured for ${GETDP_OS}:") message(STATUS "") message(STATUS " * Build options:" ${GETDP_CONFIG_OPTIONS}) message(STATUS " * Build type: " ${CMAKE_BUILD_TYPE}) message(STATUS " * C compiler: " ${CMAKE_C_COMPILER}) message(STATUS " * C++ compiler: " ${CMAKE_CXX_COMPILER}) message(STATUS " * Fortran compiler: " ${CMAKE_Fortran_COMPILER}) message(STATUS " * Install prefix: " ${CMAKE_INSTALL_PREFIX}) message(STATUS "") message(STATUS "Run 'ccmake ${CMAKE_CURRENT_SOURCE_DIR}' to fine-tune the configuration.") message(STATUS "") mark_as_advanced(GETDP_EXTRA_VERSION ARPACK_LIB GMSH_INC GMSH_LIB GSLCBLAS_LIB GSL_INC GSL_LIB PETSC_LIBS SLEPC_INC SLEPC_INC2 SLEPC_LIB BISON FLEX MAKEINFO TEXI2PDF GETDP_EXTERNAL_INCLUDE_DIRS GETDP_EXTERNAL_LIBRARIES) getdp-2.4.2-source/contrib/Sparskit/unary.f000644 001750 001750 00000323625 11266605601 022363 0ustar00geuzainegeuzaine000000 000000 c $Id: unary.f,v 1.1 2008-04-11 06:01:06 geuzaine Exp $ c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c UNARY SUBROUTINES MODULE c c----------------------------------------------------------------------c c contents: c c---------- c c submat : extracts a submatrix from a sparse matrix. c c filter : filters elements from a matrix according to their magnitude.c c filterm: same as above, but for the MSR format c c csort : sorts the elements in increasing order of columns c c clncsr : clean up the CSR format matrix, remove duplicate entry, etc c c transp : in-place transposition routine (see also csrcsc in formats) c c copmat : copy of a matrix into another matrix (both stored csr) c c msrcop : copies a matrix in MSR format into a matrix in MSR format c c getelm : returns a(i,j) for any (i,j) from a CSR-stored matrix. c c getdia : extracts a specified diagonal from a matrix. c c getl : extracts lower triangular part c c getu : extracts upper triangular part c c levels : gets the level scheduling structure for lower triangular c c matrices. c c amask : extracts C = A mask M c c rperm : permutes the rows of a matrix (B = P A) c c cperm : permutes the columns of a matrix (B = A Q) c c dperm : permutes both the rows and columns of a matrix (B = P A Q ) c c dperm1 : general extractiob routine (extracts arbitrary rows) c c dperm2 : general submatrix permutation/extraction routine c c dmperm : symmetric permutation of row and column (B=PAP') in MSR fmt c c dvperm : permutes a real vector (in-place) c c ivperm : permutes an integer vector (in-place) c c retmx : returns the max absolute value in each row of the matrix c c diapos : returns the positions of the diagonal elements in A. c c extbdg : extracts the main diagonal blocks of a matrix. c c getbwd : returns the bandwidth information on a matrix. c c blkfnd : finds the block-size of a matrix. c c blkchk : checks whether a given integer is the block size of A. c c infdia : obtains information on the diagonals of A. c c amubdg : gets number of nonzeros in each row of A*B (as well as NNZ) c c aplbdg : gets number of nonzeros in each row of A+B (as well as NNZ) c c rnrms : computes the norms of the rows of A c c cnrms : computes the norms of the columns of A c c roscal : scales the rows of a matrix by their norms. c c coscal : scales the columns of a matrix by their norms. c c addblk : Adds a matrix B into a block of A. c c get1up : Collects the first elements of each row of the upper c c triangular portion of the matrix. c c xtrows : extracts given rows from a matrix in CSR format. c c csrkvstr: Finds block row partitioning of matrix in CSR format c c csrkvstc: Finds block column partitioning of matrix in CSR format c c kvstmerge: Merges block partitionings, for conformal row/col pattern c c----------------------------------------------------------------------c subroutine submat (n,job,i1,i2,j1,j2,a,ja,ia,nr,nc,ao,jao,iao) integer n,job,i1,i2,j1,j2,nr,nc,ia(*),ja(*),jao(*),iao(*) real*8 a(*),ao(*) c----------------------------------------------------------------------- c extracts the submatrix A(i1:i2,j1:j2) and puts the result in c matrix ao,iao,jao c---- In place: ao,jao,iao may be the same as a,ja,ia. c-------------- c on input c--------- c n = row dimension of the matrix c i1,i2 = two integers with i2 .ge. i1 indicating the range of rows to be c extracted. c j1,j2 = two integers with j2 .ge. j1 indicating the range of columns c to be extracted. c * There is no checking whether the input values for i1, i2, j1, c j2 are between 1 and n. c a, c ja, c ia = matrix in compressed sparse row format. c c job = job indicator: if job .ne. 1 then the real values in a are NOT c extracted, only the column indices (i.e. data structure) are. c otherwise values as well as column indices are extracted... c c on output c-------------- c nr = number of rows of submatrix c nc = number of columns of submatrix c * if either of nr or nc is nonpositive the code will quit. c c ao, c jao,iao = extracted matrix in general sparse format with jao containing c the column indices,and iao being the pointer to the beginning c of the row,in arrays a,ja. c----------------------------------------------------------------------c c Y. Saad, Sep. 21 1989 c c----------------------------------------------------------------------c nr = i2-i1+1 nc = j2-j1+1 c if ( nr .le. 0 .or. nc .le. 0) return c klen = 0 c c simple procedure. proceeds row-wise... c do 100 i = 1,nr ii = i1+i-1 k1 = ia(ii) k2 = ia(ii+1)-1 iao(i) = klen+1 c----------------------------------------------------------------------- do 60 k=k1,k2 j = ja(k) if (j .ge. j1 .and. j .le. j2) then klen = klen+1 if (job .eq. 1) ao(klen) = a(k) jao(klen) = j - j1+1 endif 60 continue 100 continue iao(nr+1) = klen+1 return c------------end-of submat---------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine filter(n,job,drptol,a,ja,ia,b,jb,ib,len,ierr) real*8 a(*),b(*),drptol integer ja(*),jb(*),ia(*),ib(*),n,job,len,ierr c----------------------------------------------------------------------- c This module removes any elements whose absolute value c is small from an input matrix A and puts the resulting c matrix in B. The input parameter job selects a definition c of small. c----------------------------------------------------------------------- c on entry: c--------- c n = integer. row dimension of matrix c job = integer. used to determine strategy chosen by caller to c drop elements from matrix A. c job = 1 c Elements whose absolute value is less than the c drop tolerance are removed. c job = 2 c Elements whose absolute value is less than the c product of the drop tolerance and the Euclidean c norm of the row are removed. c job = 3 c Elements whose absolute value is less that the c product of the drop tolerance and the largest c element in the row are removed. c c drptol = real. drop tolerance used for dropping strategy. c a c ja c ia = input matrix in compressed sparse format c len = integer. the amount of space available in arrays b and jb. c c on return: c---------- c b c jb c ib = resulting matrix in compressed sparse format. c c ierr = integer. containing error message. c ierr .eq. 0 indicates normal return c ierr .gt. 0 indicates that there is'nt enough c space is a and ja to store the resulting matrix. c ierr then contains the row number where filter stopped. c note: c------ This module is in place. (b,jb,ib can ne the same as c a, ja, ia in which case the result will be overwritten). c----------------------------------------------------------------------c c contributed by David Day, Sep 19, 1989. c c----------------------------------------------------------------------c c local variables real*8 norm,loctol integer index,row,k,k1,k2 c index = 1 do 10 row= 1,n k1 = ia(row) k2 = ia(row+1) - 1 ib(row) = index goto (100,200,300) job 100 norm = 1.0d0 goto 400 200 norm = 0.0d0 do 22 k = k1,k2 norm = norm + a(k) * a(k) 22 continue norm = sqrt(norm) goto 400 300 norm = 0.0d0 do 23 k = k1,k2 if( abs(a(k)) .gt. norm) then norm = abs(a(k)) endif 23 continue 400 loctol = drptol * norm do 30 k = k1,k2 if( abs(a(k)) .gt. loctol)then if (index .gt. len) then ierr = row return endif b(index) = a(k) jb(index) = ja(k) index = index + 1 endif 30 continue 10 continue ib(n+1) = index return c--------------------end-of-filter ------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine filterm (n,job,drop,a,ja,b,jb,len,ierr) real*8 a(*),b(*),drop integer ja(*),jb(*),n,job,len,ierr c----------------------------------------------------------------------- c This subroutine removes any elements whose absolute value c is small from an input matrix A. Same as filter but c uses the MSR format. c----------------------------------------------------------------------- c on entry: c--------- c n = integer. row dimension of matrix c job = integer. used to determine strategy chosen by caller to c drop elements from matrix A. c job = 1 c Elements whose absolute value is less than the c drop tolerance are removed. c job = 2 c Elements whose absolute value is less than the c product of the drop tolerance and the Euclidean c norm of the row are removed. c job = 3 c Elements whose absolute value is less that the c product of the drop tolerance and the largest c element in the row are removed. c c drop = real. drop tolerance used for dropping strategy. c a c ja = input matrix in Modifief Sparse Row format c len = integer. the amount of space in arrays b and jb. c c on return: c---------- c c b, jb = resulting matrix in Modifief Sparse Row format c c ierr = integer. containing error message. c ierr .eq. 0 indicates normal return c ierr .gt. 0 indicates that there is'nt enough c space is a and ja to store the resulting matrix. c ierr then contains the row number where filter stopped. c note: c------ This module is in place. (b,jb can ne the same as c a, ja in which case the result will be overwritten). c----------------------------------------------------------------------c c contributed by David Day, Sep 19, 1989. c c----------------------------------------------------------------------c c local variables c real*8 norm,loctol integer index,row,k,k1,k2 c index = n+2 do 10 row= 1,n k1 = ja(row) k2 = ja(row+1) - 1 jb(row) = index goto (100,200,300) job 100 norm = 1.0d0 goto 400 200 norm = a(row)**2 do 22 k = k1,k2 norm = norm + a(k) * a(k) 22 continue norm = sqrt(norm) goto 400 300 norm = abs(a(row)) do 23 k = k1,k2 norm = max(abs(a(k)),norm) 23 continue 400 loctol = drop * norm do 30 k = k1,k2 if( abs(a(k)) .gt. loctol)then if (index .gt. len) then ierr = row return endif b(index) = a(k) jb(index) = ja(k) index = index + 1 endif 30 continue 10 continue jb(n+1) = index return c--------------------end-of-filterm------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine csort (n,a,ja,ia,iwork,values) logical values integer n, ja(*), ia(n+1), iwork(*) real*8 a(*) c----------------------------------------------------------------------- c This routine sorts the elements of a matrix (stored in Compressed c Sparse Row Format) in increasing order of their column indices within c each row. It uses a form of bucket sort with a cost of O(nnz) where c nnz = number of nonzero elements. c requires an integer work array of length 2*nnz. c----------------------------------------------------------------------- c on entry: c--------- c n = the row dimension of the matrix c a = the matrix A in compressed sparse row format. c ja = the array of column indices of the elements in array a. c ia = the array of pointers to the rows. c iwork = integer work array of length max ( n+1, 2*nnz ) c where nnz = 2* (ia(n+1)-ia(1)) ) . c values= logical indicating whether or not the real values a(*) must c also be permuted. if (.not. values) then the array a is not c touched by csort and can be a dummy array. c c on return: c---------- c the matrix stored in the structure a, ja, ia is permuted in such a c way that the column indices are in increasing order within each row. c iwork(1:nnz) contains the permutation used to rearrange the elements. c----------------------------------------------------------------------- c Y. Saad - Feb. 1, 1991. c----------------------------------------------------------------------- c local variables integer i, k, j, ifirst, nnz, next c c count the number of elements in each column c do 1 i=1,n+1 iwork(i) = 0 1 continue do 3 i=1, n do 2 k=ia(i), ia(i+1)-1 j = ja(k)+1 iwork(j) = iwork(j)+1 2 continue 3 continue c c compute pointers from lengths. c iwork(1) = 1 do 4 i=1,n iwork(i+1) = iwork(i) + iwork(i+1) 4 continue c c get the positions of the nonzero elements in order of columns. c ifirst = ia(1) nnz = ia(n+1)-ifirst do 5 i=1,n do 51 k=ia(i),ia(i+1)-1 j = ja(k) next = iwork(j) iwork(nnz+next) = k iwork(j) = next+1 51 continue 5 continue c c convert to coordinate format c do 6 i=1, n do 61 k=ia(i), ia(i+1)-1 iwork(k) = i 61 continue 6 continue c c loop to find permutation: for each element find the correct c position in (sorted) arrays a, ja. Record this in iwork. c do 7 k=1, nnz ko = iwork(nnz+k) irow = iwork(ko) next = ia(irow) c c the current element should go in next position in row. iwork c records this position. c iwork(ko) = next ia(irow) = next+1 7 continue c c perform an in-place permutation of the arrays. c call ivperm (nnz, ja(ifirst), iwork) if (values) call dvperm (nnz, a(ifirst), iwork) c c reshift the pointers of the original matrix back. c do 8 i=n,1,-1 ia(i+1) = ia(i) 8 continue ia(1) = ifirst c return c---------------end-of-csort-------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine clncsr(job,value2,nrow,a,ja,ia,indu,iwk) c .. Scalar Arguments .. integer job, nrow, value2 c .. c .. Array Arguments .. integer ia(nrow+1),indu(nrow),iwk(nrow+1),ja(*) real*8 a(*) c .. c c This routine performs two tasks to clean up a CSR matrix c -- remove duplicate/zero entries, c -- perform a partial ordering, new order lower triangular part, c main diagonal, upper triangular part. c c On entry: c c job = options c 0 -- nothing is done c 1 -- eliminate duplicate entries, zero entries. c 2 -- eliminate duplicate entries and perform partial ordering. c 3 -- eliminate duplicate entries, sort the entries in the c increasing order of clumn indices. c c value2 -- 0 the matrix is pattern only (a is not touched) c 1 matrix has values too. c nrow -- row dimension of the matrix c a,ja,ia -- input matrix in CSR format c c On return: c a,ja,ia -- cleaned matrix c indu -- pointers to the beginning of the upper triangular c portion if job > 1 c c Work space: c iwk -- integer work space of size nrow+1 c c .. Local Scalars .. integer i,j,k,ko,ipos,kfirst,klast real*8 tmp c .. c if (job.le.0) return c c .. eliminate duplicate entries -- c array INDU is used as marker for existing indices, it is also the c location of the entry. c IWK is used to stored the old IA array. c matrix is copied to squeeze out the space taken by the duplicated c entries. c do 90 i = 1, nrow indu(i) = 0 iwk(i) = ia(i) 90 continue iwk(nrow+1) = ia(nrow+1) k = 1 do 120 i = 1, nrow ia(i) = k ipos = iwk(i) klast = iwk(i+1) 100 if (ipos.lt.klast) then j = ja(ipos) if (indu(j).eq.0) then c .. new entry .. if (value2.ne.0) then if (a(ipos) .ne. 0.0D0) then indu(j) = k ja(k) = ja(ipos) a(k) = a(ipos) k = k + 1 endif else indu(j) = k ja(k) = ja(ipos) k = k + 1 endif else if (value2.ne.0) then c .. duplicate entry .. a(indu(j)) = a(indu(j)) + a(ipos) endif ipos = ipos + 1 go to 100 endif c .. remove marks before working on the next row .. do 110 ipos = ia(i), k - 1 indu(ja(ipos)) = 0 110 continue 120 continue ia(nrow+1) = k if (job.le.1) return c c .. partial ordering .. c split the matrix into strict upper/lower triangular c parts, INDU points to the the beginning of the upper part. c do 140 i = 1, nrow klast = ia(i+1) - 1 kfirst = ia(i) 130 if (klast.gt.kfirst) then if (ja(klast).lt.i .and. ja(kfirst).ge.i) then c .. swap klast with kfirst .. j = ja(klast) ja(klast) = ja(kfirst) ja(kfirst) = j if (value2.ne.0) then tmp = a(klast) a(klast) = a(kfirst) a(kfirst) = tmp endif endif if (ja(klast).ge.i) & klast = klast - 1 if (ja(kfirst).lt.i) & kfirst = kfirst + 1 go to 130 endif c if (ja(klast).lt.i) then indu(i) = klast + 1 else indu(i) = klast endif 140 continue if (job.le.2) return c c .. order the entries according to column indices c burble-sort is used c do 190 i = 1, nrow do 160 ipos = ia(i), indu(i)-1 do 150 j = indu(i)-1, ipos+1, -1 k = j - 1 if (ja(k).gt.ja(j)) then ko = ja(k) ja(k) = ja(j) ja(j) = ko if (value2.ne.0) then tmp = a(k) a(k) = a(j) a(j) = tmp endif endif 150 continue 160 continue do 180 ipos = indu(i), ia(i+1)-1 do 170 j = ia(i+1)-1, ipos+1, -1 k = j - 1 if (ja(k).gt.ja(j)) then ko = ja(k) ja(k) = ja(j) ja(j) = ko if (value2.ne.0) then tmp = a(k) a(k) = a(j) a(j) = tmp endif endif 170 continue 180 continue 190 continue return c---- end of clncsr ---------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine copmat (nrow,a,ja,ia,ao,jao,iao,ipos,job) real*8 a(*),ao(*) integer nrow, ia(*),ja(*),jao(*),iao(*), ipos, job c---------------------------------------------------------------------- c copies the matrix a, ja, ia, into the matrix ao, jao, iao. c---------------------------------------------------------------------- c on entry: c--------- c nrow = row dimension of the matrix c a, c ja, c ia = input matrix in compressed sparse row format. c ipos = integer. indicates the position in the array ao, jao c where the first element should be copied. Thus c iao(1) = ipos on return. c job = job indicator. if (job .ne. 1) the values are not copies c (i.e., pattern only is copied in the form of arrays ja, ia). c c on return: c---------- c ao, c jao, c iao = output matrix containing the same data as a, ja, ia. c----------------------------------------------------------------------- c Y. Saad, March 1990. c----------------------------------------------------------------------- c local variables integer kst, i, k c kst = ipos -ia(1) do 100 i = 1, nrow+1 iao(i) = ia(i) + kst 100 continue c do 200 k=ia(1), ia(nrow+1)-1 jao(kst+k)= ja(k) 200 continue c if (job .ne. 1) return do 201 k=ia(1), ia(nrow+1)-1 ao(kst+k) = a(k) 201 continue c return c--------end-of-copmat ------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine msrcop (nrow,a,ja,ao,jao,job) real*8 a(*),ao(*) integer nrow, ja(*),jao(*), job c---------------------------------------------------------------------- c copies the MSR matrix a, ja, into the MSR matrix ao, jao c---------------------------------------------------------------------- c on entry: c--------- c nrow = row dimension of the matrix c a,ja = input matrix in Modified compressed sparse row format. c job = job indicator. Values are not copied if job .ne. 1 c c on return: c---------- c ao, jao = output matrix containing the same data as a, ja. c----------------------------------------------------------------------- c Y. Saad, c----------------------------------------------------------------------- c local variables integer i, k c do 100 i = 1, nrow+1 jao(i) = ja(i) 100 continue c do 200 k=ja(1), ja(nrow+1)-1 jao(k)= ja(k) 200 continue c if (job .ne. 1) return do 201 k=ja(1), ja(nrow+1)-1 ao(k) = a(k) 201 continue do 202 k=1,nrow ao(k) = a(k) 202 continue c return c--------end-of-msrcop ------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- double precision function getelm (i,j,a,ja,ia,iadd,sorted) c----------------------------------------------------------------------- c purpose: c -------- c this function returns the element a(i,j) of a matrix a, c for any pair (i,j). the matrix is assumed to be stored c in compressed sparse row (csr) format. getelm performs a c binary search in the case where it is known that the elements c are sorted so that the column indices are in increasing order. c also returns (in iadd) the address of the element a(i,j) in c arrays a and ja when the search is successsful (zero if not). c----- c first contributed by noel nachtigal (mit). c recoded jan. 20, 1991, by y. saad [in particular c added handling of the non-sorted case + the iadd output] c----------------------------------------------------------------------- c parameters: c ----------- c on entry: c---------- c i = the row index of the element sought (input). c j = the column index of the element sought (input). c a = the matrix a in compressed sparse row format (input). c ja = the array of column indices (input). c ia = the array of pointers to the rows' data (input). c sorted = logical indicating whether the matrix is knonw to c have its column indices sorted in increasing order c (sorted=.true.) or not (sorted=.false.). c (input). c on return: c----------- c getelm = value of a(i,j). c iadd = address of element a(i,j) in arrays a, ja if found, c zero if not found. (output) c c note: the inputs i and j are not checked for validity. c----------------------------------------------------------------------- c noel m. nachtigal october 28, 1990 -- youcef saad jan 20, 1991. c----------------------------------------------------------------------- integer i, ia(*), iadd, j, ja(*) double precision a(*) logical sorted c c local variables. c integer ibeg, iend, imid, k c c initialization c iadd = 0 getelm = 0.0 ibeg = ia(i) iend = ia(i+1)-1 c c case where matrix is not necessarily sorted c if (.not. sorted) then c c scan the row - exit as soon as a(i,j) is found c do 5 k=ibeg, iend if (ja(k) .eq. j) then iadd = k goto 20 endif 5 continue c c end unsorted case. begin sorted case c else c c begin binary search. compute the middle index. c 10 imid = ( ibeg + iend ) / 2 c c test if found c if (ja(imid).eq.j) then iadd = imid goto 20 endif if (ibeg .ge. iend) goto 20 c c else update the interval bounds. c if (ja(imid).gt.j) then iend = imid -1 else ibeg = imid +1 endif goto 10 c c end both cases c endif c 20 if (iadd .ne. 0) getelm = a(iadd) c return c--------end-of-getelm-------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine getdia (nrow,ncol,job,a,ja,ia,len,diag,idiag,ioff) real*8 diag(*),a(*) integer nrow, ncol, job, len, ioff, ia(*), ja(*), idiag(*) c----------------------------------------------------------------------- c this subroutine extracts a given diagonal from a matrix stored in csr c format. the output matrix may be transformed with the diagonal removed c from it if desired (as indicated by job.) c----------------------------------------------------------------------- c our definition of a diagonal of matrix is a vector of length nrow c (always) which contains the elements in rows 1 to nrow of c the matrix that are contained in the diagonal offset by ioff c with respect to the main diagonal. if the diagonal element c falls outside the matrix then it is defined as a zero entry. c thus the proper definition of diag(*) with offset ioff is c c diag(i) = a(i,ioff+i) i=1,2,...,nrow c with elements falling outside the matrix being defined as zero. c c----------------------------------------------------------------------- c c on entry: c---------- c c nrow = integer. the row dimension of the matrix a. c ncol = integer. the column dimension of the matrix a. c job = integer. job indicator. if job = 0 then c the matrix a, ja, ia, is not altered on return. c if job.ne.0 then getdia will remove the entries c collected in diag from the original matrix. c this is done in place. c c a,ja, c ia = matrix stored in compressed sparse row a,ja,ia,format c ioff = integer,containing the offset of the wanted diagonal c the diagonal extracted is the one corresponding to the c entries a(i,j) with j-i = ioff. c thus ioff = 0 means the main diagonal c c on return: c----------- c len = number of nonzero elements found in diag. c (len .le. min(nrow,ncol-ioff)-max(1,1-ioff) + 1 ) c c diag = real*8 array of length nrow containing the wanted diagonal. c diag contains the diagonal (a(i,j),j-i = ioff ) as defined c above. c c idiag = integer array of length len, containing the poisitions c in the original arrays a and ja of the diagonal elements c collected in diag. a zero entry in idiag(i) means that c there was no entry found in row i belonging to the diagonal. c c a, ja, c ia = if job .ne. 0 the matrix is unchanged. otherwise the nonzero c diagonal entries collected in diag are removed from the c matrix and therefore the arrays a, ja, ia will change. c (the matrix a, ja, ia will contain len fewer elements) c c----------------------------------------------------------------------c c Y. Saad, sep. 21 1989 - modified and retested Feb 17, 1996. c c----------------------------------------------------------------------c c local variables integer istart, max, iend, i, kold, k, kdiag, ko c istart = max(0,-ioff) iend = min(nrow,ncol-ioff) len = 0 do 1 i=1,nrow idiag(i) = 0 diag(i) = 0.0d0 1 continue c c extract diagonal elements c do 6 i=istart+1, iend do 51 k= ia(i),ia(i+1) -1 if (ja(k)-i .eq. ioff) then diag(i)= a(k) idiag(i) = k len = len+1 goto 6 endif 51 continue 6 continue if (job .eq. 0 .or. len .eq.0) return c c remove diagonal elements and rewind structure c ko = 0 do 7 i=1, nrow kold = ko kdiag = idiag(i) do 71 k= ia(i), ia(i+1)-1 if (k .ne. kdiag) then ko = ko+1 a(ko) = a(k) ja(ko) = ja(k) endif 71 continue ia(i) = kold+1 7 continue c c redefine ia(nrow+1) c ia(nrow+1) = ko+1 return c------------end-of-getdia---------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine transp (nrow,ncol,a,ja,ia,iwk,ierr) integer nrow, ncol, ia(*), ja(*), iwk(*), ierr real*8 a(*) c------------------------------------------------------------------------ c In-place transposition routine. c------------------------------------------------------------------------ c this subroutine transposes a matrix stored in compressed sparse row c format. the transposition is done in place in that the arrays a,ja,ia c of the transpose are overwritten onto the original arrays. c------------------------------------------------------------------------ c on entry: c--------- c nrow = integer. The row dimension of A. c ncol = integer. The column dimension of A. c a = real array of size nnz (number of nonzero elements in A). c containing the nonzero elements c ja = integer array of length nnz containing the column positions c of the corresponding elements in a. c ia = integer of size n+1, where n = max(nrow,ncol). On entry c ia(k) contains the position in a,ja of the beginning of c the k-th row. c c iwk = integer work array of same length as ja. c c on return: c---------- c c ncol = actual row dimension of the transpose of the input matrix. c Note that this may be .le. the input value for ncol, in c case some of the last columns of the input matrix are zero c columns. In the case where the actual number of rows found c in transp(A) exceeds the input value of ncol, transp will c return without completing the transposition. see ierr. c a, c ja, c ia = contains the transposed matrix in compressed sparse c row format. The row dimension of a, ja, ia is now ncol. c c ierr = integer. error message. If the number of rows for the c transposed matrix exceeds the input value of ncol, c then ierr is set to that number and transp quits. c Otherwise ierr is set to 0 (normal return). c c Note: c----- 1) If you do not need the transposition to be done in place c it is preferrable to use the conversion routine csrcsc c (see conversion routines in formats). c 2) the entries of the output matrix are not sorted (the column c indices in each are not in increasing order) use csrcsc c if you want them sorted. c----------------------------------------------------------------------c c Y. Saad, Sep. 21 1989 c c modified Oct. 11, 1989. c c----------------------------------------------------------------------c c local variables real*8 t, t1 ierr = 0 nnz = ia(nrow+1)-1 c c determine column dimension c jcol = 0 do 1 k=1, nnz jcol = max(jcol,ja(k)) 1 continue if (jcol .gt. ncol) then ierr = jcol return endif c c convert to coordinate format. use iwk for row indices. c ncol = jcol c do 3 i=1,nrow do 2 k=ia(i),ia(i+1)-1 iwk(k) = i 2 continue 3 continue c find pointer array for transpose. do 35 i=1,ncol+1 ia(i) = 0 35 continue do 4 k=1,nnz i = ja(k) ia(i+1) = ia(i+1)+1 4 continue ia(1) = 1 c------------------------------------------------------------------------ do 44 i=1,ncol ia(i+1) = ia(i) + ia(i+1) 44 continue c c loop for a cycle in chasing process. c init = 1 k = 0 5 t = a(init) i = ja(init) j = iwk(init) iwk(init) = -1 c------------------------------------------------------------------------ 6 k = k+1 c current row number is i. determine where to go. l = ia(i) c save the chased element. t1 = a(l) inext = ja(l) c then occupy its location. a(l) = t ja(l) = j c update pointer information for next element to be put in row i. ia(i) = l+1 c determine next element to be chased if (iwk(l) .lt. 0) goto 65 t = t1 i = inext j = iwk(l) iwk(l) = -1 if (k .lt. nnz) goto 6 goto 70 65 init = init+1 if (init .gt. nnz) goto 70 if (iwk(init) .lt. 0) goto 65 c restart chasing -- goto 5 70 continue do 80 i=ncol,1,-1 ia(i+1) = ia(i) 80 continue ia(1) = 1 c return c------------------end-of-transp ---------------------------------------- c------------------------------------------------------------------------ end c------------------------------------------------------------------------ subroutine getl (n,a,ja,ia,ao,jao,iao) integer n, ia(*), ja(*), iao(*), jao(*) real*8 a(*), ao(*) c------------------------------------------------------------------------ c this subroutine extracts the lower triangular part of a matrix c and writes the result ao, jao, iao. The routine is in place in c that ao, jao, iao can be the same as a, ja, ia if desired. c----------- c on input: c c n = dimension of the matrix a. c a, ja, c ia = matrix stored in compressed sparse row format. c On return: c ao, jao, c iao = lower triangular matrix (lower part of a) c stored in a, ja, ia, format c note: the diagonal element is the last element in each row. c i.e. in a(ia(i+1)-1 ) c ao, jao, iao may be the same as a, ja, ia on entry -- in which case c getl will overwrite the result on a, ja, ia. c c------------------------------------------------------------------------ c local variables real*8 t integer ko, kold, kdiag, k, i c c inititialize ko (pointer for output matrix) c ko = 0 do 7 i=1, n kold = ko kdiag = 0 do 71 k = ia(i), ia(i+1) -1 if (ja(k) .gt. i) goto 71 ko = ko+1 ao(ko) = a(k) jao(ko) = ja(k) if (ja(k) .eq. i) kdiag = ko 71 continue if (kdiag .eq. 0 .or. kdiag .eq. ko) goto 72 c c exchange c t = ao(kdiag) ao(kdiag) = ao(ko) ao(ko) = t c k = jao(kdiag) jao(kdiag) = jao(ko) jao(ko) = k 72 iao(i) = kold+1 7 continue c redefine iao(n+1) iao(n+1) = ko+1 return c----------end-of-getl ------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine getu (n,a,ja,ia,ao,jao,iao) integer n, ia(*), ja(*), iao(*), jao(*) real*8 a(*), ao(*) c------------------------------------------------------------------------ c this subroutine extracts the upper triangular part of a matrix c and writes the result ao, jao, iao. The routine is in place in c that ao, jao, iao can be the same as a, ja, ia if desired. c----------- c on input: c c n = dimension of the matrix a. c a, ja, c ia = matrix stored in a, ja, ia, format c On return: c ao, jao, c iao = upper triangular matrix (upper part of a) c stored in compressed sparse row format c note: the diagonal element is the last element in each row. c i.e. in a(ia(i+1)-1 ) c ao, jao, iao may be the same as a, ja, ia on entry -- in which case c getu will overwrite the result on a, ja, ia. c c------------------------------------------------------------------------ c local variables real*8 t integer ko, k, i, kdiag, kfirst ko = 0 do 7 i=1, n kfirst = ko+1 kdiag = 0 do 71 k = ia(i), ia(i+1) -1 if (ja(k) .lt. i) goto 71 ko = ko+1 ao(ko) = a(k) jao(ko) = ja(k) if (ja(k) .eq. i) kdiag = ko 71 continue if (kdiag .eq. 0 .or. kdiag .eq. kfirst) goto 72 c exchange t = ao(kdiag) ao(kdiag) = ao(kfirst) ao(kfirst) = t c k = jao(kdiag) jao(kdiag) = jao(kfirst) jao(kfirst) = k 72 iao(i) = kfirst 7 continue c redefine iao(n+1) iao(n+1) = ko+1 return c----------end-of-getu ------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine levels (n, jal, ial, nlev, lev, ilev, levnum) integer jal(*),ial(*), levnum(*), ilev(*), lev(*) c----------------------------------------------------------------------- c levels gets the level structure of a lower triangular matrix c for level scheduling in the parallel solution of triangular systems c strict lower matrices (e.g. unit) as well matrices with their main c diagonal are accepted. c----------------------------------------------------------------------- c on entry: c---------- c n = integer. The row dimension of the matrix c jal, ial = c c on return: c----------- c nlev = integer. number of levels found c lev = integer array of length n containing the level c scheduling permutation. c ilev = integer array. pointer to beginning of levels in lev. c the numbers lev(i) to lev(i+1)-1 contain the row numbers c that belong to level number i, in the level scheduling c ordering. The equations of the same level can be solved c in parallel, once those of all the previous levels have c been solved. c work arrays: c------------- c levnum = integer array of length n (containing the level numbers c of each unknown on return) c----------------------------------------------------------------------- do 10 i = 1, n levnum(i) = 0 10 continue c c compute level of each node -- c nlev = 0 do 20 i = 1, n levi = 0 do 15 j = ial(i), ial(i+1) - 1 levi = max (levi, levnum(jal(j))) 15 continue levi = levi+1 levnum(i) = levi nlev = max(nlev,levi) 20 continue c-------------set data structure -------------------------------------- do 21 j=1, nlev+1 ilev(j) = 0 21 continue c------count number of elements in each level ----------------------- do 22 j=1, n i = levnum(j)+1 ilev(i) = ilev(i)+1 22 continue c---- set up pointer for each level ---------------------------------- ilev(1) = 1 do 23 j=1, nlev ilev(j+1) = ilev(j)+ilev(j+1) 23 continue c-----determine elements of each level -------------------------------- do 30 j=1,n i = levnum(j) lev(ilev(i)) = j ilev(i) = ilev(i)+1 30 continue c reset pointers backwards do 35 j=nlev, 1, -1 ilev(j+1) = ilev(j) 35 continue ilev(1) = 1 return c----------end-of-levels------------------------------------------------ C----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine amask (nrow,ncol,a,ja,ia,jmask,imask, * c,jc,ic,iw,nzmax,ierr) c--------------------------------------------------------------------- real*8 a(*),c(*) integer ia(nrow+1),ja(*),jc(*),ic(nrow+1),jmask(*),imask(nrow+1) logical iw(ncol) c----------------------------------------------------------------------- c This subroutine builds a sparse matrix from an input matrix by c extracting only elements in positions defined by the mask jmask, imask c----------------------------------------------------------------------- c On entry: c--------- c nrow = integer. row dimension of input matrix c ncol = integer. Column dimension of input matrix. c c a, c ja, c ia = matrix in Compressed Sparse Row format c c jmask, c imask = matrix defining mask (pattern only) stored in compressed c sparse row format. c c nzmax = length of arrays c and jc. see ierr. c c On return: c----------- c c a, ja, ia and jmask, imask are unchanged. c c c c jc, c ic = the output matrix in Compressed Sparse Row format. c c ierr = integer. serving as error message.c c ierr = 1 means normal return c ierr .gt. 1 means that amask stopped when processing c row number ierr, because there was not enough space in c c, jc according to the value of nzmax. c c work arrays: c------------- c iw = logical work array of length ncol. c c note: c------ the algorithm is in place: c, jc, ic can be the same as c a, ja, ia in which cas the code will overwrite the matrix c c on a, ja, ia c c----------------------------------------------------------------------- ierr = 0 len = 0 do 1 j=1, ncol iw(j) = .false. 1 continue c unpack the mask for row ii in iw do 100 ii=1, nrow c save pointer in order to be able to do things in place do 2 k=imask(ii), imask(ii+1)-1 iw(jmask(k)) = .true. 2 continue c add umasked elemnts of row ii k1 = ia(ii) k2 = ia(ii+1)-1 ic(ii) = len+1 do 200 k=k1,k2 j = ja(k) if (iw(j)) then len = len+1 if (len .gt. nzmax) then ierr = ii return endif jc(len) = j c(len) = a(k) endif 200 continue c do 3 k=imask(ii), imask(ii+1)-1 iw(jmask(k)) = .false. 3 continue 100 continue ic(nrow+1)=len+1 c return c-----end-of-amask ----------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine rperm (nrow,a,ja,ia,ao,jao,iao,perm,job) integer nrow,ja(*),ia(nrow+1),jao(*),iao(nrow+1),perm(nrow),job real*8 a(*),ao(*) c----------------------------------------------------------------------- c this subroutine permutes the rows of a matrix in CSR format. c rperm computes B = P A where P is a permutation matrix. c the permutation P is defined through the array perm: for each j, c perm(j) represents the destination row number of row number j. c Youcef Saad -- recoded Jan 28, 1991. c----------------------------------------------------------------------- c on entry: c---------- c n = dimension of the matrix c a, ja, ia = input matrix in csr format c perm = integer array of length nrow containing the permutation arrays c for the rows: perm(i) is the destination of row i in the c permuted matrix. c ---> a(i,j) in the original matrix becomes a(perm(i),j) c in the output matrix. c c job = integer indicating the work to be done: c job = 1 permute a, ja, ia into ao, jao, iao c (including the copying of real values ao and c the array iao). c job .ne. 1 : ignore real values. c (in which case arrays a and ao are not needed nor c used). c c------------ c on return: c------------ c ao, jao, iao = input matrix in a, ja, ia format c note : c if (job.ne.1) then the arrays a and ao are not used. c----------------------------------------------------------------------c c Y. Saad, May 2, 1990 c c----------------------------------------------------------------------c logical values values = (job .eq. 1) c c determine pointers for output matix. c do 50 j=1,nrow i = perm(j) iao(i+1) = ia(j+1) - ia(j) 50 continue c c get pointers from lengths c iao(1) = 1 do 51 j=1,nrow iao(j+1)=iao(j+1)+iao(j) 51 continue c c copying c do 100 ii=1,nrow c c old row = ii -- new row = iperm(ii) -- ko = new pointer c ko = iao(perm(ii)) do 60 k=ia(ii), ia(ii+1)-1 jao(ko) = ja(k) if (values) ao(ko) = a(k) ko = ko+1 60 continue 100 continue c return c---------end-of-rperm ------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine cperm (nrow,a,ja,ia,ao,jao,iao,perm,job) integer nrow,ja(*),ia(nrow+1),jao(*),iao(nrow+1),perm(*), job real*8 a(*), ao(*) c----------------------------------------------------------------------- c this subroutine permutes the columns of a matrix a, ja, ia. c the result is written in the output matrix ao, jao, iao. c cperm computes B = A P, where P is a permutation matrix c that maps column j into column perm(j), i.e., on return c a(i,j) becomes a(i,perm(j)) in new matrix c Y. Saad, May 2, 1990 / modified Jan. 28, 1991. c----------------------------------------------------------------------- c on entry: c---------- c nrow = row dimension of the matrix c c a, ja, ia = input matrix in csr format. c c perm = integer array of length ncol (number of columns of A c containing the permutation array the columns: c a(i,j) in the original matrix becomes a(i,perm(j)) c in the output matrix. c c job = integer indicating the work to be done: c job = 1 permute a, ja, ia into ao, jao, iao c (including the copying of real values ao and c the array iao). c job .ne. 1 : ignore real values ao and ignore iao. c c------------ c on return: c------------ c ao, jao, iao = input matrix in a, ja, ia format (array ao not needed) c c Notes: c------- c 1. if job=1 then ao, iao are not used. c 2. This routine is in place: ja, jao can be the same. c 3. If the matrix is initially sorted (by increasing column number) c then ao,jao,iao may not be on return. c c----------------------------------------------------------------------c c local parameters: integer k, i, nnz c nnz = ia(nrow+1)-1 do 100 k=1,nnz jao(k) = perm(ja(k)) 100 continue c c done with ja array. return if no need to touch values. c if (job .ne. 1) return c c else get new pointers -- and copy values too. c do 1 i=1, nrow+1 iao(i) = ia(i) 1 continue c do 2 k=1, nnz ao(k) = a(k) 2 continue c return c---------end-of-cperm-------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine dperm (nrow,a,ja,ia,ao,jao,iao,perm,qperm,job) integer nrow,ja(*),ia(nrow+1),jao(*),iao(nrow+1),perm(nrow), + qperm(*),job real*8 a(*),ao(*) c----------------------------------------------------------------------- c This routine permutes the rows and columns of a matrix stored in CSR c format. i.e., it computes P A Q, where P, Q are permutation matrices. c P maps row i into row perm(i) and Q maps column j into column qperm(j): c a(i,j) becomes a(perm(i),qperm(j)) in new matrix c In the particular case where Q is the transpose of P (symmetric c permutation of A) then qperm is not needed. c note that qperm should be of length ncol (number of columns) but this c is not checked. c----------------------------------------------------------------------- c Y. Saad, Sep. 21 1989 / recoded Jan. 28 1991. c----------------------------------------------------------------------- c on entry: c---------- c n = dimension of the matrix c a, ja, c ia = input matrix in a, ja, ia format c perm = integer array of length n containing the permutation arrays c for the rows: perm(i) is the destination of row i in the c permuted matrix -- also the destination of column i in case c permutation is symmetric (job .le. 2) c c qperm = same thing for the columns. This should be provided only c if job=3 or job=4, i.e., only in the case of a nonsymmetric c permutation of rows and columns. Otherwise qperm is a dummy c c job = integer indicating the work to be done: c * job = 1,2 permutation is symmetric Ao :== P * A * transp(P) c job = 1 permute a, ja, ia into ao, jao, iao c job = 2 permute matrix ignoring real values. c * job = 3,4 permutation is non-symmetric Ao :== P * A * Q c job = 3 permute a, ja, ia into ao, jao, iao c job = 4 permute matrix ignoring real values. c c on return: c----------- c ao, jao, iao = input matrix in a, ja, ia format c c in case job .eq. 2 or job .eq. 4, a and ao are never referred to c and can be dummy arguments. c Notes: c------- c 1) algorithm is in place c 2) column indices may not be sorted on return even though they may be c on entry. c----------------------------------------------------------------------c c local variables integer locjob, mod c c locjob indicates whether or not real values must be copied. c locjob = mod(job,2) c c permute rows first c call rperm (nrow,a,ja,ia,ao,jao,iao,perm,locjob) c c then permute columns c locjob = 0 c if (job .le. 2) then call cperm (nrow,ao,jao,iao,ao,jao,iao,perm,locjob) else call cperm (nrow,ao,jao,iao,ao,jao,iao,qperm,locjob) endif c return c-------end-of-dperm---------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine dperm1 (i1,i2,a,ja,ia,b,jb,ib,perm,ipos,job) integer i1,i2,job,ja(*),ia(*),jb(*),ib(*),perm(*) real*8 a(*),b(*) c----------------------------------------------------------------------- c general submatrix extraction routine. c----------------------------------------------------------------------- c extracts rows perm(i1), perm(i1+1), ..., perm(i2) (in this order) c from a matrix (doing nothing in the column indices.) The resulting c submatrix is constructed in b, jb, ib. A pointer ipos to the c beginning of arrays b,jb,is also allowed (i.e., nonzero elements c are accumulated starting in position ipos of b, jb). c----------------------------------------------------------------------- c Y. Saad,Sep. 21 1989 / recoded Jan. 28 1991 / modified for PSPARSLIB c Sept. 1997.. c----------------------------------------------------------------------- c on entry: c---------- c n = dimension of the matrix c a,ja, c ia = input matrix in CSR format c perm = integer array of length n containing the indices of the rows c to be extracted. c c job = job indicator. if (job .ne.1) values are not copied (i.e., c only pattern is copied). c c on return: c----------- c b,ja, c ib = matrix in csr format. b(ipos:ipos+nnz-1),jb(ipos:ipos+nnz-1) c contain the value and column indices respectively of the nnz c nonzero elements of the permuted matrix. thus ib(1)=ipos. c c Notes: c------- c algorithm is NOT in place c----------------------------------------------------------------------- c local variables c integer ko,irow,k logical values c----------------------------------------------------------------------- values = (job .eq. 1) ko = ipos ib(1) = ko do 900 i=i1,i2 irow = perm(i) do 800 k=ia(irow),ia(irow+1)-1 if (values) b(ko) = a(k) jb(ko) = ja(k) ko=ko+1 800 continue ib(i-i1+2) = ko 900 continue return c--------end-of-dperm1-------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine dperm2 (i1,i2,a,ja,ia,b,jb,ib,cperm,rperm,istart, * ipos,job) integer i1,i2,job,istart,ja(*),ia(*),jb(*),ib(*),cperm(*),rperm(*) real*8 a(*),b(*) c----------------------------------------------------------------------- c general submatrix permutation/ extraction routine. c----------------------------------------------------------------------- c extracts rows rperm(i1), rperm(i1+1), ..., rperm(i2) and does an c associated column permutation (using array cperm). The resulting c submatrix is constructed in b, jb, ib. For added flexibility, the c extracted elements are put in sequence starting from row 'istart' c of B. In addition a pointer ipos to the beginning of arrays b,jb, c is also allowed (i.e., nonzero elements are accumulated starting in c position ipos of b, jb). In most applications istart and ipos are c equal to one. However, the generality adds substantial flexiblity. c EXPLE: (1) to permute msr to msr (excluding diagonals) c call dperm2 (1,n,a,ja,ja,b,jb,jb,rperm,rperm,1,n+2) c (2) To extract rows 1 to 10: define rperm and cperm to be c identity permutations (rperm(i)=i, i=1,n) and then c call dperm2 (1,10,a,ja,ia,b,jb,ib,rperm,rperm,1,1) c (3) to achieve a symmetric permutation as defined by perm: c call dperm2 (1,10,a,ja,ia,b,jb,ib,perm,perm,1,1) c (4) to get a symmetric permutation of A and append the c resulting data structure to A's data structure (useful!) c call dperm2 (1,10,a,ja,ia,a,ja,ia(n+1),perm,perm,1,ia(n+1)) c----------------------------------------------------------------------- c Y. Saad,Sep. 21 1989 / recoded Jan. 28 1991. c----------------------------------------------------------------------- c on entry: c---------- c n = dimension of the matrix c i1,i2 = extract rows rperm(i1) to rperm(i2) of A, with i1 0 : Row number i is a zero row. c Notes: c------- c 1) The column dimension of A is not needed. c 2) algorithm in place (B can take the place of A). c----------------------------------------------------------------- call rnrms (nrow,nrm,a,ja,ia,diag) ierr = 0 do 1 j=1, nrow if (diag(j) .eq. 0.0d0) then ierr = j return else diag(j) = 1.0d0/diag(j) endif 1 continue call diamua(nrow,job,a,ja,ia,diag,b,jb,ib) return c-------end-of-roscal--------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine coscal(nrow,job,nrm,a,ja,ia,diag,b,jb,ib,ierr) c----------------------------------------------------------------------- real*8 a(*),b(*),diag(nrow) integer nrow,job,ja(*),jb(*),ia(nrow+1),ib(nrow+1),ierr c----------------------------------------------------------------------- c scales the columns of A such that their norms are one on return c result matrix written on b, or overwritten on A. c 3 choices of norms: 1-norm, 2-norm, max-norm. in place. c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A c c job = integer. job indicator. Job=0 means get array b only c job = 1 means get b, and the integer arrays ib, jb. c c nrm = integer. norm indicator. nrm = 1, means 1-norm, nrm =2 c means the 2-nrm, nrm = 0 means max norm c c a, c ja, c ia = Matrix A in compressed sparse row format. c c on return: c---------- c c diag = diagonal matrix stored as a vector containing the matrix c by which the columns have been scaled, i.e., on return c we have B = A * Diag c c b, c jb, c ib = resulting matrix B in compressed sparse row sparse format. c c ierr = error message. ierr=0 : Normal return c ierr=i > 0 : Column number i is a zero row. c Notes: c------- c 1) The column dimension of A is not needed. c 2) algorithm in place (B can take the place of A). c----------------------------------------------------------------- call cnrms (nrow,nrm,a,ja,ia,diag) ierr = 0 do 1 j=1, nrow if (diag(j) .eq. 0.0) then ierr = j return else diag(j) = 1.0d0/diag(j) endif 1 continue call amudia (nrow,job,a,ja,ia,diag,b,jb,ib) return c--------end-of-coscal-------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine addblk(nrowa, ncola, a, ja, ia, ipos, jpos, job, & nrowb, ncolb, b, jb, ib, nrowc, ncolc, c, jc, ic, nzmx, ierr) c implicit none integer nrowa, nrowb, nrowc, ncola, ncolb, ncolc, ipos, jpos integer nzmx, ierr, job integer ja(1:*), ia(1:*), jb(1:*), ib(1:*), jc(1:*), ic(1:*) real*8 a(1:*), b(1:*), c(1:*) c----------------------------------------------------------------------- c This subroutine adds a matrix B into a submatrix of A whose c (1,1) element is located in the starting position (ipos, jpos). c The resulting matrix is allowed to be larger than A (and B), c and the resulting dimensions nrowc, ncolc will be redefined c accordingly upon return. c The input matrices are assumed to be sorted, i.e. in each row c the column indices appear in ascending order in the CSR format. c----------------------------------------------------------------------- c on entry: c --------- c nrowa = number of rows in A. c bcola = number of columns in A. c a,ja,ia = Matrix A in compressed sparse row format with entries sorted c nrowb = number of rows in B. c ncolb = number of columns in B. c b,jb,ib = Matrix B in compressed sparse row format with entries sorted c c nzmax = integer. The length of the arrays c and jc. addblk will c stop if the number of nonzero elements in the matrix C c exceeds nzmax. See ierr. c c on return: c---------- c nrowc = number of rows in C. c ncolc = number of columns in C. c c,jc,ic = resulting matrix C in compressed sparse row sparse format c with entries sorted ascendly in each row. c c ierr = integer. serving as error message. c ierr = 0 means normal return, c ierr .gt. 0 means that addblk stopped while computing the c i-th row of C with i=ierr, because the number c of elements in C exceeds nzmax. c c Notes: c------- c this will not work if any of the two input matrices is not sorted c----------------------------------------------------------------------- logical values integer i,j1,j2,ka,kb,kc,kamax,kbmax values = (job .ne. 0) ierr = 0 nrowc = max(nrowa, nrowb+ipos-1) ncolc = max(ncola, ncolb+jpos-1) kc = 1 kbmax = 0 ic(1) = kc c do 10 i=1, nrowc if (i.le.nrowa) then ka = ia(i) kamax = ia(i+1)-1 else ka = ia(nrowa+1) end if if ((i.ge.ipos).and.((i-ipos).le.nrowb)) then kb = ib(i-ipos+1) kbmax = ib(i-ipos+2)-1 else kb = ib(nrowb+1) end if c c a do-while type loop -- goes through all the elements in a row. c 20 continue if (ka .le. kamax) then j1 = ja(ka) else j1 = ncolc+1 endif if (kb .le. kbmax) then j2 = jb(kb) + jpos - 1 else j2 = ncolc+1 endif c c if there are more elements to be added. c if ((ka .le. kamax .or. kb .le. kbmax) .and. & (j1 .le. ncolc .or. j2 .le. ncolc)) then c c three cases c if (j1 .eq. j2) then if (values) c(kc) = a(ka)+b(kb) jc(kc) = j1 ka = ka+1 kb = kb+1 kc = kc+1 else if (j1 .lt. j2) then jc(kc) = j1 if (values) c(kc) = a(ka) ka = ka+1 kc = kc+1 else if (j1 .gt. j2) then jc(kc) = j2 if (values) c(kc) = b(kb) kb = kb+1 kc = kc+1 endif if (kc .gt. nzmx) goto 999 goto 20 end if ic(i+1) = kc 10 continue return 999 ierr = i return c---------end-of-addblk------------------------------------------------- end c----------------------------------------------------------------------- subroutine get1up (n,ja,ia,ju) integer n, ja(*),ia(*),ju(*) c---------------------------------------------------------------------- c obtains the first element of each row of the upper triangular part c of a matrix. Assumes that the matrix is already sorted. c----------------------------------------------------------------------- c parameters c input c ----- c ja = integer array containing the column indices of aij c ia = pointer array. ia(j) contains the position of the c beginning of row j in ja c c output c ------ c ju = integer array of length n. ju(i) is the address in ja c of the first element of the uper triangular part of c of A (including rthe diagonal. Thus if row i does have c a nonzero diagonal element then ju(i) will point to it. c This is a more general version of diapos. c----------------------------------------------------------------------- c local vAriables integer i, k c do 5 i=1, n ju(i) = 0 k = ia(i) c 1 continue if (ja(k) .ge. i) then ju(i) = k goto 5 elseif (k .lt. ia(i+1) -1) then k=k+1 c c go try next element in row c goto 1 endif 5 continue return c-----end-of-get1up----------------------------------------------------- end c---------------------------------------------------------------------- subroutine xtrows (i1,i2,a,ja,ia,ao,jao,iao,iperm,job) integer i1,i2,ja(*),ia(*),jao(*),iao(*),iperm(*),job real*8 a(*),ao(*) c----------------------------------------------------------------------- c this subroutine extracts given rows from a matrix in CSR format. c Specifically, rows number iperm(i1), iperm(i1+1), ...., iperm(i2) c are extracted and put in the output matrix ao, jao, iao, in CSR c format. NOT in place. c Youcef Saad -- coded Feb 15, 1992. c----------------------------------------------------------------------- c on entry: c---------- c i1,i2 = two integers indicating the rows to be extracted. c xtrows will extract rows iperm(i1), iperm(i1+1),..,iperm(i2), c from original matrix and stack them in output matrix c ao, jao, iao in csr format c c a, ja, ia = input matrix in csr format c c iperm = integer array of length nrow containing the reverse permutation c array for the rows. row number iperm(j) in permuted matrix PA c used to be row number j in unpermuted matrix. c ---> a(i,j) in the permuted matrix was a(iperm(i),j) c in the inout matrix. c c job = integer indicating the work to be done: c job .ne. 1 : get structure only of output matrix,, c i.e., ignore real values. (in which case arrays a c and ao are not used nor accessed). c job = 1 get complete data structure of output matrix. c (i.e., including arrays ao and iao). c------------ c on return: c------------ c ao, jao, iao = input matrix in a, ja, ia format c note : c if (job.ne.1) then the arrays a and ao are not used. c----------------------------------------------------------------------c c Y. Saad, revised May 2, 1990 c c----------------------------------------------------------------------c logical values values = (job .eq. 1) c c copying c ko = 1 iao(1) = ko do 100 j=i1,i2 c c ii=iperm(j) is the index of old row to be copied. c ii = iperm(j) do 60 k=ia(ii), ia(ii+1)-1 jao(ko) = ja(k) if (values) ao(ko) = a(k) ko = ko+1 60 continue iao(j-i1+2) = ko 100 continue c return c---------end-of-xtrows------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine csrkvstr(n, ia, ja, nr, kvstr) c----------------------------------------------------------------------- integer n, ia(n+1), ja(*), nr, kvstr(*) c----------------------------------------------------------------------- c Finds block row partitioning of matrix in CSR format. c----------------------------------------------------------------------- c On entry: c-------------- c n = number of matrix scalar rows c ia,ja = input matrix sparsity structure in CSR format c c On return: c--------------- c nr = number of block rows c kvstr = first row number for each block row c c Notes: c----------- c Assumes that the matrix is sorted by columns. c This routine does not need any workspace. c c----------------------------------------------------------------------- c local variables integer i, j, jdiff c----------------------------------------------------------------------- nr = 1 kvstr(1) = 1 c--------------------------------- do i = 2, n jdiff = ia(i+1)-ia(i) if (jdiff .eq. ia(i)-ia(i-1)) then do j = ia(i), ia(i+1)-1 if (ja(j) .ne. ja(j-jdiff)) then nr = nr + 1 kvstr(nr) = i goto 299 endif enddo 299 continue else 300 nr = nr + 1 kvstr(nr) = i endif enddo kvstr(nr+1) = n+1 c--------------------------------- return end c----------------------------------------------------------------------- c------------------------end-of-csrkvstr-------------------------------- subroutine csrkvstc(n, ia, ja, nc, kvstc, iwk) c----------------------------------------------------------------------- integer n, ia(n+1), ja(*), nc, kvstc(*), iwk(*) c----------------------------------------------------------------------- c Finds block column partitioning of matrix in CSR format. c----------------------------------------------------------------------- c On entry: c-------------- c n = number of matrix scalar rows c ia,ja = input matrix sparsity structure in CSR format c c On return: c--------------- c nc = number of block columns c kvstc = first column number for each block column c c Work space: c---------------- c iwk(*) of size equal to the number of scalar columns plus one. c Assumed initialized to 0, and left initialized on return. c c Notes: c----------- c Assumes that the matrix is sorted by columns. c c----------------------------------------------------------------------- c local variables integer i, j, k, ncol c c----------------------------------------------------------------------- c-----use ncol to find maximum scalar column number ncol = 0 c-----mark the beginning position of the blocks in iwk do i = 1, n if (ia(i) .lt. ia(i+1)) then j = ja(ia(i)) iwk(j) = 1 do k = ia(i)+1, ia(i+1)-1 j = ja(k) if (ja(k-1).ne.j-1) then iwk(j) = 1 iwk(ja(k-1)+1) = 1 endif enddo iwk(j+1) = 1 ncol = max0(ncol, j) endif enddo c--------------------------------- nc = 1 kvstc(1) = 1 do i = 2, ncol+1 if (iwk(i).ne.0) then nc = nc + 1 kvstc(nc) = i iwk(i) = 0 endif enddo nc = nc - 1 c--------------------------------- return end c----------------------------------------------------------------------- c------------------------end-of-csrkvstc-------------------------------- c----------------------------------------------------------------------- subroutine kvstmerge(nr, kvstr, nc, kvstc, n, kvst) c----------------------------------------------------------------------- integer nr, kvstr(nr+1), nc, kvstc(nc+1), n, kvst(*) c----------------------------------------------------------------------- c Merges block partitionings, for conformal row/col pattern. c----------------------------------------------------------------------- c On entry: c-------------- c nr,nc = matrix block row and block column dimension c kvstr = first row number for each block row c kvstc = first column number for each block column c c On return: c--------------- c n = conformal row/col matrix block dimension c kvst = conformal row/col block partitioning c c Notes: c----------- c If matrix is not square, this routine returns without warning. c c----------------------------------------------------------------------- c-----local variables integer i,j c--------------------------------- if (kvstr(nr+1) .ne. kvstc(nc+1)) return i = 1 j = 1 n = 1 200 if (i .gt. nr+1) then kvst(n) = kvstc(j) j = j + 1 elseif (j .gt. nc+1) then kvst(n) = kvstr(i) i = i + 1 elseif (kvstc(j) .eq. kvstr(i)) then kvst(n) = kvstc(j) j = j + 1 i = i + 1 elseif (kvstc(j) .lt. kvstr(i)) then kvst(n) = kvstc(j) j = j + 1 else kvst(n) = kvstr(i) i = i + 1 endif n = n + 1 if (i.le.nr+1 .or. j.le.nc+1) goto 200 n = n - 2 c--------------------------------- return c------------------------end-of-kvstmerge------------------------------- end getdp-2.4.2-source/contrib/Sparskit/cmkreord.f000644 001750 001750 00000010505 11266605601 023021 0ustar00geuzainegeuzaine000000 000000 c $Id: cmkreord.f,v 1.1 2008-04-11 06:01:06 geuzaine Exp $ c----------------------------------------------------------------------- subroutine cmkreord(n,a,ja,ia,a0,ja0,ia0, * init,iperm,mask,maskval,nlev,riord, * levels) implicit none integer n,ja(*),ia(*),iperm(n),mask(n),riord(*),levels(*), * nlev,maskval,init integer ja0(*),ia0(*) real*8 a(*),a0(*) c----------------------------------------------------------------------- c Cuthill-McKee Reordering c----------------------------------------------------------------------- c on entry: c---------- c n = number of nodes in the graph c ja, ia = pattern of matrix in CSR format (the ja,ia arrays of csr data c structure) c init = initial node c iperm = integer array indicating in which order to traverse the graph c in order to generate all connected components. c The nodes will be traversed in order iperm(1),....,iperm(n) c Convention: c if iperm(1) .eq. 0 on entry then BFS will traverse the c nodes in the order 1,2,...,n. c c riord = (also an ouput argument). on entry riord contains the labels c of the nfirst nodes that constitute the first level. c c mask = array used to indicate whether or not a node should be c condidered in the graph. see maskval. c mask is also used as a marker of visited nodes. c c maskval= consider node i only when: mask(i) .eq. maskval c maskval must be .gt. 0. c thus, to consider all nodes, take mask(1:n) = 1. c maskval=1 (for example) c c on return c --------- c mask = on return mask is restored to its initial state. c riord = `reverse permutation array'. Contains the labels of the nodes c constituting all the levels found, from the first level to c the last. c levels = pointer array for the level structure. If lev is a level c number, and k1=levels(lev),k2=levels(lev+1)-1, then c all the nodes of level number lev are: c riord(k1),riord(k1+1),...,riord(k2) c nlev = number of levels found c----------------------------------------------------------------------- integer i maskval=1 do i=1,n mask(i)=maskval enddo iperm(1)=0 call perphn(n,ja,ia,init,iperm,mask,maskval,nlev,riord, & levels) call rversp(n,riord) call exchange(n,riord,iperm) call dperm(n,a,ja,ia,a0,ja0,ia0,iperm,iperm,1) end c------------------------------------------------------------------------------- subroutine sort_irv(itmp,rtmp,n) c---------------------------------------------------------------------------- implicit real*8 (a-h,o-z) dimension itmp(n),rtmp(n) do i=1,n itmpmin=itmp(i) jmin=i do j=i+1,n if (itmp(j).lt.itmpmin) then jmin=j itmpmin=itmp(jmin) endif enddo it=itmp(i) itmp(i)=itmp(jmin) itmp(jmin)=it rt=rtmp(i) rtmp(i)=rtmp(jmin) rtmp(jmin)=rt enddo end c------------------------------------------------------------------------------- subroutine sortcol(n,a,ja,ia,iw,rw) c------------------------------------------------------------------------------- implicit real*8 (a-h,o-z) real*8 a(*),rw(*) dimension ia(n+1),ja(*),iw(n) do i=1,n ideb=ia(i) ifin=ia(i+1)-1 k=0 do j=ideb,ifin k=k+1 iw(k)=ja(j) rw(k)= a(j) enddo call sort_irv(iw,rw,ifin-ideb+1) k=0 do j=ideb,ifin k=k+1 ja(j)=iw(k) a(j)=rw(k) enddo enddo return end c------------------------------------------------------------------------------- subroutine exchange(n,iriord,iperm) c------------------------------------------------------------------------------- implicit none integer n,iriord(n),iperm(n) c---------------------------------------------------------------------------- c Reverse a permutation vector c c On entry : c ---------- c n : dimension c iriord : initial reordering vector c On return : c ----------- c iperm : permutation vector to be used with SPARSKIT (dperm ...) c c---------------------------------------------------------------------------- integer i do i=1,n iperm(iriord(i))=i enddo end getdp-2.4.2-source/contrib/Sparskit/inout.f000644 001750 001750 00000155116 11266605601 022361 0ustar00geuzainegeuzaine000000 000000 c $Id: inout.f,v 1.1 2008-04-11 06:01:06 geuzaine Exp $ c----------------------------------------------------------------------c subroutine psplot (ncol,ja,ia,iunt,mode) integer ja(*),ia(*),iunt,ncol,id,mode call pspltm (ncol, ncol, mode, ja, ia, ' ', & 0, 5.0, "in", 0, id, iunt) return end c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c C INPUT-OUTPUT MODULE c c----------------------------------------------------------------------c c contents: c c---------- c c readmt : reads matrices in the Boeing/Harwell format. c c prtmt : prints matrices in the Boeing/Harwell format. c c dump : outputs matrix rows in a simple format (debugging purposes)c c pspltm : generates a post-script plot of the non-zero pattern of A c c pltmt : produces a 'pic' file for plotting a sparse matrix c c smms : write the matrx in a format used in SMMS package c c readsm : reads matrics in coordinate format (as in SMMS package) c c readsk : reads matrices in CSR format (simplified H/B formate). c c skit : writes matrics to a file, format same as above. c c prtunf : writes matrics (in CSR format) unformatted c c readunf: reads unformatted data of matrics (in CSR format) c c----------------------------------------------------------------------c subroutine readmt (nmax,nzmax,job,iounit,a,ja,ia,rhs,nrhs, * guesol,nrow,ncol,nnz,title,key,type,ierr) c----------------------------------------------------------------------- c this subroutine reads a boeing/harwell matrix. handles right hand c sides in full format only (no sparse right hand sides). c Also the matrix must be in assembled forms. c Author: Youcef Saad - Date: Sept., 1989 c updated Oct 31, 1989. c----------------------------------------------------------------------- c on entry: c--------- c nmax = max column dimension allowed for matrix. The array ia should c be of length at least ncol+1 (see below) if job.gt.0 c nzmax = max number of nonzeros elements allowed. the arrays a, c and ja should be of length equal to nnz (see below) if these c arrays are to be read (see job). c c job = integer to indicate what is to be read. (note: job is an c input and output parameter, it can be modified on return) c job = 0 read the values of ncol, nrow, nnz, title, key, c type and return. matrix is not read and arrays c a, ja, ia, rhs are not touched. c job = 1 read srtucture only, i.e., the arrays ja and ia. c job = 2 read matrix including values, i.e., a, ja, ia c job = 3 read matrix and right hand sides: a,ja,ia,rhs. c rhs may contain initial guesses and exact c solutions appended to the actual right hand sides. c this will be indicated by the output parameter c guesol [see below]. c c nrhs = integer. nrhs is an input as well as ouput parameter. c at input nrhs contains the total length of the array rhs. c See also ierr and nrhs in output parameters. c c iounit = logical unit number where to read the matrix from. c c on return: c---------- c job = on return job may be modified to the highest job it could c do: if job=2 on entry but no matrix values are available it c is reset to job=1 on return. Similarly of job=3 but no rhs c is provided then it is rest to job=2 or job=1 depending on c whether or not matrix values are provided. c Note that no error message is triggered (i.e. ierr = 0 c on return in these cases. It is therefore important to c compare the values of job on entry and return ). c c a = the a matrix in the a, ia, ja (column) storage format c ja = column number of element a(i,j) in array a. c ia = pointer array. ia(i) points to the beginning of column i. c c rhs = real array of size nrow + 1 if available (see job) c c nrhs = integer containing the number of right-hand sides found c each right hand side may be accompanied with an intial guess c and also the exact solution. c c guesol = a 2-character string indicating whether an initial guess c (1-st character) and / or the exact solution (2-nd c character) is provided with the right hand side. c if the first character of guesol is 'G' it means that an c an intial guess is provided for each right-hand side. c These are appended to the right hand-sides in the array rhs. c if the second character of guesol is 'X' it means that an c exact solution is provided for each right-hand side. c These are appended to the right hand-sides c and the initial guesses (if any) in the array rhs. c c nrow = number of rows in matrix c ncol = number of columns in matrix c nnz = number of nonzero elements in A. This info is returned c even if there is not enough space in a, ja, ia, in order c to determine the minimum storage needed. c c title = character*72 = title of matrix test ( character a*72). c key = character*8 = key of matrix c type = charatcer*3 = type of matrix. c for meaning of title, key and type refer to documentation c Harwell/Boeing matrices. c c ierr = integer used for error messages c * ierr = 0 means that the matrix has been read normally. c * ierr = 1 means that the array matrix could not be read c because ncol+1 .gt. nmax c * ierr = 2 means that the array matrix could not be read c because nnz .gt. nzmax c * ierr = 3 means that the array matrix could not be read c because both (ncol+1 .gt. nmax) and (nnz .gt. nzmax ) c * ierr = 4 means that the right hand side (s) initial c guesse (s) and exact solution (s) could not be c read because they are stored in sparse format (not handled c by this routine ...) c * ierr = 5 means that the right-hand-sides, initial guesses c and exact solutions could not be read because the length of c rhs as specified by the input value of nrhs is not c sufficient to store them. The rest of the matrix may have c been read normally. c c Notes: c------- c 1) The file inout must be open (and possibly rewound if necessary) c prior to calling readmt. c 2) Refer to the documentation on the Harwell-Boeing formats c for details on the format assumed by readmt. c We summarize the format here for convenience. c c a) all lines in inout are assumed to be 80 character long. c b) the file consists of a header followed by the block of the c column start pointers followed by the block of the c row indices, followed by the block of the real values and c finally the numerical values of the right-hand-side if a c right hand side is supplied. c c) the file starts by a header which contains four lines if no c right hand side is supplied and five lines otherwise. c * first line contains the title (72 characters long) followed by c the 8-character identifier (name of the matrix, called key) c [ A72,A8 ] c * second line contains the number of lines for each c of the following data blocks (4 of them) and the total number c of lines excluding the header. c [5i4] c * the third line contains a three character string identifying c the type of matrices as they are referenced in the Harwell c Boeing documentation [e.g., rua, rsa,..] and the number of c rows, columns, nonzero entries. c [A3,11X,4I14] c * The fourth line contains the variable fortran format c for the following data blocks. c [2A16,2A20] c * The fifth line is only present if right-hand-sides are c supplied. It consists of three one character-strings containing c the storage format for the right-hand-sides c ('F'= full,'M'=sparse=same as matrix), an initial guess c indicator ('G' for yes), an exact solution indicator c ('X' for yes), followed by the number of right-hand-sides c and then the number of row indices. c [A3,11X,2I14] c d) The three following blocks follow the header as described c above. c e) In case the right hand-side are in sparse formats then c the fourth block uses the same storage format as for the matrix c to describe the NRHS right hand sides provided, with a column c being replaced by a right hand side. c----------------------------------------------------------------------- character title*72, key*8, type*3, ptrfmt*16, indfmt*16, 1 valfmt*20, rhsfmt*20, rhstyp*3, guesol*2 integer totcrd, ptrcrd, indcrd, valcrd, rhscrd, nrow, ncol, 1 nnz, neltvl, nrhs, nmax, nzmax, nrwindx integer ia (nmax+1), ja (nzmax) real*8 a(nzmax), rhs(*) c----------------------------------------------------------------------- ierr = 0 lenrhs = nrhs c read (iounit,10) title, key, totcrd, ptrcrd, indcrd, valcrd, 1 rhscrd, type, nrow, ncol, nnz, neltvl, ptrfmt, indfmt, 2 valfmt, rhsfmt 10 format (a72, a8 / 5i14 / a3, 11x, 4i14 / 2a16, 2a20) c if (rhscrd .gt. 0) read (iounit,11) rhstyp, nrhs, nrwindx 11 format (a3,11x,i14,i14) c c anything else to read ? c if (job .le. 0) return c ---- check whether matrix is readable ------ n = ncol if (ncol .gt. nmax) ierr = 1 if (nnz .gt. nzmax) ierr = ierr + 2 if (ierr .ne. 0) return c ---- read pointer and row numbers ---------- read (iounit,ptrfmt) (ia (i), i = 1, n+1) read (iounit,indfmt) (ja (i), i = 1, nnz) c --- reading values of matrix if required.... if (job .le. 1) return c --- and if available ----------------------- if (valcrd .le. 0) then job = 1 return endif read (iounit,valfmt) (a(i), i = 1, nnz) c --- reading rhs if required ---------------- if (job .le. 2) return c --- and if available ----------------------- if ( rhscrd .le. 0) then job = 2 return endif c c --- read right-hand-side.-------------------- c if (rhstyp(1:1) .eq. 'M') then ierr = 4 return endif c guesol = rhstyp(2:3) c nvec = 1 if (guesol(1:1) .eq. 'G' .or. guesol(1:1) .eq. 'g') nvec=nvec+1 if (guesol(2:2) .eq. 'X' .or. guesol(2:2) .eq. 'x') nvec=nvec+1 c len = nrhs*nrow c if (len*nvec .gt. lenrhs) then ierr = 5 return endif c c read right-hand-sides c next = 1 iend = len read(iounit,rhsfmt) (rhs(i), i = next, iend) c c read initial guesses if available c if (guesol(1:1) .eq. 'G' .or. guesol(1:1) .eq. 'g') then next = next+len iend = iend+ len read(iounit,valfmt) (rhs(i), i = next, iend) endif c c read exact solutions if available c if (guesol(2:2) .eq. 'X' .or. guesol(2:2) .eq. 'x') then next = next+len iend = iend+ len read(iounit,valfmt) (rhs(i), i = next, iend) endif c return c--------- end of readmt ----------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine prtmt (nrow,ncol,a,ja,ia,rhs,guesol,title,key,type, 1 ifmt,job,iounit) c----------------------------------------------------------------------- c writes a matrix in Harwell-Boeing format into a file. c assumes that the matrix is stored in COMPRESSED SPARSE COLUMN FORMAT. c some limited functionality for right hand sides. c Author: Youcef Saad - Date: Sept., 1989 - updated Oct. 31, 1989 to c cope with new format. c----------------------------------------------------------------------- c on entry: c--------- c nrow = number of rows in matrix c ncol = number of columns in matrix c a = real*8 array containing the values of the matrix stored c columnwise c ja = integer array of the same length as a containing the column c indices of the corresponding matrix elements of array a. c ia = integer array of containing the pointers to the beginning of c the row in arrays a and ja. c rhs = real array containing the right-hand-side (s) and optionally c the associated initial guesses and/or exact solutions c in this order. See also guesol for details. the vector rhs will c be used only if job .gt. 2 (see below). Only full storage for c the right hand sides is supported. c c guesol = a 2-character string indicating whether an initial guess c (1-st character) and / or the exact solution (2-nd) c character) is provided with the right hand side. c if the first character of guesol is 'G' it means that an c an intial guess is provided for each right-hand sides. c These are assumed to be appended to the right hand-sides in c the array rhs. c if the second character of guesol is 'X' it means that an c exact solution is provided for each right-hand side. c These are assumed to be appended to the right hand-sides c and the initial guesses (if any) in the array rhs. c c title = character*72 = title of matrix test ( character a*72 ). c key = character*8 = key of matrix c type = charatcer*3 = type of matrix. c c ifmt = integer specifying the format chosen for the real values c to be output (i.e., for a, and for rhs-guess-sol if c applicable). The meaning of ifmt is as follows. c * if (ifmt .lt. 100) then the D descriptor is used, c format Dd.m, in which the length (m) of the mantissa is c precisely the integer ifmt (and d = ifmt+6) c * if (ifmt .gt. 100) then prtmt will use the c F- descriptor (format Fd.m) in which the length of the c mantissa (m) is the integer mod(ifmt,100) and the length c of the integer part is k=ifmt/100 (and d = k+m+2) c Thus ifmt= 4 means D10.4 +.xxxxD+ee while c ifmt=104 means F7.4 +x.xxxx c ifmt=205 means F9.5 +xx.xxxxx c Note: formats for ja, and ia are internally computed. c c job = integer to indicate whether matrix values and c a right-hand-side is available to be written c job = 1 write srtucture only, i.e., the arrays ja and ia. c job = 2 write matrix including values, i.e., a, ja, ia c job = 3 write matrix and one right hand side: a,ja,ia,rhs. c job = nrhs+2 write matrix and nrhs successive right hand sides c Note that there cannot be any right-hand-side if the matrix c has no values. Also the initial guess and exact solutions when c provided are for each right hand side. For example if nrhs=2 c and guesol='GX' there are 6 vectors to write. c c c iounit = logical unit number where to write the matrix into. c c on return: c---------- c the matrix a, ja, ia will be written in output unit iounit c in the Harwell-Boeing format. None of the inputs is modofied. c c Notes: 1) This code attempts to pack as many elements as possible per c 80-character line. c 2) this code attempts to avoid as much as possible to put c blanks in the formats that are written in the 4-line header c (This is done for purely esthetical reasons since blanks c are ignored in format descriptors.) c 3) sparse formats for right hand sides and guesses are not c supported. c----------------------------------------------------------------------- character title*72,key*8,type*3,ptrfmt*16,indfmt*16,valfmt*20, * guesol*2, rhstyp*3 integer totcrd, ptrcrd, indcrd, valcrd, rhscrd, nrow, ncol, 1 nnz, nrhs, len, nperli, nrwindx integer ja(*), ia(*) real*8 a(*),rhs(*) c-------------- c compute pointer format c-------------- nnz = ia(ncol+1) -1 len = int ( alog10(0.1+real(nnz+1))) + 1 nperli = 80/len ptrcrd = ncol/nperli + 1 if (len .gt. 9) then assign 101 to ix else assign 100 to ix endif write (ptrfmt,ix) nperli,len 100 format(1h(,i2,1HI,i1,1h) ) 101 format(1h(,i2,1HI,i2,1h) ) c---------------------------- c compute ROW index format c---------------------------- len = int ( alog10(0.1+real(nrow) )) + 1 nperli = min0(80/len,nnz) indcrd = (nnz-1)/nperli+1 write (indfmt,100) nperli,len c--------------- c compute values and rhs format (using the same for both) c--------------- valcrd = 0 rhscrd = 0 c quit this part if no values provided. if (job .le. 1) goto 20 c if (ifmt .ge. 100) then ihead = ifmt/100 ifmt = ifmt-100*ihead len = ihead+ifmt+2 nperli = 80/len c if (len .le. 9 ) then assign 102 to ix elseif (ifmt .le. 9) then assign 103 to ix else assign 104 to ix endif c write(valfmt,ix) nperli,len,ifmt 102 format(1h(,i2,1hF,i1,1h.,i1,1h) ) 103 format(1h(,i2,1hF,i2,1h.,i1,1h) ) 104 format(1h(,i2,1hF,i2,1h.,i2,1h) ) C else len = ifmt + 6 nperli = 80/len c try to minimize the blanks in the format strings. if (nperli .le. 9) then if (len .le. 9 ) then assign 105 to ix elseif (ifmt .le. 9) then assign 106 to ix else assign 107 to ix endif else if (len .le. 9 ) then assign 108 to ix elseif (ifmt .le. 9) then assign 109 to ix else assign 110 to ix endif endif c----------- write(valfmt,ix) nperli,len,ifmt 105 format(1h(,i1,1hD,i1,1h.,i1,1h) ) 106 format(1h(,i1,1hD,i2,1h.,i1,1h) ) 107 format(1h(,i1,1hD,i2,1h.,i2,1h) ) 108 format(1h(,i2,1hD,i1,1h.,i1,1h) ) 109 format(1h(,i2,1hD,i2,1h.,i1,1h) ) 110 format(1h(,i2,1hD,i2,1h.,i2,1h) ) c endif valcrd = (nnz-1)/nperli+1 nrhs = job -2 if (nrhs .ge. 1) then i = (nrhs*nrow-1)/nperli+1 rhscrd = i if (guesol(1:1) .eq. 'G' .or. guesol(1:1) .eq. 'g') + rhscrd = rhscrd+i if (guesol(2:2) .eq. 'X' .or. guesol(2:2) .eq. 'x') + rhscrd = rhscrd+i rhstyp = 'F'//guesol endif 20 continue c totcrd = ptrcrd+indcrd+valcrd+rhscrd c write 4-line or five line header write(iounit,10) title,key,totcrd,ptrcrd,indcrd,valcrd, 1 rhscrd,type,nrow,ncol,nnz,nrhs,ptrfmt,indfmt,valfmt,valfmt c----------------------------------------------------------------------- nrwindx = 0 if (nrhs .ge. 1) write (iounit,11) rhstyp, nrhs, nrwindx 10 format (a72, a8 / 5i14 / a3, 11x, 4i14 / 2a16, 2a20) 11 format(A3,11x,i14,i14) c write(iounit,ptrfmt) (ia (i), i = 1, ncol+1) write(iounit,indfmt) (ja (i), i = 1, nnz) if (job .le. 1) return write(iounit,valfmt) (a(i), i = 1, nnz) if (job .le. 2) return len = nrow*nrhs next = 1 iend = len write(iounit,valfmt) (rhs(i), i = next, iend) c c write initial guesses if available c if (guesol(1:1) .eq. 'G' .or. guesol(1:1) .eq. 'g') then next = next+len iend = iend+ len write(iounit,valfmt) (rhs(i), i = next, iend) endif c c write exact solutions if available c if (guesol(2:2) .eq. 'X' .or. guesol(2:2) .eq. 'x') then next = next+len iend = iend+ len write(iounit,valfmt) (rhs(i), i = next, iend) endif c return c----------end of prtmt ------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine dump (i1,i2,values,a,ja,ia,iout) integer i1, i2, ia(*), ja(*), iout real*8 a(*) logical values c----------------------------------------------------------------------- c outputs rows i1 through i2 of a sparse matrix stored in CSR format c (or columns i1 through i2 of a matrix stored in CSC format) in a file, c one (column) row at a time in a nice readable format. c This is a simple routine which is useful for debugging. c----------------------------------------------------------------------- c on entry: c--------- c i1 = first row (column) to print out c i2 = last row (column) to print out c values= logical. indicates whether or not to print real values. c if value = .false. only the pattern will be output. c a, c ja, c ia = matrix in CSR format (or CSC format) c iout = logical unit number for output. c---------- c the output file iout will have written in it the rows or columns c of the matrix in one of two possible formats (depending on the max c number of elements per row. The values are output with only c two digits of accuracy (D9.2). ) c----------------------------------------------------------------------- c local variables integer maxr, i, k1, k2 c c select mode horizontal or vertical c maxr = 0 do 1 i=i1, i2 maxr = max0(maxr,ia(i+1)-ia(i)) 1 continue if (maxr .le. 8) then c c able to do one row acros line c do 2 i=i1, i2 write(iout,100) i k1=ia(i) k2 = ia(i+1)-1 write (iout,101) (ja(k),k=k1,k2) if (values) write (iout,102) (a(k),k=k1,k2) 2 continue else c c unable to one row acros line. do three items at a time c across a line do 3 i=i1, i2 if (values) then write(iout,200) i else write(iout,203) i endif k1=ia(i) k2 = ia(i+1)-1 if (values) then write (iout,201) (ja(k),a(k),k=k1,k2) else write (iout,202) (ja(k),k=k1,k2) endif 3 continue endif c c formats : c 100 format (1h ,34(1h-),' row',i6,1x,34(1h-) ) 101 format(' col:',8(i5,6h : )) 102 format(' val:',8(D9.2,2h :) ) 200 format (1h ,30(1h-),' row',i3,1x,30(1h-),/ * 3(' columns : values * ') ) c-------------xiiiiiihhhhhhddddddddd-*- 201 format(3(1h ,i6,6h : ,D9.2,3h * ) ) 202 format(6(1h ,i5,6h * ) ) 203 format (1h ,30(1h-),' row',i3,1x,30(1h-),/ * 3(' column : column *') ) return c----end-of-dump-------------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine pspltm(nrow,ncol,mode,ja,ia,title,ptitle,size,munt, * nlines,lines,iunt) c----------------------------------------------------------------------- integer nrow,ncol,ptitle,mode,iunt, ja(*), ia(*), lines(nlines) real size character title*(*), munt*2 c----------------------------------------------------------------------- c PSPLTM - PostScript PLoTer of a (sparse) Matrix c This version by loris renggli (renggli@masg1.epfl.ch), Dec 1991 c and Youcef Saad c------ c Loris RENGGLI, Swiss Federal Institute of Technology, Math. Dept c CH-1015 Lausanne (Switzerland) -- e-mail: renggli@masg1.epfl.ch c Modified by Youcef Saad -- June 24, 1992 to add a few features: c separation lines + acceptance of MSR format. c----------------------------------------------------------------------- c input arguments description : c c nrow = number of rows in matrix c c ncol = number of columns in matrix c c mode = integer indicating whether the matrix is stored in c CSR mode (mode=0) or CSC mode (mode=1) or MSR mode (mode=2) c c ja = column indices of nonzero elements when matrix is c stored rowise. Row indices if stores column-wise. c ia = integer array of containing the pointers to the c beginning of the columns in arrays a, ja. c c title = character*(*). a title of arbitrary length to be printed c as a caption to the figure. Can be a blank character if no c caption is desired. c c ptitle = position of title; 0 under the drawing, else above c c size = size of the drawing c c munt = units used for size : 'cm' or 'in' c c nlines = number of separation lines to draw for showing a partionning c of the matrix. enter zero if no partition lines are wanted. c c lines = integer array of length nlines containing the coordinates of c the desired partition lines . The partitioning is symmetric: c a horizontal line across the matrix will be drawn in c between rows lines(i) and lines(i)+1 for i=1, 2, ..., nlines c an a vertical line will be similarly drawn between columns c lines(i) and lines(i)+1 for i=1,2,...,nlines c c iunt = logical unit number where to write the matrix into. c----------------------------------------------------------------------- c additional note: use of 'cm' assumes european format for paper size c (21cm wide) and use of 'in' assumes american format (8.5in wide). c The correct centering of the figure depends on the proper choice. Y.S. c----------------------------------------------------------------------- c external integer LENSTR external LENSTR c local variables --------------------------------------------------- integer n,nr,nc,maxdim,istart,ilast,ii,k,ltit real lrmrgn,botmrgn,xtit,ytit,ytitof,fnstit,siz real xl,xr, yb,yt, scfct,u2dot,frlw,delt,paperx,conv,xx,yy logical square c change square to .true. if you prefer a square frame around c a rectangular matrix data haf /0.5/, zero/0.0/, conv/2.54/,square/.false./ c----------------------------------------------------------------------- siz = size nr = nrow nc = ncol n = nc if (mode .eq. 0) n = nr c nnz = ia(n+1) - ia(1) maxdim = max(nrow, ncol) m = 1 + maxdim nc = nc+1 nr = nr+1 c c units (cm or in) to dot conversion factor and paper size c if (munt.eq.'cm' .or. munt.eq.'CM') then u2dot = 72.0/conv paperx = 21.0 else u2dot = 72.0 paperx = 8.5*conv siz = siz*conv end if c c left and right margins (drawing is centered) c lrmrgn = (paperx-siz)/2.0 c c bottom margin : 2 cm c botmrgn = 2.0 c scaling factor scfct = siz*u2dot/m c matrix frame line witdh frlw = 0.25 c font size for title (cm) fnstit = 0.5 ltit = LENSTR(title) c position of title : centered horizontally c at 1.0 cm vertically over the drawing ytitof = 1.0 xtit = paperx/2.0 ytit = botmrgn+siz*nr/m + ytitof c almost exact bounding box xl = lrmrgn*u2dot - scfct*frlw/2 xr = (lrmrgn+siz)*u2dot + scfct*frlw/2 yb = botmrgn*u2dot - scfct*frlw/2 yt = (botmrgn+siz*nr/m)*u2dot + scfct*frlw/2 if (ltit.gt.0) then yt = yt + (ytitof+fnstit*0.70)*u2dot end if c add some room to bounding box delt = 10.0 xl = xl-delt xr = xr+delt yb = yb-delt yt = yt+delt c c correction for title under the drawing if (ptitle.eq.0 .and. ltit.gt.0) then ytit = botmrgn + fnstit*0.3 botmrgn = botmrgn + ytitof + fnstit*0.7 end if c begin of output c write(iunt,10) '%!' write(iunt,10) '%%Creator: PSPLTM routine' write(iunt,12) '%%BoundingBox:',xl,yb,xr,yt write(iunt,10) '%%EndComments' write(iunt,10) '/cm {72 mul 2.54 div} def' write(iunt,10) '/mc {72 div 2.54 mul} def' write(iunt,10) '/pnum { 72 div 2.54 mul 20 string' write(iunt,10) 'cvs print ( ) print} def' write(iunt,10) 1 '/Cshow {dup stringwidth pop -2 div 0 rmoveto show} def' c c we leave margins etc. in cm so it is easy to modify them if c needed by editing the output file write(iunt,10) 'gsave' if (ltit.gt.0) then write(iunt,*) '/Helvetica findfont ',fnstit, & ' cm scalefont setfont ' write(iunt,*) xtit,' cm ',ytit,' cm moveto ' write(iunt,'(3A)') '(',title(1:ltit),') Cshow' end if write(iunt,*) lrmrgn,' cm ',botmrgn,' cm translate' write(iunt,*) siz,' cm ',m,' div dup scale ' c------- c draw a frame around the matrix write(iunt,*) frlw,' setlinewidth' write(iunt,10) 'newpath' write(iunt,11) 0, 0, ' moveto' if (square) then write(iunt,11) m,0,' lineto' write(iunt,11) m, m, ' lineto' write(iunt,11) 0,m,' lineto' else write(iunt,11) nc,0,' lineto' write(iunt,11) nc,nr,' lineto' write(iunt,11) 0,nr,' lineto' end if write(iunt,10) 'closepath stroke' c c drawing the separation lines c write(iunt,*) ' 0.2 setlinewidth' do 22 kol=1, nlines isep = lines(kol) c c horizontal lines c yy = real(nrow-isep) + haf xx = real(ncol+1) write(iunt,13) zero, yy, ' moveto ' write(iunt,13) xx, yy, ' lineto stroke ' c c vertical lines c xx = real(isep) + haf yy = real(nrow+1) write(iunt,13) xx, zero,' moveto ' write(iunt,13) xx, yy, ' lineto stroke ' 22 continue c c----------- plotting loop --------------------------------------------- c write(iunt,10) '1 1 translate' write(iunt,10) '0.8 setlinewidth' write(iunt,10) '/p {moveto 0 -.40 rmoveto ' write(iunt,10) ' 0 .80 rlineto stroke} def' c do 1 ii=1, n istart = ia(ii) ilast = ia(ii+1)-1 if (mode .eq. 1) then do 2 k=istart, ilast write(iunt,11) ii-1, nrow-ja(k), ' p' 2 continue else do 3 k=istart, ilast write(iunt,11) ja(k)-1, nrow-ii, ' p' 3 continue c add diagonal element if MSR mode. if (mode .eq. 2) * write(iunt,11) ii-1, nrow-ii, ' p' c endif 1 continue c----------------------------------------------------------------------- write(iunt,10) 'showpage' return c 10 format (A) 11 format (2(I6,1x),A) 12 format (A,4(1x,F9.2)) 13 format (2(F9.2,1x),A) c----------------------------------------------------------------------- end c integer function lenstr(s) c----------------------------------------------------------------------- c return length of the string S c----------------------------------------------------------------------- character*(*) s integer len intrinsic len integer n c----------------------------------------------------------------------- n = len(s) 10 continue if (s(n:n).eq.' ') then n = n-1 if (n.gt.0) go to 10 end if lenstr = n c return c--------end-of-pspltm-------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine pltmt (nrow,ncol,mode,ja,ia,title,key,type, 1 job, iounit) c----------------------------------------------------------------------- c this subroutine creates a 'pic' file for plotting the pattern of c a sparse matrix stored in general sparse format. it is not intended c to be a means of plotting large matrices (it is very inefficient). c It is however useful for small matrices and can be used for example c for inserting matrix plots in a text. The size of the plot can be c 7in x 7in or 5 in x 5in .. There is also an option for writing a c 3-line header in troff (see description of parameter job). c Author: Youcef Saad - Date: Sept., 1989 c See SPARSKIT/UNSUPP/ for a version of this to produce a post-script c file. c----------------------------------------------------------------------- c nrow = number of rows in matrix c c ncol = number of columns in matrix c c mode = integer indicating whether the matrix is stored c row-wise (mode = 0) or column-wise (mode=1) c c ja = column indices of nonzero elements when matrix is c stored rowise. Row indices if stores column-wise. c ia = integer array of containing the pointers to the c beginning of the columns in arrays a, ja. c c title = character*71 = title of matrix test ( character a*71 ). c key = character*8 = key of matrix c type = character*3 = type of matrix. c c job = this integer parameter allows to set a few minor c options. First it tells pltmt whether or not to c reduce the plot. The standard size of 7in is then c replaced by a 5in plot. It also tells pltmt whether or c not to append to the pic file a few 'troff' lines that c produce a centered caption includingg the title, key and c types as well as the size and number of nonzero elements. c job = 0 : do not reduce and do not make caption. c job = 1 : reduce and do not make caption. c job = 10 : do not reduce and make caption c job = 11 : reduce and make caption. c (i.e. trailing digit for reduction, leading digit for caption) c c iounit = logical unit number where to write the matrix into. c c----------------------------------------------------------------------- c example of usage . c----------------- c In the fortran code: c a) read a Harwell/Boeing matrix c call readmt (.....) c iout = 13 c b) generate pic file: c call pltmt (nrow,ncol,mode,ja,ia,title,key,type,iout) c stop c --------- c Then in a unix environment plot the matrix by the command c c pic FOR013.DAT | troff -me | lpr -Ppsx c c----------------------------------------------------------------------- c notes: 1) Plots square as well as rectangular matrices. c (however not as much tested with rectangular matrices.) c 2) the dot-size is adapted according to the size of the c matrix. c 3) This is not meant at all as a way of plotting large c matrices. The pic file generaled will have one line for c each nonzero element. It is only meant for use in c such things as document poreparations etc.. c 4) The caption written will print the 71 character long c title. This may not be centered correctly if the c title has trailing blanks (a problem with Troff). c if you want the title centered then you can center c the string in title before calling pltmt. c c----------------------------------------------------------------------- integer ja(*), ia(*) character key*8,title*72,type*3 real x, y c------- n = ncol if (mode .eq. 0) n = nrow nnz = ia(n+1) - ia(1) maxdim = max0 (nrow, ncol) xnrow = real(nrow) ptsize = 0.08 hscale = (7.0 -2.0*ptsize)/real(maxdim-1) vscale = hscale xwid = ptsize + real(ncol-1)*hscale + ptsize xht = ptsize + real(nrow-1)*vscale + ptsize xshift = (7.0-xwid)/2.0 yshift = (7.0-xht)/2.0 c------ if (mod(job,10) .eq. 1) then write (iounit,88) else write (iounit,89) endif 88 format('.PS 5in',/,'.po 1.8i') 89 format('.PS',/,'.po 0.7i') write(iounit,90) 90 format('box invisible wid 7.0 ht 7.0 with .sw at (0.0,0.0) ') write(iounit,91) xwid, xht, xshift, yshift 91 format('box wid ',f5.2,' ht ',f5.2, * ' with .sw at (',f5.2,',',f5.2,')' ) c c shift points slightly to account for size of dot , etc.. c tiny = 0.03 if (mod(job,10) .eq. 1) tiny = 0.05 xshift = xshift + ptsize - tiny yshift = yshift + ptsize + tiny c c----------------------------------------------------------------------- c ips = 8 if (maxdim .le. 500) ips = 10 if (maxdim .le. 300) ips = 12 if (maxdim .le. 100) ips = 16 if (maxdim .lt. 50) ips = 24 write(iounit,92) ips 92 format ('.ps ',i2) c c-----------plottingloop --------------------------------------------- c do 1 ii=1, n istart = ia(ii) ilast = ia(ii+1)-1 if (mode .ne. 0) then x = real(ii-1) do 2 k=istart, ilast y = xnrow-real(ja(k)) write(iounit,128) xshift+x*hscale, yshift+y*vscale 2 continue else y = xnrow - real(ii) do 3 k=istart, ilast x = real(ja(k)-1) write(iounit,128) xshift+x*hscale, yshift+y*vscale 3 continue endif 1 continue c----------------------------------------------------------------------- 128 format(7h"." at ,f6.3,1h,,f6.3,8h ljust ) write (iounit, 129) 129 format('.PE') c quit if caption not desired. if ( (job/10) .ne. 1) return c write(iounit,127) key, type, title write(iounit,130) nrow,ncol,nnz 127 format('.sp 4'/'.ll 7i'/'.ps 12'/'.po 0.7i'/'.ce 3'/, * 'Matrix: ',a8,', Type: ',a3,/,a72) 130 format('Dimension: ',i4,' x ',i4,', Nonzero elements: ',i5) return c----------------end-of-pltmt ------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine smms (n,first,last,mode,a,ja,ia,iout) integer ia(*), ja(*), n, first, last, mode, iout real*8 a(*) c----------------------------------------------------------------------- c writes a matrix in Coordinate (SMMS) format -- c----------------------------------------------------------------------- c on entry: c--------- c n = integer = size of matrix -- number of rows (columns if matrix c is stored columnwise) c first = first row (column) to be output. This routine will output c rows (colums) first to last. c last = last row (column) to be output. c mode = integer giving some information about the storage of the c matrix. A 3-digit decimal number. 'htu' c * u = 0 means that matrix is stored row-wise c * u = 1 means that matrix is stored column-wise c * t = 0 indicates that the matrix is stored in CSR format c * t = 1 indicates that the matrix is stored in MSR format. c * h = ... to be added. c a, c ja, c ia = matrix in CSR or MSR format (see mode) c iout = output unit number. c c on return: c---------- c the output file iout will have written in it the matrix in smms c (coordinate format) c c----------------------------------------------------------------------- logical msr, csc c c determine mode ( msr or csr ) c msr = .false. csc = .false. if (mod(mode,10) .eq. 1) csc = .true. if ( (mode/10) .eq. 1) msr = .true. write (iout,*) n do 2 i=first, last k1=ia(i) k2 = ia(i+1)-1 c write (iout,*) ' row ', i if (msr) write(iout,'(2i6,e22.14)') i, i, a(i) do 10 k=k1, k2 if (csc) then write(iout,'(2i6,e22.14)') ja(k), i, a(k) else write(iout,'(2i6,e22.14)') i, ja(k), a(k) endif 10 continue 2 continue c----end-of-smms-------------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine readsm (nmax,nzmax,n,nnz,ia,ja,a,iout,ierr) integer nmax, nzmax, row, n, iout, i, j, k, ierr integer ia(nmax+1), ja(nzmax) real*8 a(nzmax), x c----------------------------------------------------------------------- c read a matrix in coordinate format as is used in the SMMS c package (F. Alvarado), i.e. the row is in ascending order. c Outputs the matrix in CSR format. c----------------------------------------------------------------------- c coded by Kesheng Wu on Oct 21, 1991 with the supervision of Y. Saad c----------------------------------------------------------------------- c on entry: c--------- c nmax = the maximum size of array c nzmax = the maximum number of nonzeros c iout = the I/O unit that has the data file c c on return: c---------- c n = integer = size of matrix c nnz = number of non-zero entries in the matrix c a, c ja, c ia = matrix in CSR format c ierr = error code, c 0 -- subroutine end with intended job done c 1 -- error in I/O unit iout c 2 -- end-of-file reached while reading n, i.e. a empty data file c 3 -- n non-positive or too large c 4 -- nnz is zero or larger than nzmax c 5 -- data file is not orgnized in the order of ascending c row indices c c in case of errors: c n will be set to zero (0). In case the data file has more than nzmax c number of entries, the first nzmax entries will be read, and are not c cleared on return. The total number of entry is determined. c Ierr is set. c----------------------------------------------------------------------- c rewind(iout) nnz = 0 ia(1) = 1 row = 1 c read (iout,*, err=1000, end=1010) n if ((n.le.0) .or. (n.gt.nmax)) goto 1020 c 10 nnz = nnz + 1 read (iout, *, err=1000, end=100) i, j, x c set the pointers when needed if (i.gt.row) then do 20 k = row+1, i ia(k) = nnz 20 continue row = i else if (i.lt.row) then goto 1040 endif ja(nnz) = j a (nnz) = x if (nnz.lt.nzmax) then goto 10 else goto 1030 endif c normal return -- end of file reached 100 ia(row+1) = nnz nnz = nnz - 1 if (nnz.eq.0) goto 1030 c c everything seems to be OK. c ierr = 0 return c c error handling code c c error in reading data entries c 1000 ierr = 1 goto 2000 c c empty file c 1010 ierr = 2 goto 2000 c c problem with n c 1020 ierr = 3 goto 2000 c c problem with nnz c 1030 ierr = 4 c c try to determine the real number of entries, in case needed c if (nnz.ge.nzmax) then 200 read(iout, *, err=210, end=210) i, j, x nnz = nnz + 1 goto 200 210 continue endif goto 2000 c c data entries not ordered c 1040 ierr = 5 2000 n = 0 return c----end-of-readsm------------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine readsk (nmax,nzmax,n,nnz,a,ja,ia,iounit,ierr) integer nmax, nzmax, iounit, n, nnz, i, ierr integer ia(nmax+1), ja(nzmax) real*8 a(nzmax) c----------------------------------------------------------------------- c Reads matrix in Compressed Saprse Row format. The data is supposed to c appear in the following order -- n, ia, ja, a c Only square matrices accepted. Format has following features c (1) each number is separated by at least one space (or end-of-line), c (2) each array starts with a new line. c----------------------------------------------------------------------- c coded by Kesheng Wu on Oct 21, 1991 with supervision of Y. Saad c----------------------------------------------------------------------- c on entry: c--------- c nmax = max column dimension allowed for matrix. c nzmax = max number of nonzeros elements allowed. the arrays a, c and ja should be of length equal to nnz (see below). c iounit = logical unit number where to read the matrix from. c c on return: c---------- c ia, c ja, c a = matrx in CSR format c n = number of rows(columns) in matrix c nnz = number of nonzero elements in A. This info is returned c even if there is not enough space in a, ja, ia, in order c to determine the minimum storage needed. c ierr = error code, c 0 : OK; c 1 : error when try to read the specified I/O unit. c 2 : end-of-file reached during reading of data file. c 3 : array size in data file is negtive or larger than nmax; c 4 : nunmer of nonzeros in data file is negtive or larger than nzmax c in case of errors: c--------- c n is set to 0 (zero), at the same time ierr is set. c----------------------------------------------------------------------- c c read the size of the matrix c rewind(iounit) read (iounit, *, err=1000, end=1010) n if ((n.le.0).or.(n.gt.nmax)) goto 1020 c c read the pointer array ia(*) c read (iounit, *, err=1000, end=1010) (ia(i), i=1, n+1) c c Number of None-Zeros c nnz = ia(n+1) - 1 if ((nnz.le.0).or.(nnz.gt.nzmax)) goto 1030 c c read the column indices array c read (iounit, *, err=1000, end=1010) (ja(i), i=1, nnz) c c read the matrix elements c read (iounit, *, err=1000, end=1010) (a(i), i=1, nnz) c c normal return c ierr = 0 return c c error handling code c c error in reading I/O unit 1000 ierr = 1 goto 2000 c c EOF reached in reading 1010 ierr =2 goto 2000 c c n non-positive or too large 1020 ierr = 3 n = 0 goto 2000 c c NNZ non-positive or too large 1030 ierr = 4 c c the real return statement c 2000 n = 0 return c---------end of readsk ------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine skit (n, a, ja, ia, ifmt, iounit, ierr) c----------------------------------------------------------------------- c Writes a matrix in Compressed Sparse Row format to an I/O unit. c It tryes to pack as many number as possible into lines of less than c 80 characters. Space is inserted in between numbers for separation c to avoid carrying a header in the data file. This can be viewed c as a simplified Harwell-Boeing format. c----------------------------------------------------------------------- c Modified from subroutine prtmt written by Y. Saad c----------------------------------------------------------------------- c on entry: c--------- c n = number of rows(columns) in matrix c a = real*8 array containing the values of the matrix stored c columnwise c ja = integer array of the same length as a containing the column c indices of the corresponding matrix elements of array a. c ia = integer array of containing the pointers to the beginning of c the row in arrays a and ja. c ifmt = integer specifying the format chosen for the real values c to be output (i.e., for a, and for rhs-guess-sol if c applicable). The meaning of ifmt is as follows. c * if (ifmt .lt. 100) then the D descriptor is used, c format Dd.m, in which the length (m) of the mantissa is c precisely the integer ifmt (and d = ifmt+6) c * if (ifmt .gt. 100) then prtmt will use the c F- descriptor (format Fd.m) in which the length of the c mantissa (m) is the integer mod(ifmt,100) and the length c of the integer part is k=ifmt/100 (and d = k+m+2) c Thus ifmt= 4 means D10.4 +.xxxxD+ee while c ifmt=104 means F7.4 +x.xxxx c ifmt=205 means F9.5 +xx.xxxxx c Note: formats for ja, and ia are internally computed. c c iounit = logical unit number where to write the matrix into. c c on return: c---------- c ierr = error code, 0 for normal 1 for error in writing to iounit. c c on error: c-------- c If error is encontacted when writing the matrix, the whole matrix c is written to the standard output. c ierr is set to 1. c----------------------------------------------------------------------- character ptrfmt*16,indfmt*16,valfmt*20 integer iounit, n, ifmt, len, nperli, nnz, i, ihead integer ja(*), ia(*), ierr real*8 a(*) c-------------- c compute pointer format c-------------- nnz = ia(n+1) len = int ( alog10(0.1+real(nnz))) + 2 nnz = nnz - 1 nperli = 80/len c print *, ' skit entries:', n, nnz, len, nperli if (len .gt. 9) then assign 101 to ix else assign 100 to ix endif write (ptrfmt,ix) nperli,len 100 format(1h(,i2,1HI,i1,1h) ) 101 format(1h(,i2,1HI,i2,1h) ) c---------------------------- c compute ROW index format c---------------------------- len = int ( alog10(0.1+real(n) )) + 2 nperli = min0(80/len,nnz) write (indfmt,100) nperli,len c--------------------------- c compute value format c--------------------------- if (ifmt .ge. 100) then ihead = ifmt/100 ifmt = ifmt-100*ihead len = ihead+ifmt+3 nperli = 80/len c if (len .le. 9 ) then assign 102 to ix elseif (ifmt .le. 9) then assign 103 to ix else assign 104 to ix endif c write(valfmt,ix) nperli,len,ifmt 102 format(1h(,i2,1hF,i1,1h.,i1,1h) ) 103 format(1h(,i2,1hF,i2,1h.,i1,1h) ) 104 format(1h(,i2,1hF,i2,1h.,i2,1h) ) C else len = ifmt + 7 nperli = 80/len c try to minimize the blanks in the format strings. if (nperli .le. 9) then if (len .le. 9 ) then assign 105 to ix elseif (ifmt .le. 9) then assign 106 to ix else assign 107 to ix endif else if (len .le. 9 ) then assign 108 to ix elseif (ifmt .le. 9) then assign 109 to ix else assign 110 to ix endif endif c----------- write(valfmt,ix) nperli,len,ifmt 105 format(1h(,i1,1hD,i1,1h.,i1,1h) ) 106 format(1h(,i1,1hD,i2,1h.,i1,1h) ) 107 format(1h(,i1,1hD,i2,1h.,i2,1h) ) 108 format(1h(,i2,1hD,i1,1h.,i1,1h) ) 109 format(1h(,i2,1hD,i2,1h.,i1,1h) ) 110 format(1h(,i2,1hD,i2,1h.,i2,1h) ) c endif c c output the data c write(iounit, *) n write(iounit,ptrfmt,err=1000) (ia(i), i = 1, n+1) write(iounit,indfmt,err=1000) (ja(i), i = 1, nnz) write(iounit,valfmt,err=1000) ( a(i), i = 1, nnz) c c done, if no trouble is encounted in writing data c ierr = 0 return c c if can't write the data to the I/O unit specified, should be able to c write everything to standard output (unit 6) c 1000 write(0, *) 'Error, Can''t write data to sepcified unit',iounit write(0, *) 'Write the matrix into standard output instead!' ierr = 1 write(6,*) n write(6,ptrfmt) (ia(i), i=1, n+1) write(6,indfmt) (ja(i), i=1, nnz) write(6,valfmt) ( a(i), i=1, nnz) return c----------end of skit ------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine prtunf(n, a, ja, ia, iout, ierr) c----------------------------------------------------------------------- c This subroutine dumps the arrays used for storing sparse compressed row c format in machine code, i.e. unformatted using standard FORTRAN term. c----------------------------------------------------------------------- c First coded by Kesheng Wu on Oct 21, 1991 under the instruction of c Prof. Y. Saad c----------------------------------------------------------------------- c On entry: c n: the size of the matrix (matrix is n X n) c ia: integer array stores the stariting position of each row. c ja: integer array stores the column indices of each entry. c a: the non-zero entries of the matrix. c iout: the unit number opened for storing the matrix. c On return: c ierr: a error, 0 if everything's OK, else 1 if error in writing data. c On error: c set ierr to 1. c No redirection is made, since direct the machine code to the standard c output may cause unpridictable consequences. c----------------------------------------------------------------------- integer iout, n, nnz, ierr, ia(*), ja(*) real*8 a(*) nnz = ia(n+1)-ia(1) c write(unit=iout, err=1000) n write(unit=iout, err=1000) (ia(k),k=1,n+1) if (nnz .gt. 0) then write(unit=iout, err=1000) (ja(k),k=1,nnz) write(unit=iout, err=1000) ( a(k),k=1,nnz) endif c ierr = 0 return c 1000 ierr = 1 return end c---------end of prtunf ------------------------------------------------ c c----------------------------------------------------------------------- subroutine readunf(nmax,nzmax,n,nnz,a,ja,ia,iounit,ierr) c----------------------------------------------------------------------- c This subroutine reads a matix store in machine code (FORTRAN c unformatted form). The matrix is in CSR format. c----------------------------------------------------------------------- c First coded by Kesheng Wu on Oct 21, 1991 under the instruction of c Prof. Y. Saad c----------------------------------------------------------------------- c On entry: c nmax: the maximum value of matrix size. c nzmax: the maximum number of non-zero entries. c iounit: the I/O unit that opened for reading. c On return: c n: the actual size of array. c nnz: the actual number of non-zero entries. c ia,ja,a: the matrix in CSR format. c ierr: a error code, it's same as that used in reaadsk c 0 -- OK c 1 -- error in reading iounit c 2 -- end-of-file reached while reading data file c 3 -- n is non-positive or too large c 4 -- nnz is non-positive or too large c On error: c return with n set to 0 (zero). nnz is kept if it's set already, c in case one want to use it to determine the size of array needed c to hold the data. c----------------------------------------------------------------------- c integer nmax, nzmax, n, iounit, nnz, k integer ia(nmax+1), ja(nzmax) real*8 a(nzmax) c rewind iounit c read (unit=iounit, err=1000, end=1010) n if ((n.le.0) .or. (n.gt.nmax)) goto 1020 c read(unit=iounit, err=1000, end=1010) (ia(k),k=1,n+1) c nnz = ia(n+1) - 1 if ((nnz.le.0) .or. (nnz.gt.nzmax)) goto 1030 c read(unit=iounit, err=1000, end=1010) (ja(k),k=1,nnz) read(unit=iounit, err=1000, end=1010) (a(k),k=1,nnz) c c everything seems to be OK. c ierr = 0 return c c error handling c 1000 ierr = 1 goto 2000 1010 ierr = 2 goto 2000 1020 ierr = 3 goto 2000 1030 ierr = 4 2000 n = 0 return end c---------end of readunf ---------------------------------------------- getdp-2.4.2-source/contrib/Sparskit/formats.f000644 001750 001750 00000412513 11266605601 022673 0ustar00geuzainegeuzaine000000 000000 c $Id: formats.f,v 1.1 2008-04-11 06:01:06 geuzaine Exp $ c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c FORMAT CONVERSION MODULE c c----------------------------------------------------------------------c c contents: c c---------- c c csrdns : converts a row-stored sparse matrix into the dense format. c c dnscsr : converts a dense matrix to a sparse storage format. c c coocsr : converts coordinate to to csr format c c coicsr : in-place conversion of coordinate to csr format c c csrcoo : converts compressed sparse row to coordinate. c c csrssr : converts compressed sparse row to symmetric sparse row c c ssrcsr : converts symmetric sparse row to compressed sparse row c c csrell : converts compressed sparse row to ellpack format c c ellcsr : converts ellpack format to compressed sparse row format c c csrmsr : converts compressed sparse row format to modified sparse c c row format c c msrcsr : converts modified sparse row format to compressed sparse c c row format. c c csrcsc : converts compressed sparse row format to compressed sparse c c column format (transposition) c c csrcsc2 : rectangular version of csrcsc c c csrlnk : converts compressed sparse row to linked list format c c lnkcsr : converts linked list format to compressed sparse row fmt c c csrdia : converts a compressed sparse row format into a diagonal c c format. c c diacsr : converts a diagonal format into a compressed sparse row c c format. c c bsrcsr : converts a block-row sparse format into a compressed c c sparse row format. c c csrbsr : converts a compressed sparse row format into a block-row c c sparse format. c c csrbnd : converts a compressed sparse row format into a banded c c format (linpack style). c c bndcsr : converts a banded format (linpack style) into a compressed c c sparse row storage. c c csrssk : converts the compressed sparse row format to the symmetric c c skyline format c c sskssr : converts symmetric skyline format to symmetric sparse row c c format. c c csrjad : converts the csr format into the jagged diagonal format c c jadcsr : converts the jagged-diagonal format into the csr format c c csruss : Compressed Sparse Row to Unsymmetric Sparse Skyline c c format c c usscsr : Unsymmetric Sparse Skyline format to Compressed Sparse Row c c csrsss : Compressed Sparse Row to Symmetric Sparse Skyline format c c ssscsr : Symmetric Sparse Skyline format to Compressed Sparse Row c c csrvbr : Converts compressed sparse row to var block row format c c vbrcsr : Converts var block row to compressed sparse row format c c csorted : Checks if matrix in CSR format is sorted by columns c c--------- miscalleneous additions not involving the csr format--------c c cooell : converts coordinate to Ellpack/Itpack format c c dcsort : sorting routine used by crsjad c c----------------------------------------------------------------------c subroutine csrdns(nrow,ncol,a,ja,ia,dns,ndns,ierr) real*8 dns(ndns,*),a(*) integer ja(*),ia(*) c----------------------------------------------------------------------- c Compressed Sparse Row to Dense c----------------------------------------------------------------------- c c converts a row-stored sparse matrix into a densely stored one c c On entry: c---------- c c nrow = row-dimension of a c ncol = column dimension of a c a, c ja, c ia = input matrix in compressed sparse row format. c (a=value array, ja=column array, ia=pointer array) c dns = array where to store dense matrix c ndns = first dimension of array dns c c on return: c----------- c dns = the sparse matrix a, ja, ia has been stored in dns(ndns,*) c c ierr = integer error indicator. c ierr .eq. 0 means normal return c ierr .eq. i means that the code has stopped when processing c row number i, because it found a column number .gt. ncol. c c----------------------------------------------------------------------- ierr = 0 do 1 i=1, nrow do 2 j=1,ncol dns(i,j) = 0.0d0 2 continue 1 continue c do 4 i=1,nrow do 3 k=ia(i),ia(i+1)-1 j = ja(k) if (j .gt. ncol) then ierr = i return endif dns(i,j) = a(k) 3 continue 4 continue return c---- end of csrdns ---------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine dnscsr(nrow,ncol,nzmax,dns,ndns,a,ja,ia,ierr) real*8 dns(ndns,*),a(*) integer ia(*),ja(*) c----------------------------------------------------------------------- c Dense to Compressed Row Sparse c----------------------------------------------------------------------- c c converts a densely stored matrix into a row orientied c compactly sparse matrix. ( reverse of csrdns ) c Note: this routine does not check whether an element c is small. It considers that a(i,j) is zero if it is exactly c equal to zero: see test below. c----------------------------------------------------------------------- c on entry: c--------- c c nrow = row-dimension of a c ncol = column dimension of a c nzmax = maximum number of nonzero elements allowed. This c should be set to be the lengths of the arrays a and ja. c dns = input nrow x ncol (dense) matrix. c ndns = first dimension of dns. c c on return: c---------- c c a, ja, ia = value, column, pointer arrays for output matrix c c ierr = integer error indicator: c ierr .eq. 0 means normal retur c ierr .eq. i means that the the code stopped while c processing row number i, because there was no space left in c a, and ja (as defined by parameter nzmax). c----------------------------------------------------------------------- ierr = 0 next = 1 ia(1) = 1 do 4 i=1,nrow do 3 j=1, ncol if (dns(i,j) .eq. 0.0d0) goto 3 if (next .gt. nzmax) then ierr = i return endif ja(next) = j a(next) = dns(i,j) next = next+1 3 continue ia(i+1) = next 4 continue return c---- end of dnscsr ---------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine coocsr(nrow,nnz,a,ir,jc,ao,jao,iao) c----------------------------------------------------------------------- real*8 a(*),ao(*),x integer ir(*),jc(*),jao(*),iao(*) c----------------------------------------------------------------------- c Coordinate to Compressed Sparse Row c----------------------------------------------------------------------- c converts a matrix that is stored in coordinate format c a, ir, jc into a row general sparse ao, jao, iao format. c c on entry: c--------- c nrow = dimension of the matrix c nnz = number of nonzero elements in matrix c a, c ir, c jc = matrix in coordinate format. a(k), ir(k), jc(k) store the nnz c nonzero elements of the matrix with a(k) = actual real value of c the elements, ir(k) = its row number and jc(k) = its column c number. The order of the elements is arbitrary. c c on return: c----------- c ir is destroyed c c ao, jao, iao = matrix in general sparse matrix format with ao c continung the real values, jao containing the column indices, c and iao being the pointer to the beginning of the row, c in arrays ao, jao. c c Notes: c------ This routine is NOT in place. See coicsr c c------------------------------------------------------------------------ do 1 k=1,nrow+1 iao(k) = 0 1 continue c determine row-lengths. do 2 k=1, nnz iao(ir(k)) = iao(ir(k))+1 2 continue c starting position of each row.. k = 1 do 3 j=1,nrow+1 k0 = iao(j) iao(j) = k k = k+k0 3 continue c go through the structure once more. Fill in output matrix. do 4 k=1, nnz i = ir(k) j = jc(k) x = a(k) iad = iao(i) ao(iad) = x jao(iad) = j iao(i) = iad+1 4 continue c shift back iao do 5 j=nrow,1,-1 iao(j+1) = iao(j) 5 continue iao(1) = 1 return c------------- end of coocsr ------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine coicsr (n,nnz,job,a,ja,ia,iwk) integer ia(nnz),ja(nnz),iwk(n) real*8 a(*) c------------------------------------------------------------------------ c IN-PLACE coo-csr conversion routine. c------------------------------------------------------------------------ c this subroutine converts a matrix stored in coordinate format into c the csr format. The conversion is done in place in that the arrays c a,ja,ia of the result are overwritten onto the original arrays. c------------------------------------------------------------------------ c on entry: c--------- c n = integer. row dimension of A. c nnz = integer. number of nonzero elements in A. c job = integer. Job indicator. when job=1, the real values in a are c filled. Otherwise a is not touched and the structure of the c array only (i.e. ja, ia) is obtained. c a = real array of size nnz (number of nonzero elements in A) c containing the nonzero elements c ja = integer array of length nnz containing the column positions c of the corresponding elements in a. c ia = integer array of length nnz containing the row positions c of the corresponding elements in a. c iwk = integer work array of length n+1 c on return: c---------- c a c ja c ia = contains the compressed sparse row data structure for the c resulting matrix. c Note: c------- c the entries of the output matrix are not sorted (the column c indices in each are not in increasing order) use coocsr c if you want them sorted. c----------------------------------------------------------------------c c Coded by Y. Saad, Sep. 26 1989 c c----------------------------------------------------------------------c real*8 t,tnext logical values c----------------------------------------------------------------------- values = (job .eq. 1) c find pointer array for resulting matrix. do 35 i=1,n+1 iwk(i) = 0 35 continue do 4 k=1,nnz i = ia(k) iwk(i+1) = iwk(i+1)+1 4 continue c------------------------------------------------------------------------ iwk(1) = 1 do 44 i=2,n iwk(i) = iwk(i-1) + iwk(i) 44 continue c c loop for a cycle in chasing process. c init = 1 k = 0 5 if (values) t = a(init) i = ia(init) j = ja(init) ia(init) = -1 c------------------------------------------------------------------------ 6 k = k+1 c current row number is i. determine where to go. ipos = iwk(i) c save the chased element. if (values) tnext = a(ipos) inext = ia(ipos) jnext = ja(ipos) c then occupy its location. if (values) a(ipos) = t ja(ipos) = j c update pointer information for next element to come in row i. iwk(i) = ipos+1 c determine next element to be chased, if (ia(ipos) .lt. 0) goto 65 t = tnext i = inext j = jnext ia(ipos) = -1 if (k .lt. nnz) goto 6 goto 70 65 init = init+1 if (init .gt. nnz) goto 70 if (ia(init) .lt. 0) goto 65 c restart chasing -- goto 5 70 do 80 i=1,n ia(i+1) = iwk(i) 80 continue ia(1) = 1 return c----------------- end of coicsr ---------------------------------------- c------------------------------------------------------------------------ end c----------------------------------------------------------------------- subroutine csrcoo (nrow,job,nzmax,a,ja,ia,nnz,ao,ir,jc,ierr) c----------------------------------------------------------------------- real*8 a(*),ao(*) integer ir(*),jc(*),ja(*),ia(nrow+1) c----------------------------------------------------------------------- c Compressed Sparse Row to Coordinate c----------------------------------------------------------------------- c converts a matrix that is stored in coordinate format c a, ir, jc into a row general sparse ao, jao, iao format. c c on entry: c--------- c nrow = dimension of the matrix. c job = integer serving as a job indicator. c if job = 1 fill in only the array ir, ignore jc, and ao. c if job = 2 fill in ir, and jc but not ao c if job = 3 fill in everything. c The reason why these options are provided is that on return c ao and jc are the same as a, ja. So when job = 3, a and ja are c simply copied into ao, jc. When job=2, only jc and ir are c returned. With job=1 only the array ir is returned. Moreover, c the algorithm is in place: c call csrcoo (nrow,1,nzmax,a,ja,ia,nnz,a,ia,ja,ierr) c will write the output matrix in coordinate format on a, ja,ia. c c a, c ja, c ia = matrix in compressed sparse row format. c nzmax = length of space available in ao, ir, jc. c the code will stop immediatly if the number of c nonzero elements found in input matrix exceeds nzmax. c c on return: c----------- c ao, ir, jc = matrix in coordinate format. c c nnz = number of nonzero elements in matrix. c ierr = integer error indicator. c ierr .eq. 0 means normal retur c ierr .eq. 1 means that the the code stopped c because there was no space in ao, ir, jc c (according to the value of nzmax). c c NOTES: 1)This routine is PARTIALLY in place: csrcoo can be called with c ao being the same array as as a, and jc the same array as ja. c but ir CANNOT be the same as ia. c 2) note the order in the output arrays, c------------------------------------------------------------------------ ierr = 0 nnz = ia(nrow+1)-1 if (nnz .gt. nzmax) then ierr = 1 return endif c------------------------------------------------------------------------ goto (3,2,1) job 1 do 10 k=1,nnz ao(k) = a(k) 10 continue 2 do 11 k=1,nnz jc(k) = ja(k) 11 continue c c copy backward to allow for in-place processing. c 3 do 13 i=nrow,1,-1 k1 = ia(i+1)-1 k2 = ia(i) do 12 k=k1,k2,-1 ir(k) = i 12 continue 13 continue return c------------- end-of-csrcoo ------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine csrssr (nrow,a,ja,ia,nzmax,ao,jao,iao,ierr) real*8 a(*), ao(*), t integer ia(*), ja(*), iao(*), jao(*) c----------------------------------------------------------------------- c Compressed Sparse Row to Symmetric Sparse Row c----------------------------------------------------------------------- c this subroutine extracts the lower triangular part of a matrix. c It can used as a means for converting a symmetric matrix for c which all the entries are stored in sparse format into one c in which only the lower part is stored. The routine is in place in c that the output matrix ao, jao, iao can be overwritten on c the input matrix a, ja, ia if desired. Csrssr has been coded to c put the diagonal elements of the matrix in the last position in c each row (i.e. in position ao(ia(i+1)-1 of ao and jao) c----------------------------------------------------------------------- c On entry c----------- c nrow = dimension of the matrix a. c a, ja, c ia = matrix stored in compressed row sparse format c c nzmax = length of arrays ao, and jao. c c On return: c----------- c ao, jao, c iao = lower part of input matrix (a,ja,ia) stored in compressed sparse c row format format. c c ierr = integer error indicator. c ierr .eq. 0 means normal return c ierr .eq. i means that the code has stopped when processing c row number i, because there is not enough space in ao, jao c (according to the value of nzmax) c c----------------------------------------------------------------------- ierr = 0 ko = 0 c----------------------------------------------------------------------- do 7 i=1, nrow kold = ko kdiag = 0 do 71 k = ia(i), ia(i+1) -1 if (ja(k) .gt. i) goto 71 ko = ko+1 if (ko .gt. nzmax) then ierr = i return endif ao(ko) = a(k) jao(ko) = ja(k) if (ja(k) .eq. i) kdiag = ko 71 continue if (kdiag .eq. 0 .or. kdiag .eq. ko) goto 72 c c exchange c t = ao(kdiag) ao(kdiag) = ao(ko) ao(ko) = t c k = jao(kdiag) jao(kdiag) = jao(ko) jao(ko) = k 72 iao(i) = kold+1 7 continue c redefine iao(n+1) iao(nrow+1) = ko+1 return c--------- end of csrssr ----------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine ssrcsr(job, value2, nrow, a, ja, ia, nzmax, & ao, jao, iao, indu, iwk, ierr) c .. Scalar Arguments .. integer ierr, job, nrow, nzmax, value2 c .. c .. Array Arguments .. integer ia(nrow+1), iao(nrow+1), indu(nrow), & iwk(nrow+1), ja(*), jao(nzmax) real*8 a(*), ao(nzmax) c .. c----------------------------------------------------------------------- c Symmetric Sparse Row to Compressed Sparse Row format c----------------------------------------------------------------------- c This subroutine converts a given matrix in SSR format to regular c CSR format by computing Ao = A + A' - diag(A), where A' is A c transpose. c c Typically this routine is used to expand the SSR matrix of c Harwell Boeing matrices, or to obtain a symmetrized graph of c unsymmetric matrices. c c This routine is inplace, i.e., (Ao,jao,iao) may be same as c (a,ja,ia). c c It is possible to input an arbitrary CSR matrix to this routine, c since there is no syntactical difference between CSR and SSR c format. It also removes duplicate entries and perform a partial c ordering. The output matrix has an order of lower half, main c diagonal and upper half after the partial ordering. c----------------------------------------------------------------------- c on entry: c--------- c c job = options c 0 -- duplicate entries are not removed. If the input matrix is c SSR (not an arbitary CSR) matrix, no duplicate entry should c arise from this routine. c 1 -- eliminate duplicate entries, zero entries. c 2 -- eliminate duplicate entries and perform partial ordering. c 3 -- eliminate duplicate entries, sort the entries in the c increasing order of clumn indices. c c value2= will the values of A be copied? c 0 -- only expand the graph (a, ao are not touched) c 1 -- expand the matrix with the values. c c nrow = column dimension of inout matrix c a, c ia, c ja = matrix in compressed sparse row format. c c nzmax = size of arrays ao and jao. SSRCSR will abort if the storage c provided in ao, jao is not sufficient to store A. See ierr. c c on return: c---------- c ao, jao, iao c = output matrix in compressed sparse row format. The resulting c matrix is symmetric and is equal to A+A'-D. ao, jao, iao, c can be the same as a, ja, ia in the calling sequence. c c indu = integer array of length nrow. INDU will contain pointers c to the beginning of upper traigular part if job > 1. c Otherwise it is also used as a work array (size nrow). c c iwk = integer work space (size nrow+1). c c ierr = integer. Serving as error message. If the length of the arrays c ao, jao exceeds nzmax, ierr returns the minimum value c needed for nzmax. otherwise ierr=0 (normal return). c c----------------------------------------------------------------------- c .. Local Scalars .. integer i, ipos, j, k, kfirst, klast, ko, kosav, nnz real*8 tmp c .. c .. Executable Statements .. ierr = 0 do 10 i = 1, nrow indu(i) = 0 iwk(i) = 0 10 continue iwk(nrow+1) = 0 c c .. compute number of elements in each row of (A'-D) c put result in iwk(i+1) for row i. c do 30 i = 1, nrow do 20 k = ia(i), ia(i+1) - 1 j = ja(k) if (j.ne.i) & iwk(j+1) = iwk(j+1) + 1 20 continue 30 continue c c .. find addresses of first elements of ouput matrix. result in iwk c iwk(1) = 1 do 40 i = 1, nrow indu(i) = iwk(i) + ia(i+1) - ia(i) iwk(i+1) = iwk(i+1) + indu(i) indu(i) = indu(i) - 1 40 continue c.....Have we been given enough storage in ao, jao ? nnz = iwk(nrow+1) - 1 if (nnz.gt.nzmax) then ierr = nnz return endif c c .. copy the existing matrix (backwards). c kosav = iwk(nrow+1) do 60 i = nrow, 1, -1 klast = ia(i+1) - 1 kfirst = ia(i) iao(i+1) = kosav kosav = iwk(i) ko = iwk(i) - kfirst iwk(i) = ko + klast + 1 do 50 k = klast, kfirst, -1 if (value2.ne.0) & ao(k+ko) = a(k) jao(k+ko) = ja(k) 50 continue 60 continue iao(1) = 1 c c now copy (A'-D). Go through the structure of ao, jao, iao c that has already been copied. iwk(i) is the address c of the next free location in row i for ao, jao. c do 80 i = 1, nrow do 70 k = iao(i), indu(i) j = jao(k) if (j.ne.i) then ipos = iwk(j) if (value2.ne.0) & ao(ipos) = ao(k) jao(ipos) = i iwk(j) = ipos + 1 endif 70 continue 80 continue if (job.le.0) return c c .. eliminate duplicate entries -- c array INDU is used as marker for existing indices, it is also the c location of the entry. c IWK is used to stored the old IAO array. c matrix is copied to squeeze out the space taken by the duplicated c entries. c do 90 i = 1, nrow indu(i) = 0 iwk(i) = iao(i) 90 continue iwk(nrow+1) = iao(nrow+1) k = 1 do 120 i = 1, nrow iao(i) = k ipos = iwk(i) klast = iwk(i+1) 100 if (ipos.lt.klast) then j = jao(ipos) if (indu(j).eq.0) then c .. new entry .. if (value2.ne.0) then if (ao(ipos) .ne. 0.0D0) then indu(j) = k jao(k) = jao(ipos) ao(k) = ao(ipos) k = k + 1 endif else indu(j) = k jao(k) = jao(ipos) k = k + 1 endif else if (value2.ne.0) then c .. duplicate entry .. ao(indu(j)) = ao(indu(j)) + ao(ipos) endif ipos = ipos + 1 go to 100 endif c .. remove marks before working on the next row .. do 110 ipos = iao(i), k - 1 indu(jao(ipos)) = 0 110 continue 120 continue iao(nrow+1) = k if (job.le.1) return c c .. partial ordering .. c split the matrix into strict upper/lower triangular c parts, INDU points to the the beginning of the strict upper part. c do 140 i = 1, nrow klast = iao(i+1) - 1 kfirst = iao(i) 130 if (klast.gt.kfirst) then if (jao(klast).lt.i .and. jao(kfirst).ge.i) then c .. swap klast with kfirst .. j = jao(klast) jao(klast) = jao(kfirst) jao(kfirst) = j if (value2.ne.0) then tmp = ao(klast) ao(klast) = ao(kfirst) ao(kfirst) = tmp endif endif if (jao(klast).ge.i) & klast = klast - 1 if (jao(kfirst).lt.i) & kfirst = kfirst + 1 go to 130 endif c if (jao(klast).lt.i) then indu(i) = klast + 1 else indu(i) = klast endif 140 continue if (job.le.2) return c c .. order the entries according to column indices c bubble-sort is used c do 190 i = 1, nrow do 160 ipos = iao(i), indu(i)-1 do 150 j = indu(i)-1, ipos+1, -1 k = j - 1 if (jao(k).gt.jao(j)) then ko = jao(k) jao(k) = jao(j) jao(j) = ko if (value2.ne.0) then tmp = ao(k) ao(k) = ao(j) ao(j) = tmp endif endif 150 continue 160 continue do 180 ipos = indu(i), iao(i+1)-1 do 170 j = iao(i+1)-1, ipos+1, -1 k = j - 1 if (jao(k).gt.jao(j)) then ko = jao(k) jao(k) = jao(j) jao(j) = ko if (value2.ne.0) then tmp = ao(k) ao(k) = ao(j) ao(j) = tmp endif endif 170 continue 180 continue 190 continue c return c---- end of ssrcsr ---------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine xssrcsr (nrow,a,ja,ia,nzmax,ao,jao,iao,indu,ierr) integer ia(nrow+1),iao(nrow+1),ja(*),jao(nzmax),indu(nrow+1) real*8 a(*),ao(nzmax) c----------------------------------------------------------------------- c Symmetric Sparse Row to (regular) Compressed Sparse Row c----------------------------------------------------------------------- c this subroutine converts a symmetric matrix in which only the lower c part is stored in compressed sparse row format, i.e., c a matrix stored in symmetric sparse format, into a fully stored matrix c i.e., a matrix where both the lower and upper parts are stored in c compressed sparse row format. the algorithm is in place (i.e. result c may be overwritten onto the input matrix a, ja, ia ----- ). c the output matrix delivered by ssrcsr is such that each row starts with c the elements of the lower part followed by those of the upper part. c----------------------------------------------------------------------- c on entry: c--------- c c nrow = row dimension of inout matrix c a, c ia, c ja = matrix in compressed sparse row format. This is assumed to be c a lower triangular matrix. c c nzmax = size of arrays ao and jao. ssrcsr will abort if the storage c provided in a, ja is not sufficient to store A. See ierr. c c on return: c---------- c ao, iao, c jao = output matrix in compressed sparse row format. The resulting c matrix is symmetric and is equal to A+A**T - D, if c A is the original lower triangular matrix. ao, jao, iao, c can be the same as a, ja, ia in the calling sequence. c c indu = integer array of length nrow+1. If the input matrix is such c that the last element in each row is its diagonal element then c on return, indu will contain the pointers to the diagonal c element in each row of the output matrix. Otherwise used as c work array. c ierr = integer. Serving as error message. If the length of the arrays c ao, jao exceeds nzmax, ierr returns the minimum value c needed for nzmax. otherwise ierr=0 (normal return). c c----------------------------------------------------------------------- ierr = 0 do 1 i=1,nrow+1 indu(i) = 0 1 continue c c compute number of elements in each row of strict upper part. c put result in indu(i+1) for row i. c do 3 i=1, nrow do 2 k=ia(i),ia(i+1)-1 j = ja(k) if (j .lt. i) indu(j+1) = indu(j+1)+1 2 continue 3 continue c----------- c find addresses of first elements of ouput matrix. result in indu c----------- indu(1) = 1 do 4 i=1,nrow lenrow = ia(i+1)-ia(i) indu(i+1) = indu(i) + indu(i+1) + lenrow 4 continue c--------------------- enough storage in a, ja ? -------- nnz = indu(nrow+1)-1 if (nnz .gt. nzmax) then ierr = nnz return endif c c now copy lower part (backwards). c kosav = indu(nrow+1) do 6 i=nrow,1,-1 klast = ia(i+1)-1 kfirst = ia(i) iao(i+1) = kosav ko = indu(i) kosav = ko do 5 k = kfirst, klast ao(ko) = a(k) jao(ko) = ja(k) ko = ko+1 5 continue indu(i) = ko 6 continue iao(1) = 1 c c now copy upper part. Go through the structure of ao, jao, iao c that has already been copied (lower part). indu(i) is the address c of the next free location in row i for ao, jao. c do 8 i=1,nrow c i-th row is now in ao, jao, iao structure -- lower half part do 9 k=iao(i), iao(i+1)-1 j = jao(k) if (j .ge. i) goto 8 ipos = indu(j) ao(ipos) = ao(k) jao(ipos) = i indu(j) = indu(j) + 1 9 continue 8 continue return c----- end of xssrcsr -------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine csrell (nrow,a,ja,ia,maxcol,coef,jcoef,ncoef, * ndiag,ierr) integer ia(nrow+1), ja(*), jcoef(ncoef,1) real*8 a(*), coef(ncoef,1) c----------------------------------------------------------------------- c Compressed Sparse Row to Ellpack - Itpack format c----------------------------------------------------------------------- c this subroutine converts matrix stored in the general a, ja, ia c format into the coef, jcoef itpack format. c c----------------------------------------------------------------------- c on entry: c---------- c nrow = row dimension of the matrix A. c c a, c ia, c ja = input matrix in compressed sparse row format. c c ncoef = first dimension of arrays coef, and jcoef. c c maxcol = integer equal to the number of columns available in coef. c c on return: c---------- c coef = real array containing the values of the matrix A in c itpack-ellpack format. c jcoef = integer array containing the column indices of coef(i,j) c in A. c ndiag = number of active 'diagonals' found. c c ierr = error message. 0 = correct return. If ierr .ne. 0 on c return this means that the number of diagonals found c (ndiag) exceeds maxcol. c c----------------------------------------------------------------------- c first determine the length of each row of lower-part-of(A) ierr = 0 ndiag = 0 do 3 i=1, nrow k = ia(i+1)-ia(i) ndiag = max0(ndiag,k) 3 continue c----- check whether sufficient columns are available. ----------------- if (ndiag .gt. maxcol) then ierr = 1 return endif c c fill coef with zero elements and jcoef with row numbers.------------ c do 4 j=1,ndiag do 41 i=1,nrow coef(i,j) = 0.0d0 jcoef(i,j) = i 41 continue 4 continue c c------- copy elements row by row.-------------------------------------- c do 6 i=1, nrow k1 = ia(i) k2 = ia(i+1)-1 do 5 k=k1,k2 coef(i,k-k1+1) = a(k) jcoef(i,k-k1+1) = ja(k) 5 continue 6 continue return c--- end of csrell------------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine ellcsr(nrow,coef,jcoef,ncoef,ndiag,a,ja,ia,nzmax,ierr) integer ia(nrow+1), ja(*), jcoef(ncoef,1) real*8 a(*), coef(ncoef,1) c----------------------------------------------------------------------- c Ellpack - Itpack format to Compressed Sparse Row c----------------------------------------------------------------------- c this subroutine converts a matrix stored in ellpack-itpack format c coef-jcoef into the compressed sparse row format. It actually checks c whether an entry in the input matrix is a nonzero element before c putting it in the output matrix. The test does not account for small c values but only for exact zeros. c----------------------------------------------------------------------- c on entry: c---------- c c nrow = row dimension of the matrix A. c coef = array containing the values of the matrix A in ellpack format. c jcoef = integer arraycontains the column indices of coef(i,j) in A. c ncoef = first dimension of arrays coef, and jcoef. c ndiag = number of active columns in coef, jcoef. c c ndiag = on entry the number of columns made available in coef. c c on return: c---------- c a, ia, c ja = matrix in a, ia, ja format where. c c nzmax = size of arrays a and ja. ellcsr will abort if the storage c provided in a, ja is not sufficient to store A. See ierr. c c ierr = integer. serves are output error message. c ierr = 0 means normal return. c ierr = 1 means that there is not enough space in c a and ja to store output matrix. c----------------------------------------------------------------------- c first determine the length of each row of lower-part-of(A) ierr = 0 c-----check whether sufficient columns are available. ----------------- c c------- copy elements row by row.-------------------------------------- kpos = 1 ia(1) = kpos do 6 i=1, nrow do 5 k=1,ndiag if (coef(i,k) .ne. 0.0d0) then if (kpos .gt. nzmax) then ierr = kpos return endif a(kpos) = coef(i,k) ja(kpos) = jcoef(i,k) kpos = kpos+1 endif 5 continue ia(i+1) = kpos 6 continue return c--- end of ellcsr ----------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine csrmsr (n,a,ja,ia,ao,jao,wk,iwk) real*8 a(*),ao(*),wk(n) integer ia(n+1),ja(*),jao(*),iwk(n+1) c----------------------------------------------------------------------- c Compressed Sparse Row to Modified - Sparse Row c Sparse row with separate main diagonal c----------------------------------------------------------------------- c converts a general sparse matrix a, ja, ia into c a compressed matrix using a separated diagonal (referred to as c the bell-labs format as it is used by bell labs semi conductor c group. We refer to it here as the modified sparse row format. c Note: this has been coded in such a way that one can overwrite c the output matrix onto the input matrix if desired by a call of c the form c c call csrmsr (n, a, ja, ia, a, ja, wk,iwk) c c In case ao, jao, are different from a, ja, then one can c use ao, jao as the work arrays in the calling sequence: c c call csrmsr (n, a, ja, ia, ao, jao, ao,jao) c c----------------------------------------------------------------------- c c on entry : c--------- c a, ja, ia = matrix in csr format. note that the c algorithm is in place: ao, jao can be the same c as a, ja, in which case it will be overwritten on it c upon return. c c on return : c----------- c c ao, jao = sparse matrix in modified sparse row storage format: c + ao(1:n) contains the diagonal of the matrix. c + ao(n+2:nnz) contains the nondiagonal elements of the c matrix, stored rowwise. c + jao(n+2:nnz) : their column indices c + jao(1:n+1) contains the pointer array for the nondiagonal c elements in ao(n+1:nnz) and jao(n+2:nnz). c i.e., for i .le. n+1 jao(i) points to beginning of row i c in arrays ao, jao. c here nnz = number of nonzero elements+1 c work arrays: c------------ c wk = real work array of length n c iwk = integer work array of length n+1 c c notes: c------- c Algorithm is in place. i.e. both: c c call csrmsr (n, a, ja, ia, ao, jao, ao,jao) c (in which ao, jao, are different from a, ja) c and c call csrmsr (n, a, ja, ia, a, ja, wk,iwk) c (in which wk, jwk, are different from a, ja) c are OK. c-------- c coded by Y. Saad Sep. 1989. Rechecked Feb 27, 1990. c----------------------------------------------------------------------- icount = 0 c c store away diagonal elements and count nonzero diagonal elements. c do 1 i=1,n wk(i) = 0.0d0 iwk(i+1) = ia(i+1)-ia(i) do 2 k=ia(i),ia(i+1)-1 if (ja(k) .eq. i) then wk(i) = a(k) icount = icount + 1 iwk(i+1) = iwk(i+1)-1 endif 2 continue 1 continue c c compute total length c iptr = n + ia(n+1) - icount c c copy backwards (to avoid collisions) c do 500 ii=n,1,-1 do 100 k=ia(ii+1)-1,ia(ii),-1 j = ja(k) if (j .ne. ii) then ao(iptr) = a(k) jao(iptr) = j iptr = iptr-1 endif 100 continue 500 continue c c compute pointer values and copy wk(*) c jao(1) = n+2 do 600 i=1,n ao(i) = wk(i) jao(i+1) = jao(i)+iwk(i+1) 600 continue return c------------ end of subroutine csrmsr --------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine msrcsr (n,a,ja,ao,jao,iao,wk,iwk) real*8 a(*),ao(*),wk(n) integer ja(*),jao(*),iao(n+1),iwk(n+1) c----------------------------------------------------------------------- c Modified - Sparse Row to Compressed Sparse Row c c----------------------------------------------------------------------- c converts a compressed matrix using a separated diagonal c (modified sparse row format) in the Compressed Sparse Row c format. c does not check for zero elements in the diagonal. c c c on entry : c--------- c n = row dimension of matrix c a, ja = sparse matrix in msr sparse storage format c see routine csrmsr for details on data structure c c on return : c----------- c c ao,jao,iao = output matrix in csr format. c c work arrays: c------------ c wk = real work array of length n c iwk = integer work array of length n+1 c c notes: c The original version of this was NOT in place, but has c been modified by adding the vector iwk to be in place. c The original version had ja instead of iwk everywhere in c loop 500. Modified Sun 29 May 1994 by R. Bramley (Indiana). c c----------------------------------------------------------------------- logical added do 1 i=1,n wk(i) = a(i) iwk(i) = ja(i) 1 continue iwk(n+1) = ja(n+1) iao(1) = 1 iptr = 1 c--------- do 500 ii=1,n added = .false. idiag = iptr + (iwk(ii+1)-iwk(ii)) do 100 k=iwk(ii),iwk(ii+1)-1 j = ja(k) if (j .lt. ii) then ao(iptr) = a(k) jao(iptr) = j iptr = iptr+1 elseif (added) then ao(iptr) = a(k) jao(iptr) = j iptr = iptr+1 else c add diag element - only reserve a position for it. idiag = iptr iptr = iptr+1 added = .true. c then other element ao(iptr) = a(k) jao(iptr) = j iptr = iptr+1 endif 100 continue ao(idiag) = wk(ii) jao(idiag) = ii if (.not. added) iptr = iptr+1 iao(ii+1) = iptr 500 continue return c------------ end of subroutine msrcsr --------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine csrcsc (n,job,ipos,a,ja,ia,ao,jao,iao) integer ia(n+1),iao(n+1),ja(*),jao(*) real*8 a(*),ao(*) c----------------------------------------------------------------------- c Compressed Sparse Row to Compressed Sparse Column c c (transposition operation) Not in place. c----------------------------------------------------------------------- c -- not in place -- c this subroutine transposes a matrix stored in a, ja, ia format. c --------------- c on entry: c---------- c n = dimension of A. c job = integer to indicate whether to fill the values (job.eq.1) of the c matrix ao or only the pattern., i.e.,ia, and ja (job .ne.1) c c ipos = starting position in ao, jao of the transposed matrix. c the iao array takes this into account (thus iao(1) is set to ipos.) c Note: this may be useful if one needs to append the data structure c of the transpose to that of A. In this case use for example c call csrcsc (n,1,ia(n+1),a,ja,ia,a,ja,ia(n+2)) c for any other normal usage, enter ipos=1. c a = real array of length nnz (nnz=number of nonzero elements in input c matrix) containing the nonzero elements. c ja = integer array of length nnz containing the column positions c of the corresponding elements in a. c ia = integer of size n+1. ia(k) contains the position in a, ja of c the beginning of the k-th row. c c on return: c ---------- c output arguments: c ao = real array of size nzz containing the "a" part of the transpose c jao = integer array of size nnz containing the column indices. c iao = integer array of size n+1 containing the "ia" index array of c the transpose. c c----------------------------------------------------------------------- call csrcsc2 (n,n,job,ipos,a,ja,ia,ao,jao,iao) end c----------------------------------------------------------------------- subroutine csrcsc2 (n,n2,job,ipos,a,ja,ia,ao,jao,iao) integer ia(n+1),iao(n2+1),ja(*),jao(*) real*8 a(*),ao(*) c----------------------------------------------------------------------- c Compressed Sparse Row to Compressed Sparse Column c c (transposition operation) Not in place. c----------------------------------------------------------------------- c Rectangular version. n is number of rows of CSR matrix, c n2 (input) is number of columns of CSC matrix. c----------------------------------------------------------------------- c -- not in place -- c this subroutine transposes a matrix stored in a, ja, ia format. c --------------- c on entry: c---------- c n = number of rows of CSR matrix. c n2 = number of columns of CSC matrix. c job = integer to indicate whether to fill the values (job.eq.1) of the c matrix ao or only the pattern., i.e.,ia, and ja (job .ne.1) c c ipos = starting position in ao, jao of the transposed matrix. c the iao array takes this into account (thus iao(1) is set to ipos.) c Note: this may be useful if one needs to append the data structure c of the transpose to that of A. In this case use for example c call csrcsc2 (n,n,1,ia(n+1),a,ja,ia,a,ja,ia(n+2)) c for any other normal usage, enter ipos=1. c a = real array of length nnz (nnz=number of nonzero elements in input c matrix) containing the nonzero elements. c ja = integer array of length nnz containing the column positions c of the corresponding elements in a. c ia = integer of size n+1. ia(k) contains the position in a, ja of c the beginning of the k-th row. c c on return: c ---------- c output arguments: c ao = real array of size nzz containing the "a" part of the transpose c jao = integer array of size nnz containing the column indices. c iao = integer array of size n+1 containing the "ia" index array of c the transpose. c c----------------------------------------------------------------------- c----------------- compute lengths of rows of transp(A) ---------------- do 1 i=1,n2+1 iao(i) = 0 1 continue do 3 i=1, n do 2 k=ia(i), ia(i+1)-1 j = ja(k)+1 iao(j) = iao(j)+1 2 continue 3 continue c---------- compute pointers from lengths ------------------------------ iao(1) = ipos do 4 i=1,n2 iao(i+1) = iao(i) + iao(i+1) 4 continue c--------------- now do the actual copying ----------------------------- do 6 i=1,n do 62 k=ia(i),ia(i+1)-1 j = ja(k) next = iao(j) if (job .eq. 1) ao(next) = a(k) jao(next) = i iao(j) = next+1 62 continue 6 continue c-------------------------- reshift iao and leave ---------------------- do 7 i=n2,1,-1 iao(i+1) = iao(i) 7 continue iao(1) = ipos c--------------- end of csrcsc2 ---------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine csrlnk (n,a,ja,ia,link) real*8 a(*) integer n, ja(*), ia(n+1), link(*) c----------------------------------------------------------------------- c Compressed Sparse Row to Linked storage format. c----------------------------------------------------------------------- c this subroutine translates a matrix stored in compressed sparse c row into one with a linked list storage format. Only the link c array needs to be obtained since the arrays a, ja, and ia may c be unchanged and carry the same meaning for the output matrix. c in other words a, ja, ia, link is the output linked list data c structure with a, ja, unchanged from input, and ia possibly c altered (in case therea re null rows in matrix). Details on c the output array link are given below. c----------------------------------------------------------------------- c Coded by Y. Saad, Feb 21, 1991. c----------------------------------------------------------------------- c c on entry: c---------- c n = integer equal to the dimension of A. c c a = real array of size nna containing the nonzero elements c ja = integer array of size nnz containing the column positions c of the corresponding elements in a. c ia = integer of size n+1 containing the pointers to the beginning c of each row. ia(k) contains the position in a, ja of the c beginning of the k-th row. c c on return: c---------- c a, ja, are not changed. c ia may be changed if there are null rows. c c a = nonzero elements. c ja = column positions. c ia = ia(i) points to the first element of row i in linked structure. c link = integer array of size containing the linked list information. c link(k) points to the next element of the row after element c a(k), ja(k). if link(k) = 0, then there is no next element, c i.e., a(k), jcol(k) is the last element of the current row. c c Thus row number i can be accessed as follows: c next = ia(i) c while(next .ne. 0) do c value = a(next) ! value a(i,j) c jcol = ja(next) ! column index j c next = link(next) ! address of next element in row c endwhile c notes: c ------ ia may be altered on return. c----------------------------------------------------------------------- c local variables integer i, k c c loop through all rows c do 100 i =1, n istart = ia(i) iend = ia(i+1)-1 if (iend .gt. istart) then do 99 k=istart, iend-1 link(k) = k+1 99 continue link(iend) = 0 else ia(i) = 0 endif 100 continue c return c-------------end-of-csrlnk -------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine lnkcsr (n, a, jcol, istart, link, ao, jao, iao) real*8 a(*), ao(*) integer n, jcol(*), istart(n), link(*), jao(*), iao(*) c----------------------------------------------------------------------- c Linked list storage format to Compressed Sparse Row format c----------------------------------------------------------------------- c this subroutine translates a matrix stored in linked list storage c format into the compressed sparse row format. c----------------------------------------------------------------------- c Coded by Y. Saad, Feb 21, 1991. c----------------------------------------------------------------------- c c on entry: c---------- c n = integer equal to the dimension of A. c c a = real array of size nna containing the nonzero elements c jcol = integer array of size nnz containing the column positions c of the corresponding elements in a. c istart= integer array of size n poiting to the beginning of the rows. c istart(i) contains the position of the first element of c row i in data structure. (a, jcol, link). c if a row is empty istart(i) must be zero. c link = integer array of size nnz containing the links in the linked c list data structure. link(k) points to the next element c of the row after element ao(k), jcol(k). if link(k) = 0, c then there is no next element, i.e., ao(k), jcol(k) is c the last element of the current row. c c on return: c----------- c ao, jao, iao = matrix stored in csr format: c c ao = real array containing the values of the nonzero elements of c the matrix stored row-wise. c jao = integer array of size nnz containing the column indices. c iao = integer array of size n+1 containing the pointers array to the c beginning of each row. iao(i) is the address in ao,jao of c first element of row i. c c----------------------------------------------------------------------- c first determine individial bandwidths and pointers. c----------------------------------------------------------------------- c local variables integer irow, ipos, next c----------------------------------------------------------------------- ipos = 1 iao(1) = ipos c c loop through all rows c do 100 irow =1, n c c unroll i-th row. c next = istart(irow) 10 if (next .eq. 0) goto 99 jao(ipos) = jcol(next) ao(ipos) = a(next) ipos = ipos+1 next = link(next) goto 10 99 iao(irow+1) = ipos 100 continue c return c-------------end-of-lnkcsr ------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine csrdia (n,idiag,job,a,ja,ia,ndiag, * diag,ioff,ao,jao,iao,ind) real*8 diag(ndiag,idiag), a(*), ao(*) integer ia(*), ind(*), ja(*), jao(*), iao(*), ioff(*) c----------------------------------------------------------------------- c Compressed sparse row to diagonal format c----------------------------------------------------------------------- c this subroutine extracts idiag diagonals from the input matrix a, c a, ia, and puts the rest of the matrix in the output matrix ao, c jao, iao. The diagonals to be extracted depend on the value of job c (see below for details.) In the first case, the diagonals to be c extracted are simply identified by their offsets provided in ioff c by the caller. In the second case, the code internally determines c the idiag most significant diagonals, i.e., those diagonals of the c matrix which have the largest number of nonzero elements, and c extracts them. c----------------------------------------------------------------------- c on entry: c---------- c n = dimension of the matrix a. c idiag = integer equal to the number of diagonals to be extracted. c Note: on return idiag may be modified. c a, ja, c ia = matrix stored in a, ja, ia, format c job = integer. serves as a job indicator. Job is better thought c of as a two-digit number job=xy. If the first (x) digit c is one on entry then the diagonals to be extracted are c internally determined. In this case csrdia exctracts the c idiag most important diagonals, i.e. those having the largest c number on nonzero elements. If the first digit is zero c then csrdia assumes that ioff(*) contains the offsets c of the diagonals to be extracted. there is no verification c that ioff(*) contains valid entries. c The second (y) digit of job determines whether or not c the remainder of the matrix is to be written on ao,jao,iao. c If it is zero then ao, jao, iao is not filled, i.e., c the diagonals are found and put in array diag and the rest is c is discarded. if it is one, ao, jao, iao contains matrix c of the remaining elements. c Thus: c job= 0 means do not select diagonals internally (pick those c defined by ioff) and do not fill ao,jao,iao c job= 1 means do not select diagonals internally c and fill ao,jao,iao c job=10 means select diagonals internally c and do not fill ao,jao,iao c job=11 means select diagonals internally c and fill ao,jao,iao c c ndiag = integer equal to the first dimension of array diag. c c on return: c----------- c c idiag = number of diagonals found. This may be smaller than its value c on entry. c diag = real array of size (ndiag x idiag) containing the diagonals c of A on return c c ioff = integer array of length idiag, containing the offsets of the c diagonals to be extracted. c ao, jao c iao = remainder of the matrix in a, ja, ia format. c work arrays: c------------ c ind = integer array of length 2*n-1 used as integer work space. c needed only when job.ge.10 i.e., in case the diagonals are to c be selected internally. c c Notes: c------- c 1) The algorithm is in place: ao, jao, iao can be overwritten on c a, ja, ia if desired c 2) When the code is required to select the diagonals (job .ge. 10) c the selection of the diagonals is done from left to right c as a result if several diagonals have the same weight (number c of nonzero elemnts) the leftmost one is selected first. c----------------------------------------------------------------------- job1 = job/10 job2 = job-job1*10 if (job1 .eq. 0) goto 50 n2 = n+n-1 call infdia(n,ja,ia,ind,idum) c----------- determine diagonals to accept.---------------------------- c----------------------------------------------------------------------- ii = 0 4 ii=ii+1 jmax = 0 do 41 k=1, n2 j = ind(k) if (j .le. jmax) goto 41 i = k jmax = j 41 continue if (jmax .le. 0) then ii = ii-1 goto 42 endif ioff(ii) = i-n ind(i) = - jmax if (ii .lt. idiag) goto 4 42 idiag = ii c---------------- initialize diago to zero ----------------------------- 50 continue do 55 j=1,idiag do 54 i=1,n diag(i,j) = 0.0d0 54 continue 55 continue c----------------------------------------------------------------------- ko = 1 c----------------------------------------------------------------------- c extract diagonals and accumulate remaining matrix. c----------------------------------------------------------------------- do 6 i=1, n do 51 k=ia(i),ia(i+1)-1 j = ja(k) do 52 l=1,idiag if (j-i .ne. ioff(l)) goto 52 diag(i,l) = a(k) goto 51 52 continue c--------------- append element not in any diagonal to ao,jao,iao ----- if (job2 .eq. 0) goto 51 ao(ko) = a(k) jao(ko) = j ko = ko+1 51 continue if (job2 .ne. 0 ) ind(i+1) = ko 6 continue if (job2 .eq. 0) return c finish with iao iao(1) = 1 do 7 i=2,n+1 iao(i) = ind(i) 7 continue return c----------- end of csrdia --------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine diacsr (n,job,idiag,diag,ndiag,ioff,a,ja,ia) real*8 diag(ndiag,idiag), a(*), t integer ia(*), ja(*), ioff(*) c----------------------------------------------------------------------- c diagonal format to compressed sparse row c----------------------------------------------------------------------- c this subroutine extract the idiag most important diagonals from the c input matrix a, ja, ia, i.e, those diagonals of the matrix which have c the largest number of nonzero elements. If requested (see job), c the rest of the matrix is put in a the output matrix ao, jao, iao c----------------------------------------------------------------------- c on entry: c---------- c n = integer. dimension of the matrix a. c job = integer. job indicator with the following meaning. c if (job .eq. 0) then check for each entry in diag c whether this entry is zero. If it is then do not include c in the output matrix. Note that the test is a test for c an exact arithmetic zero. Be sure that the zeros are c actual zeros in double precision otherwise this would not c work. c c idiag = integer equal to the number of diagonals to be extracted. c Note: on return idiag may be modified. c c diag = real array of size (ndiag x idiag) containing the diagonals c of A on return. c c ndiag = integer equal to the first dimension of array diag. c c ioff = integer array of length idiag, containing the offsets of the c diagonals to be extracted. c c on return: c----------- c a, c ja, c ia = matrix stored in a, ja, ia, format c c Note: c ----- the arrays a and ja should be of length n*idiag. c c----------------------------------------------------------------------- ia(1) = 1 ko = 1 do 80 i=1, n do 70 jj = 1, idiag j = i+ioff(jj) if (j .lt. 1 .or. j .gt. n) goto 70 t = diag(i,jj) if (job .eq. 0 .and. t .eq. 0.0d0) goto 70 a(ko) = t ja(ko) = j ko = ko+1 70 continue ia(i+1) = ko 80 continue return c----------- end of diacsr --------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine bsrcsr (job, n, m, na, a, ja, ia, ao, jao, iao) implicit none integer job, n, m, na, ia(*), ja(*), jao(*), iao(n+1) real*8 a(na,*), ao(*) c----------------------------------------------------------------------- c Block Sparse Row to Compressed Sparse Row. c----------------------------------------------------------------------- c NOTE: ** meanings of parameters may have changed wrt earlier versions c FORMAT DEFINITION HAS CHANGED WRT TO EARLIER VERSIONS... c----------------------------------------------------------------------- c c converts a matrix stored in block-reduced a, ja, ia format to the c general sparse row a, ja, ia format. A matrix that has a block c structure is a matrix whose entries are blocks of the same size m c (e.g. 3 x 3). Then it is often preferred to work with the reduced c graph of the matrix. Instead of storing one element at a time one can c store a whole block at a time. In this storage scheme an entry is a c square array holding the m**2 elements of a block. c c----------------------------------------------------------------------- c on entry: c---------- c job = if job.eq.0 on entry, values are not copied (pattern only) c c n = the block row dimension of the matrix. c c m = the dimension of each block. Thus, the actual row dimension c of A is n x m. c c na = first dimension of array a as declared in calling program. c This should be .ge. m**2. c c a = real array containing the real entries of the matrix. Recall c that each entry is in fact an m x m block. These entries c are stored column-wise in locations a(1:m*m,k) for each k-th c entry. See details below. c c ja = integer array of length n. ja(k) contains the column index c of the leading element, i.e., the element (1,1) of the block c that is held in the column a(*,k) of the value array. c c ia = integer array of length n+1. ia(i) points to the beginning c of block row number i in the arrays a and ja. c c on return: c----------- c ao, jao, c iao = matrix stored in compressed sparse row format. The number of c rows in the new matrix is n x m. c c Notes: THIS CODE IS NOT IN PLACE. c c----------------------------------------------------------------------- c BSR FORMAT. c---------- c Each row of A contains the m x m block matrix unpacked column- c wise (this allows the user to declare the array a as a(m,m,*) on entry c if desired). The block rows are stored in sequence just as for the c compressed sparse row format. c c----------------------------------------------------------------------- c example with m = 2: c 1 2 3 c +-------|--------|--------+ +-------+ c | 1 2 | 0 0 | 3 4 | Block | x 0 x | 1 c | 5 6 | 0 0 | 7 8 | Representation: | 0 x x | 2 c +-------+--------+--------+ | x 0 0 | 3 c | 0 0 | 9 10 | 11 12 | +-------+ c | 0 0 | 13 14 | 15 16 | c +-------+--------+--------+ c | 17 18 | 0 0 | 0 0 | c | 22 23 | 0 0 | 0 0 | c +-------+--------+--------+ c c For this matrix: n = 3 c m = 2 c nnz = 5 c----------------------------------------------------------------------- c Data structure in Block Sparse Row format: c------------------------------------------- c Array A: c------------------------- c 1 3 9 11 17 <<--each m x m block is stored column-wise c 5 7 13 15 22 in a column of the array A. c 2 4 10 12 18 c 6 8 14 16 23 c------------------------- c JA 1 3 2 3 1 <<-- column indices for each block. Note that c------------------------- these indices are wrt block matrix. c IA 1 3 5 6 <<-- pointers to beginning of each block row c------------------------- in arrays A and JA. c----------------------------------------------------------------------- c locals c integer i, i1, i2, ij, ii, irow, j, jstart, k, krow, no logical val c val = (job.ne.0) no = n * m irow = 1 krow = 1 iao(irow) = 1 c----------------------------------------------------------------------- do 2 ii=1, n c c recall: n is the block-row dimension c i1 = ia(ii) i2 = ia(ii+1)-1 c c create m rows for each block row -- i.e., each k. c do 23 i=1,m do 21 k=i1, i2 jstart = m*(ja(k)-1) do 22 j=1,m ij = (j-1)*m + i if (val) ao(krow) = a(ij,k) jao(krow) = jstart+j krow = krow+1 22 continue 21 continue irow = irow+1 iao(irow) = krow 23 continue 2 continue return c-------------end-of-bsrcsr -------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine csrbsr (job,nrow,m,na,a,ja,ia,ao,jao,iao,iw,ierr) implicit none integer job,ierr,nrow,m,na,ia(nrow+1),ja(*),jao(na),iao(*),iw(*) real*8 a(*),ao(na,*) c----------------------------------------------------------------------- c Compressed Sparse Row to Block Sparse Row c----------------------------------------------------------------------- c c This subroutine converts a matrix stored in a general compressed a, c ja, ia format into a a block sparse row format a(m,m,*),ja(*),ia(*). c See routine bsrcsr for more details on data structure for block c matrices. c c NOTES: 1) the initial matrix does not have to have a block structure. c zero padding is done for general sparse matrices. c 2) For most practical purposes, na should be the same as m*m. c c----------------------------------------------------------------------- c c In what follows nr=1+(nrow-1)/m = block-row dimension of output matrix c c on entry: c---------- c c job = job indicator. c job = 0 -> only the pattern of output matrix is generated c job > 0 -> both pattern and values are generated. c job = -1 -> iao(1) will return the number of nonzero blocks, c in the output matrix. In this case jao(1:nr) is used as c workspace, ao is untouched, iao is untouched except iao(1) c c nrow = integer, the actual row dimension of the matrix. c c m = integer equal to the dimension of each block. m should be > 0. c c na = first dimension of array ao as declared in calling program. c na should be .ge. m*m. c c a, ja, c ia = input matrix stored in compressed sparse row format. c c on return: c----------- c c ao = real array containing the values of the matrix. For details c on the format see below. Each row of a contains the m x m c block matrix unpacked column-wise (this allows the user to c declare the array a as ao(m,m,*) on entry if desired). The c block rows are stored in sequence just as for the compressed c sparse row format. The block dimension of the output matrix c is nr = 1 + (nrow-1) / m. c c jao = integer array. containing the block-column indices of the c block-matrix. Each jao(k) is an integer between 1 and nr c containing the block column index of the block ao(*,k). c c iao = integer array of length nr+1. iao(i) points to the beginning c of block row number i in the arrays ao and jao. When job=-1 c iao(1) contains the number of nonzero blocks of the output c matrix and the rest of iao is unused. This is useful for c determining the lengths of ao and jao. c c ierr = integer, error code. c 0 -- normal termination c 1 -- m is equal to zero c 2 -- NA too small to hold the blocks (should be .ge. m**2) c c Work arrays: c------------- c iw = integer work array of dimension nr = 1 + (nrow-1) / m c c NOTES: c------- c 1) this code is not in place. c 2) see routine bsrcsr for details on data sctructure for block c sparse row format. c c----------------------------------------------------------------------- c nr is the block-dimension of the output matrix. c integer nr, m2, io, ko, ii, len, k, jpos, j, i, ij, jr, irow logical vals c----- ierr = 0 if (m*m .gt. na) ierr = 2 if (m .eq. 0) ierr = 1 if (ierr .ne. 0) return c----------------------------------------------------------------------- vals = (job .gt. 0) nr = 1 + (nrow-1) / m m2 = m*m ko = 1 io = 1 iao(io) = 1 len = 0 c c iw determines structure of block-row (nonzero indicator) c do j=1, nr iw(j) = 0 enddo c c big loop -- leap by m rows each time. c do ii=1, nrow, m irow = 0 c c go through next m rows -- make sure not to go beyond nrow. c do while (ii+irow .le. nrow .and. irow .le. m-1) do k=ia(ii+irow),ia(ii+irow+1)-1 c c block column index = (scalar column index -1) / m + 1 c j = ja(k)-1 jr = j/m + 1 j = j - (jr-1)*m jpos = iw(jr) if (jpos .eq. 0) then c c create a new block c iw(jr) = ko jao(ko) = jr if (vals) then c c initialize new block to zero -- then copy nonzero element c do i=1, m2 ao(i,ko) = 0.0d0 enddo ij = j*m + irow + 1 ao(ij,ko) = a(k) endif ko = ko+1 else c c copy column index and nonzero element c jao(jpos) = jr ij = j*m + irow + 1 if (vals) ao(ij,jpos) = a(k) endif enddo irow = irow+1 enddo c c refresh iw c do j = iao(io),ko-1 iw(jao(j)) = 0 enddo if (job .eq. -1) then len = len + ko-1 ko = 1 else io = io+1 iao(io) = ko endif enddo if (job .eq. -1) iao(1) = len c return c--------------end-of-csrbsr-------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine csrbnd (n,a,ja,ia,job,abd,nabd,lowd,ml,mu,ierr) real*8 a(*),abd(nabd,n) integer ia(n+1),ja(*) c----------------------------------------------------------------------- c Compressed Sparse Row to Banded (Linpack ) format. c----------------------------------------------------------------------- c this subroutine converts a general sparse matrix stored in c compressed sparse row format into the banded format. for the c banded format,the Linpack conventions are assumed (see below). c----------------------------------------------------------------------- c on entry: c---------- c n = integer,the actual row dimension of the matrix. c c a, c ja, c ia = input matrix stored in compressed sparse row format. c c job = integer. if job=1 then the values of the lower bandwith ml c and the upper bandwidth mu are determined internally. c otherwise it is assumed that the values of ml and mu c are the correct bandwidths on input. See ml and mu below. c c nabd = integer. first dimension of array abd. c c lowd = integer. this should be set to the row number in abd where c the lowest diagonal (leftmost) of A is located. c lowd should be ( 1 .le. lowd .le. nabd). c if it is not known in advance what lowd should be c enter lowd = 0 and the default value lowd = ml+mu+1 c will be chosen. Alternative: call routine getbwd from unary c first to detrermione ml and mu then define lowd accordingly. c (Note: the banded solvers in linpack use lowd=2*ml+mu+1. ) c c ml = integer. equal to the bandwidth of the strict lower part of A c mu = integer. equal to the bandwidth of the strict upper part of A c thus the total bandwidth of A is ml+mu+1. c if ml+mu+1 is found to be larger than lowd then an error c flag is raised (unless lowd = 0). see ierr. c c note: ml and mu are assumed to have the correct bandwidth values c as defined above if job is set to zero on entry. c c on return: c----------- c c abd = real array of dimension abd(nabd,n). c on return contains the values of the matrix stored in c banded form. The j-th column of abd contains the elements c of the j-th column of the original matrix comprised in the c band ( i in (j-ml,j+mu) ) with the lowest diagonal at c the bottom row (row lowd). See details below for this format. c c ml = integer. equal to the bandwidth of the strict lower part of A c mu = integer. equal to the bandwidth of the strict upper part of A c if job=1 on entry then these two values are internally computed. c c lowd = integer. row number in abd where the lowest diagonal c (leftmost) of A is located on return. In case lowd = 0 c on return, then it is defined to ml+mu+1 on return and the c lowd will contain this value on return. ` c c ierr = integer. used for error messages. On return: c ierr .eq. 0 :means normal return c ierr .eq. -1 : means invalid value for lowd. (either .lt. 0 c or larger than nabd). c ierr .eq. -2 : means that lowd is not large enough and as c result the matrix cannot be stored in array abd. c lowd should be at least ml+mu+1, where ml and mu are as c provided on output. c c----------------------------------------------------------------------* c Additional details on banded format. (this closely follows the * c format used in linpack. may be useful for converting a matrix into * c this storage format in order to use the linpack banded solvers). * c----------------------------------------------------------------------* c --- band storage format for matrix abd --- * c uses ml+mu+1 rows of abd(nabd,*) to store the diagonals of * c a in rows of abd starting from the lowest (sub)-diagonal which is * c stored in row number lowd of abd. the minimum number of rows needed * c in abd is ml+mu+1, i.e., the minimum value for lowd is ml+mu+1. the * c j-th column of abd contains the elements of the j-th column of a, * c from bottom to top: the element a(j+ml,j) is stored in position * c abd(lowd,j), then a(j+ml-1,j) in position abd(lowd-1,j) and so on. * c Generally, the element a(j+k,j) of original matrix a is stored in * c position abd(lowd+k-ml,j), for k=ml,ml-1,..,0,-1, -mu. * c The first dimension nabd of abd must be .ge. lowd * c * c example [from linpack ]: if the original matrix is * c * c 11 12 13 0 0 0 * c 21 22 23 24 0 0 * c 0 32 33 34 35 0 original banded matrix * c 0 0 43 44 45 46 * c 0 0 0 54 55 56 * c 0 0 0 0 65 66 * c * c then n = 6, ml = 1, mu = 2. lowd should be .ge. 4 (=ml+mu+1) and * c if lowd = 5 for example, abd should be: * c * c untouched --> x x x x x x * c * * 13 24 35 46 * c * 12 23 34 45 56 resulting abd matrix in banded * c 11 22 33 44 55 66 format * c row lowd--> 21 32 43 54 65 * * c * c * = not used * c * c----------------------------------------------------------------------* c first determine ml and mu. c----------------------------------------------------------------------- ierr = 0 c----------- if (job .eq. 1) call getbwd(n,a,ja,ia,ml,mu) m = ml+mu+1 if (lowd .eq. 0) lowd = m if (m .gt. lowd) ierr = -2 if (lowd .gt. nabd .or. lowd .lt. 0) ierr = -1 if (ierr .lt. 0) return c------------ do 15 i=1,m ii = lowd -i+1 do 10 j=1,n abd(ii,j) = 0.0d0 10 continue 15 continue c--------------------------------------------------------------------- mdiag = lowd-ml do 30 i=1,n do 20 k=ia(i),ia(i+1)-1 j = ja(k) abd(i-j+mdiag,j) = a(k) 20 continue 30 continue return c------------- end of csrbnd ------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine bndcsr (n,abd,nabd,lowd,ml,mu,a,ja,ia,len,ierr) real*8 a(*),abd(nabd,*), t integer ia(n+1),ja(*) c----------------------------------------------------------------------- c Banded (Linpack ) format to Compressed Sparse Row format. c----------------------------------------------------------------------- c on entry: c---------- c n = integer,the actual row dimension of the matrix. c c nabd = first dimension of array abd. c c abd = real array containing the values of the matrix stored in c banded form. The j-th column of abd contains the elements c of the j-th column of the original matrix,comprised in the c band ( i in (j-ml,j+mu) ) with the lowest diagonal located c in row lowd (see below). c c lowd = integer. this should be set to the row number in abd where c the lowest diagonal (leftmost) of A is located. c lowd should be s.t. ( 1 .le. lowd .le. nabd). c The subroutines dgbco, ... of linpack use lowd=2*ml+mu+1. c c ml = integer. equal to the bandwidth of the strict lower part of A c mu = integer. equal to the bandwidth of the strict upper part of A c thus the total bandwidth of A is ml+mu+1. c if ml+mu+1 is found to be larger than nabd then an error c message is set. see ierr. c c len = integer. length of arrays a and ja. bndcsr will stop if the c length of the arrays a and ja is insufficient to store the c matrix. see ierr. c c on return: c----------- c a, c ja, c ia = input matrix stored in compressed sparse row format. c c lowd = if on entry lowd was zero then lowd is reset to the default c value ml+mu+l. c c ierr = integer. used for error message output. c ierr .eq. 0 :means normal return c ierr .eq. -1 : means invalid value for lowd. c ierr .gt. 0 : means that there was not enough storage in a and ja c for storing the ourput matrix. The process ran out of space c (as indicated by len) while trying to fill row number ierr. c This should give an idea of much more storage might be required. c Moreover, the first irow-1 rows are correctly filled. c c notes: the values in abd found to be equal to zero c ----- (actual test: if (abd(...) .eq. 0.0d0) are removed. c The resulting may not be identical to a csr matrix c originally transformed to a bnd format. c c----------------------------------------------------------------------- ierr = 0 c----------- if (lowd .gt. nabd .or. lowd .le. 0) then ierr = -1 return endif c----------- ko = 1 ia(1) = 1 do 30 irow=1,n c----------------------------------------------------------------------- i = lowd do 20 j=irow-ml,irow+mu if (j .le. 0 ) goto 19 if (j .gt. n) goto 21 t = abd(i,j) if (t .eq. 0.0d0) goto 19 if (ko .gt. len) then ierr = irow return endif a(ko) = t ja(ko) = j ko = ko+1 19 i = i-1 20 continue c end for row irow 21 ia(irow+1) = ko 30 continue return c------------- end of bndcsr ------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine csrssk (n,imod,a,ja,ia,asky,isky,nzmax,ierr) real*8 a(*),asky(nzmax) integer n, imod, nzmax, ierr, ia(n+1), isky(n+1), ja(*) c----------------------------------------------------------------------- c Compressed Sparse Row to Symmetric Skyline Format c or Symmetric Sparse Row c----------------------------------------------------------------------- c this subroutine translates a compressed sparse row or a symmetric c sparse row format into a symmetric skyline format. c the input matrix can be in either compressed sparse row or the c symmetric sparse row format. The output matrix is in a symmetric c skyline format: a real array containing the (active portions) of the c rows in sequence and a pointer to the beginning of each row. c c This module is NOT in place. c----------------------------------------------------------------------- c Coded by Y. Saad, Oct 5, 1989. Revised Feb. 18, 1991. c----------------------------------------------------------------------- c c on entry: c---------- c n = integer equal to the dimension of A. c imod = integer indicating the variant of skyline format wanted: c imod = 0 means the pointer isky points to the `zeroth' c element of the row, i.e., to the position of the diagonal c element of previous row (for i=1, isky(1)= 0) c imod = 1 means that itpr points to the beginning of the row. c imod = 2 means that isky points to the end of the row (diagonal c element) c c a = real array of size nna containing the nonzero elements c ja = integer array of size nnz containing the column positions c of the corresponding elements in a. c ia = integer of size n+1. ia(k) contains the position in a, ja of c the beginning of the k-th row. c nzmax = integer. must be set to the number of available locations c in the output array asky. c c on return: c---------- c c asky = real array containing the values of the matrix stored in skyline c format. asky contains the sequence of active rows from c i=1, to n, an active row being the row of elemnts of c the matrix contained between the leftmost nonzero element c and the diagonal element. c isky = integer array of size n+1 containing the pointer array to c each row. The meaning of isky depends on the input value of c imod (see above). c ierr = integer. Error message. If the length of the c output array asky exceeds nzmax. ierr returns the minimum value c needed for nzmax. otherwise ierr=0 (normal return). c c Notes: c 1) This module is NOT in place. c 2) even when imod = 2, length of isky is n+1, not n. c c----------------------------------------------------------------------- c first determine individial bandwidths and pointers. c----------------------------------------------------------------------- ierr = 0 isky(1) = 0 do 3 i=1,n ml = 0 do 31 k=ia(i),ia(i+1)-1 ml = max(ml,i-ja(k)+1) 31 continue isky(i+1) = isky(i)+ml 3 continue c c test if there is enough space asky to do the copying. c nnz = isky(n+1) if (nnz .gt. nzmax) then ierr = nnz return endif c c fill asky with zeros. c do 1 k=1, nnz asky(k) = 0.0d0 1 continue c c copy nonzero elements. c do 4 i=1,n kend = isky(i+1) do 41 k=ia(i),ia(i+1)-1 j = ja(k) if (j .le. i) asky(kend+j-i) = a(k) 41 continue 4 continue c c modify pointer according to imod if necessary. c if (imod .eq. 0) return if (imod .eq. 1) then do 50 k=1, n+1 isky(k) = isky(k)+1 50 continue endif if (imod .eq. 2) then do 60 k=1, n isky(k) = isky(k+1) 60 continue endif c return c------------- end of csrssk ------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine sskssr (n,imod,asky,isky,ao,jao,iao,nzmax,ierr) real*8 asky(*),ao(nzmax) integer n, imod,nzmax,ierr, isky(n+1),iao(n+1),jao(nzmax) c----------------------------------------------------------------------- c Symmetric Skyline Format to Symmetric Sparse Row format. c----------------------------------------------------------------------- c tests for exact zeros in skyline matrix (and ignores them in c output matrix). In place routine (a, isky :: ao, iao) c----------------------------------------------------------------------- c this subroutine translates a symmetric skyline format into a c symmetric sparse row format. Each element is tested to see if it is c a zero element. Only the actual nonzero elements are retained. Note c that the test used is simple and does take into account the smallness c of a value. the subroutine filter (see unary module) can be used c for this purpose. c----------------------------------------------------------------------- c Coded by Y. Saad, Oct 5, 1989. Revised Feb 18, 1991./ c----------------------------------------------------------------------- c c on entry: c---------- c n = integer equal to the dimension of A. c imod = integer indicating the variant of skyline format used: c imod = 0 means the pointer iao points to the `zeroth' c element of the row, i.e., to the position of the diagonal c element of previous row (for i=1, iao(1)= 0) c imod = 1 means that itpr points to the beginning of the row. c imod = 2 means that iao points to the end of the row c (diagonal element) c asky = real array containing the values of the matrix. asky contains c the sequence of active rows from i=1, to n, an active row c being the row of elemnts of the matrix contained between the c leftmost nonzero element and the diagonal element. c isky = integer array of size n+1 containing the pointer array to c each row. isky (k) contains the address of the beginning of the c k-th active row in the array asky. c nzmax = integer. equal to the number of available locations in the c output array ao. c c on return: c ---------- c ao = real array of size nna containing the nonzero elements c jao = integer array of size nnz containing the column positions c of the corresponding elements in a. c iao = integer of size n+1. iao(k) contains the position in a, ja of c the beginning of the k-th row. c ierr = integer. Serving as error message. If the length of the c output arrays ao, jao exceeds nzmax then ierr returns c the row number where the algorithm stopped: rows c i, to ierr-1 have been processed succesfully. c ierr = 0 means normal return. c ierr = -1 : illegal value for imod c Notes: c------- c This module is in place: ao and iao can be the same as asky, and isky. c----------------------------------------------------------------------- c local variables integer next, kend, kstart, i, j ierr = 0 c c check for validity of imod c if (imod.ne.0 .and. imod.ne.1 .and. imod .ne. 2) then ierr =-1 return endif c c next = pointer to next available position in output matrix c kend = pointer to end of current row in skyline matrix. c next = 1 c c set kend = start position -1 in skyline matrix. c kend = 0 if (imod .eq. 1) kend = isky(1)-1 if (imod .eq. 0) kend = isky(1) c c loop through all rows c do 50 i=1,n c c save value of pointer to ith row in output matrix c iao(i) = next c c get beginnning and end of skyline row c kstart = kend+1 if (imod .eq. 0) kend = isky(i+1) if (imod .eq. 1) kend = isky(i+1)-1 if (imod .eq. 2) kend = isky(i) c c copy element into output matrix unless it is a zero element. c do 40 k=kstart,kend if (asky(k) .eq. 0.0d0) goto 40 j = i-(kend-k) jao(next) = j ao(next) = asky(k) next=next+1 if (next .gt. nzmax+1) then ierr = i return endif 40 continue 50 continue iao(n+1) = next return c-------------end-of-sskssr -------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine csrjad (nrow, a, ja, ia, idiag, iperm, ao, jao, iao) integer ja(*), jao(*), ia(nrow+1), iperm(nrow), iao(nrow) real*8 a(*), ao(*) c----------------------------------------------------------------------- c Compressed Sparse Row to JAgged Diagonal storage. c----------------------------------------------------------------------- c this subroutine converts matrix stored in the compressed sparse c row format to the jagged diagonal format. The data structure c for the JAD (Jagged Diagonal storage) is as follows. The rows of c the matrix are (implicitly) permuted so that their lengths are in c decreasing order. The real entries ao(*) and their column indices c jao(*) are stored in succession. The number of such diagonals is idiag. c the lengths of each of these diagonals is stored in iao(*). c For more details see [E. Anderson and Y. Saad, c ``Solving sparse triangular systems on parallel computers'' in c Inter. J. of High Speed Computing, Vol 1, pp. 73-96 (1989).] c or [Y. Saad, ``Krylov Subspace Methods on Supercomputers'' c SIAM J. on Stat. Scient. Comput., volume 10, pp. 1200-1232 (1989).] c----------------------------------------------------------------------- c on entry: c---------- c nrow = row dimension of the matrix A. c c a, c ia, c ja = input matrix in compressed sparse row format. c c on return: c---------- c c idiag = integer. The number of jagged diagonals in the matrix. c c iperm = integer array of length nrow containing the permutation c of the rows that leads to a decreasing order of the c number of nonzero elements. c c ao = real array containing the values of the matrix A in c jagged diagonal storage. The j-diagonals are stored c in ao in sequence. c c jao = integer array containing the column indices of the c entries in ao. c c iao = integer array containing pointers to the beginning c of each j-diagonal in ao, jao. iao is also used as c a work array and it should be of length n at least. c c----------------------------------------------------------------------- c ---- define initial iperm and get lengths of each row c ---- jao is used a work vector to store tehse lengths c idiag = 0 ilo = nrow do 10 j=1, nrow iperm(j) = j len = ia(j+1) - ia(j) ilo = min(ilo,len) idiag = max(idiag,len) jao(j) = len 10 continue c c call sorter to get permutation. use iao as work array. c call dcsort (jao, nrow, iao, iperm, ilo, idiag) c c define output data structure. first lengths of j-diagonals c do 20 j=1, nrow iao(j) = 0 20 continue do 40 k=1, nrow len = jao(iperm(k)) do 30 i=1,len iao(i) = iao(i)+1 30 continue 40 continue c c get the output matrix itself c k1 = 1 k0 = k1 do 60 jj=1, idiag len = iao(jj) do 50 k=1,len i = ia(iperm(k))+jj-1 ao(k1) = a(i) jao(k1) = ja(i) k1 = k1+1 50 continue iao(jj) = k0 k0 = k1 60 continue iao(idiag+1) = k1 return c----------end-of-csrjad------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine jadcsr (nrow, idiag, a, ja, ia, iperm, ao, jao, iao) integer ja(*), jao(*), ia(idiag+1), iperm(nrow), iao(nrow+1) real*8 a(*), ao(*) c----------------------------------------------------------------------- c Jagged Diagonal Storage to Compressed Sparse Row c----------------------------------------------------------------------- c this subroutine converts a matrix stored in the jagged diagonal format c to the compressed sparse row format. c----------------------------------------------------------------------- c on entry: c---------- c nrow = integer. the row dimension of the matrix A. c c idiag = integer. The number of jagged diagonals in the data c structure a, ja, ia. c c a, c ja, c ia = input matrix in jagged diagonal format. c c iperm = permutation of the rows used to obtain the JAD ordering. c c on return: c---------- c c ao, jao, c iao = matrix in CSR format. c----------------------------------------------------------------------- c determine first the pointers for output matrix. Go through the c structure once: c do 137 j=1,nrow jao(j) = 0 137 continue c c compute the lengths of each row of output matrix - c do 140 i=1, idiag len = ia(i+1)-ia(i) do 138 k=1,len jao(iperm(k)) = jao(iperm(k))+1 138 continue 140 continue c c remember to permute c kpos = 1 iao(1) = 1 do 141 i=1, nrow kpos = kpos+jao(i) iao(i+1) = kpos 141 continue c c copy elemnts one at a time. c do 200 jj = 1, idiag k1 = ia(jj)-1 len = ia(jj+1)-k1-1 do 160 k=1,len kpos = iao(iperm(k)) ao(kpos) = a(k1+k) jao(kpos) = ja(k1+k) iao(iperm(k)) = kpos+1 160 continue 200 continue c c rewind pointers c do 5 j=nrow,1,-1 iao(j+1) = iao(j) 5 continue iao(1) = 1 return c----------end-of-jadcsr------------------------------------------------ c----------------------------------------------------------------------- end subroutine dcsort(ival, n, icnt, index, ilo, ihi) c----------------------------------------------------------------------- c Specifications for arguments: c ---------------------------- integer n, ilo, ihi, ival(n), icnt(ilo:ihi), index(n) c----------------------------------------------------------------------- c This routine computes a permutation which, when applied to the c input vector ival, sorts the integers in ival in descending c order. The permutation is represented by the vector index. The c permuted ival can be interpreted as follows: c ival(index(i-1)) .ge. ival(index(i)) .ge. ival(index(i+1)) c c A specialized sort, the distribution counting sort, is used c which takes advantage of the knowledge that c 1) The values are in the (small) range [ ilo, ihi ] c 2) Values are likely to be repeated often c c contributed to SPARSKIT by Mike Heroux. (Cray Research) c --------------------------------------- c----------------------------------------------------------------------- c Usage: c------ c call dcsort( ival, n, icnt, index, ilo, ihi ) c c Arguments: c----------- c ival integer array (input) c On entry, ia is an n dimensional array that contains c the values to be sorted. ival is unchanged on exit. c c n integer (input) c On entry, n is the number of elements in ival and index. c c icnt integer (work) c On entry, is an integer work vector of length c (ihi - ilo + 1). c c index integer array (output) c On exit, index is an n-length integer vector containing c the permutation which sorts the vector ival. c c ilo integer (input) c On entry, ilo is .le. to the minimum value in ival. c c ihi integer (input) c On entry, ihi is .ge. to the maximum value in ival. c c Remarks: c--------- c The permutation is NOT applied to the vector ival. c c---------------------------------------------------------------- c c Local variables: c Other integer values are temporary indices. c c Author: c-------- c Michael Heroux c Sandra Carney c Mathematical Software Research Group c Cray Research, Inc. c c References: c Knuth, Donald E., "The Art of Computer Programming, Volume 3: c Sorting and Searching," Addison-Wesley, Reading, Massachusetts, c 1973, pp. 78-79. c c Revision history: c 05/09/90: Original implementation. A variation of the c Distribution Counting Sort recommended by c Sandra Carney. (Mike Heroux) c c----------------------------------------------------------------- c ---------------------------------- c Specifications for local variables c ---------------------------------- integer i, j, ivalj c c -------------------------- c First executable statement c -------------------------- do 10 i = ilo, ihi icnt(i) = 0 10 continue c do 20 i = 1, n icnt(ival(i)) = icnt(ival(i)) + 1 20 continue c do 30 i = ihi-1,ilo,-1 icnt(i) = icnt(i) + icnt(i+1) 30 continue c do 40 j = n, 1, -1 ivalj = ival(j) index(icnt(ivalj)) = j icnt(ivalj) = icnt(ivalj) - 1 40 continue return end c-------end-of-dcsort--------------------------------------------------- c----------------------------------------------------------------------- subroutine cooell(job,n,nnz,a,ja,ia,ao,jao,lda,ncmax,nc,ierr) implicit none integer job,n,nnz,lda,ncmax,nc,ierr integer ja(nnz),ia(nnz),jao(lda,ncmax) real*8 a(nnz),ao(lda,ncmax) c----------------------------------------------------------------------- c COOrdinate format to ELLpack format c----------------------------------------------------------------------- c On entry: c job -- 0 if only pattern is to be processed(AO is not touched) c n -- number of rows in the matrix c a,ja,ia -- input matix in COO format c lda -- leading dimension of array AO and JAO c ncmax -- size of the second dimension of array AO and JAO c c On exit: c ao,jao -- the matrix in ELL format c nc -- maximum number of nonzeros per row c ierr -- 0 if convertion succeeded c -1 if LDA < N c nc if NC > ncmax c c NOTE: the last column of JAO is used as work space!! c----------------------------------------------------------------------- integer i,j,k,ip real*8 zero logical copyval parameter (zero=0.0D0) c .. first executable statement .. copyval = (job.ne.0) if (lda .lt. n) then ierr = -1 return endif c .. use the last column of JAO as workspace c .. initialize the work space do i = 1, n jao(i,ncmax) = 0 enddo nc = 0 c .. go through ia and ja to find out number nonzero per row do k = 1, nnz i = ia(k) jao(i,ncmax) = jao(i,ncmax) + 1 enddo c .. maximum number of nonzero per row nc = 0 do i = 1, n if (nc.lt.jao(i,ncmax)) nc = jao(i,ncmax) jao(i,ncmax) = 0 enddo c .. if nc > ncmax retrun now if (nc.gt.ncmax) then ierr = nc return endif c .. go through ia and ja to copy the matrix to AO and JAO do k = 1, nnz i = ia(k) j = ja(k) jao(i,ncmax) = jao(i,ncmax) + 1 ip = jao(i,ncmax) if (ip.gt.nc) nc = ip if (copyval) ao(i,ip) = a(k) jao(i,ip) = j enddo c .. fill the unspecified elements of AO and JAO with zero diagonals do i = 1, n do j = ia(i+1)-ia(i)+1, nc jao(i,j)=i if(copyval) ao(i,j) = zero enddo enddo ierr = 0 c return end c-----end-of-cooell----------------------------------------------------- c----------------------------------------------------------------------- subroutine xcooell(n,nnz,a,ja,ia,ac,jac,nac,ner,ncmax,ierr) C----------------------------------------------------------------------- C coordinate format to ellpack format. C----------------------------------------------------------------------- C C DATE WRITTEN: June 4, 1989. C C PURPOSE C ------- C This subroutine takes a sparse matrix in coordinate format and C converts it into the Ellpack-Itpack storage. C C Example: C ------- C ( 11 0 13 0 0 0 ) C | 21 22 0 24 0 0 | C | 0 32 33 0 35 0 | C A = | 0 0 43 44 0 46 | C | 51 0 0 54 55 0 | C ( 61 62 0 0 65 66 ) C C Coordinate storage scheme: C C A = (11,22,33,44,55,66,13,21,24,32,35,43,46,51,54,61,62,65) C IA = (1, 2, 3, 4, 5, 6, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 6 ) C JA = ( 1, 2, 3, 4, 5, 6, 3, 1, 4, 2, 5, 3, 6, 1, 4, 1, 2, 5) C C Ellpack-Itpack storage scheme: C C ( 11 13 0 0 ) ( 1 3 * * ) C | 22 21 24 0 | | 2 1 4 * | C AC = | 33 32 35 0 | JAC = | 3 2 5 * | C | 44 43 46 0 | | 4 3 6 * | C | 55 51 54 0 | | 5 1 4 * | C ( 66 61 62 65 ) ( 6 1 2 5 ) C C Note: * means that you can store values from 1 to 6 (1 to n, where C n is the order of the matrix) in that position in the array. C C Contributed by: C --------------- C Ernest E. Rothman C Cornell Thoery Center/Cornell National Supercomputer Facility C e-mail address: BITNET: EER@CORNELLF.BITNET C INTERNET: eer@cornellf.tn.cornell.edu C C checked and modified 04/13/90 Y.Saad. C C REFERENCES C ---------- C Kincaid, D. R.; Oppe, T. C.; Respess, J. R.; Young, D. M. 1984. C ITPACKV 2C User's Guide, CNA-191. Center for Numerical Analysis, C University of Texas at Austin. C C "Engineering and Scientific Subroutine Library; Guide and C Reference; Release 3 (SC23-0184-3). Pp. 79-86. C C----------------------------------------------------------------------- C C INPUT PARAMETERS C ---------------- C N - Integer. The size of the square matrix. C C NNZ - Integer. Must be greater than or equal to the number of C nonzero elements in the sparse matrix. Dimension of A, IA C and JA. C C NCA - Integer. First dimension of output arrays ca and jac. C C A(NNZ) - Real array. (Double precision) C Stored entries of the sparse matrix A. C NNZ is the number of nonzeros. C C IA(NNZ) - Integer array. C Pointers to specify rows for the stored nonzero entries C in A. C C JA(NNZ) - Integer array. C Pointers to specify columns for the stored nonzero C entries in A. C C NER - Integer. Must be set greater than or equal to the maximum C number of nonzeros in any row of the sparse matrix. C C OUTPUT PARAMETERS C ----------------- C AC(NAC,*) - Real array. (Double precision) C Stored entries of the sparse matrix A in compressed C storage mode. C C JAC(NAC,*) - Integer array. C Contains the column numbers of the sparse matrix C elements stored in the corresponding positions in C array AC. C C NCMAX - Integer. Equals the maximum number of nonzeros in any C row of the sparse matrix. C C IERR - Error parameter is returned as zero on successful C execution of the subroutin #include #include #include "GetDPConfig.h" #include "Sparskit.h" #include "MallocUtils.h" #include "Message.h" #if defined(HAVE_UNDERSCORE) #define etime_ etime #define ilut_ ilut #define ilutp_ ilutp #define ilud_ ilud #define iludp_ iludp #define iluk_ iluk #define ilu0_ ilu0 #define milu0_ milu0 #define cmkreord_ cmkreord #define sortcol_ sortcol #define skit_ skit #define psplot_ psplot #define cg_ cg #define cgnr_ cgnr #define bcg_ bcg #define dbcg_ dbcg #define bcgstab_ bcgstab #define tfqmr_ tfqmr #define fom_ fom #define gmres_ gmres #define fgmres_ fgmres #define dqgmres_ dqgmres #define amux_ amux #define atmux_ atmux #define lusol_ lusol #define lutsol_ lutsol #define csrcoo_ csrcoo #define ma28ad_ ma28ad #define ma28cd_ ma28cd #define dnrm2_ dnrm2 #define flu_ flu #define pgmres_ pgmres #define getdia_ getdia #define amudia_ amudia #define diamua_ diamua #define rnrms_ rnrms #define cnrms_ cnrms #endif /* Fortran prototypes */ extern "C" { void ilut_ (int*,double*,int*,int*,int*,double*, sscalar*,int*,int*,int*,double*,int*,int*); void ilutp_ (int*,double*,int*,int*,int*,double*, double*,int*,sscalar*,int*, int*,int*,double*,int*,int*,int*); void ilud_ (int*,double*,int*,int*,double*, double*,sscalar*,int*, int*,int*,double*,int*,int*); void iludp_ (int*,double*,int*,int*,double*, double*,double*, int*,sscalar*,int*,int*,int*, double*,int*,int*,int*); void iluk_ (int*,double*,int*,int*,int*, sscalar*,int*,int*, int*,int*,double*,int*,int*); void ilu0_ (int*,double*,int*,int*,sscalar*,int*,int*,int*,int*); void milu0_ (int*,double*,int*,int*,sscalar*,int*,int*,int*,int*); void cmkreord_ (int*,double*,int*,int*,double*,int*,int*,int*, int*,int*,int*,int*,int*,int*); void sortcol_ (int*,double*,int*,int*,int*,double*); void skit_ (int*,double*,int*,int*,int*,int*,int*); void psplot_ (int*,int*,int*,int*,int*); void cg_ (int*,double*,double*,int*,double*,double*); void cgnr_ (int*,double*,double*,int*,double*,double*); void bcg_ (int*,double*,double*,int*,double*,double*); void dbcg_ (int*,double*,double*,int*,double*,double*); void bcgstab_ (int*,double*,double*,int*,double*,double*); void tfqmr_ (int*,double*,double*,int*,double*,double*); void fom_ (int*,double*,double*,int*,double*,double*); void gmres_ (int*,double*,double*,int*,double*,double*); void fgmres_ (int*,double*,double*,int*,double*,double*); void dqgmres_ (int*,double*,double*,int*,double*,double*); void amux_ (int*,double*,double*,double*,int*,int*); void atmux_ (int*,double*,double*,double*,int*,int*); void lusol_ (int*,double*,double*,sscalar*,int*,int*); void lutsol_ (int*,double*,double*,sscalar*,int*,int*); void csrcoo_ (int*,int*,int*,double*,int*,int*,int*,double*,int*,int*,int*); void ma28ad_ (int*,int*,double*,int*,int*,int*,int*,double*,int*,int*,double*,int*); void ma28cd_ (int*,double*,int*,int*,int*,double*,double*,int*); double dnrm2_ (int*,double*,int*); void flu_ (int*,double*,double*,double*,int*,int*,double*,double*, double*,double*,double*); void pgmres_ (int*,int*,double*,double*,double*,double*, int*,int*,double*,int*,int*, sscalar*,int*,int*,int*); void getdia_ (int*,int*,int*,double*,int*,int*,int*,double*,int*,int*); void diamua_ (int*,int*,double*,int*,int*,double*,double*,int*,int*); void amudia_ (int*,int*,double*,int*,int*,double*,double*,int*,int*); void rnrms_ (int*,int*,double*,int*,int*,double*); void cnrms_ (int*,int*,double*,int*,int*,double*); } /* ------------------------------------------------------------------------ */ /* s o l v e */ /* ------------------------------------------------------------------------ */ void solve_matrix (Matrix *M, Solver_Params *p, double *b, double *x){ FILE *pf; double fpar[17]; double *a, *w, *rhs, *sol, *dx ; double res; int i, j, k, nnz, nnz_ilu, ierr, ipar[17]; int *ja, *ia, *jw, *mask, *levels; int its, end, do_permute=0; int zero=0, un=1, deux=2, six=6, douze=12, trente=30, trente_et_un=31; int ROW=0, COLUMN=1; double res1=1.; int TrueNnz=0; if (!M->N) { Message::Warning("No equations in linear system"); return; } for(i=0 ; iN ; i++){ if(b[i] != 0.) break; if(i == M->N-1) { Message::Warning("Null right hand side in linear system"); /* for(i=0 ; iN ; i++) x[i] = 0. ; return ; */ } } if(M->T == DENSE){ if(p->Algorithm == LU){ Message::Info("Dense LU decomposition"); print_matrix_info_DENSE(M->N); sol = (double*)Malloc(M->N * sizeof(double)); w = (double*)Malloc(M->N * sizeof(double)); dx = (double*)Malloc(M->N * sizeof(double)); ipar[1] = p->Re_Use_LU; ipar[2] = p->Iterative_Improvement; ipar[3] = p->Matrix_Printing; ipar[4] = p->Nb_Iter_Max; fpar[1] = p->Stopping_Test; flu_(&ipar[1], &fpar[1], M->F.a, M->F.lu, &M->N, &M->N, b, x, dx, sol, w); Free(sol); Free(w); Free(dx); return ; } Message::Info("Dense to sparse matrix conversion") ; nnz = M->N * M->N ; M->S.a = List_Create(1, 1, sizeof(double)); M->S.a->n = nnz ; M->S.a->array = (char*) M->F.a ; M->S.jptr = List_Create(M->N+1, M->N, sizeof(int)); M->S.ai = List_Create(nnz, M->N, sizeof(int)); for(i=1 ; i<=nnz ; i+=M->N){ List_Add(M->S.jptr, &i) ; for(j=1 ; j<=M->N ; j++){ List_Add(M->S.ai, &j) ; } } i = nnz + 1 ; List_Add(M->S.jptr, &i) ; if(M->changed){ do_permute = 1 ; M->changed = 0 ; } for (i=0 ; iF.a[i]) TrueNnz++ ; Message::Info("Number of nonzeros %d/%d (%.4f)",TrueNnz, nnz, (double)TrueNnz/(double)nnz); Message::Cpu(""); } /* if DENSE */ else{ nnz = List_Nbr(M->S.a); if(M->changed){ do_permute = 1 ; csr_format (&M->S, M->N); restore_format (&M->S); M->changed = 0 ; } } /* if SPARSE */ a = (double*) M->S.a->array; ia = (int*) M->S.jptr->array; ja = (int*) M->S.ai->array; if(p->Scaling != NONE){ Message::Info("Scaling system of equations") ; scale_matrix (p->Scaling, M) ; scale_vector (ROW, M, b) ; } else{ Message::Info("No scaling of system of equations") ; } for (i=1; iN; i++) { if(ia[i]-ia[i-1] <= 0) Message::Error("Zero row in matrix"); } rhs = (double*) Malloc(M->N * sizeof(double)); sol = (double*) Calloc(M->N, sizeof(double)); /* Renumbering */ if (!M->ILU_Exists){ M->S.permr = (int*) Malloc(M->N * sizeof(int)); M->S.rpermr = (int*) Malloc(M->N * sizeof(int)); M->S.permp = (int*) Malloc(2 * M->N * sizeof(int)); } if(do_permute || !M->ILU_Exists){ for(i=0 ; iN ; i++) { M->S.permr[i] = M->S.rpermr[i] = M->S.permp[i+M->N] = i+1; } switch (p->Renumbering_Technique){ case NONE: Message::Info("No renumbering"); break; case RCMK: Message::Info("RCMK algebraic renumbering"); if(!M->ILU_Exists){ M->S.a_rcmk = (double*) Malloc(nnz * sizeof(double)); M->S.ia_rcmk = (int*) Malloc((M->N + 1) * sizeof(int)); M->S.ja_rcmk = (int*) Malloc(nnz * sizeof(int)); } mask = (int*) Malloc(nnz * sizeof(int)); levels = (int*) Malloc((M->N + 1) * sizeof(int)); i = j = k = 1; cmkreord_(&M->N, a, ja, ia, M->S.a_rcmk, M->S.ja_rcmk, M->S.ia_rcmk, &i, M->S.permr, mask, &j, &k, M->S.rpermr, levels); w = (double*) Malloc(nnz * sizeof(double)); sortcol_(&M->N, M->S.a_rcmk, M->S.ja_rcmk, M->S.ia_rcmk, mask, w); Free(w); Free(mask); Free(levels); break; default : Message::Error("Unknown renumbering technique"); break; } print_matrix_info_CSR(M->N, ia, ja); Message::Cpu(""); } if(p->Renumbering_Technique == RCMK){ if (p->Re_Use_ILU && !M->ILU_Exists && !do_permute){ /* This is incorrect if M is to be changed during the process, and we still want to keep the same precond. Free(M->S.a->array) ; Free(M->S.jptr->array) ; Free(M->S.ai->array) ; M->S.a->array = (char*)M->S.a_rcmk; M->S.jptr->array = (char*)M->S.ia_rcmk; M->S.ai->array = (char*)M->S.ja_rcmk; */ } a = M->S.a_rcmk; ia = M->S.ia_rcmk; ja = M->S.ja_rcmk; } if (p->Matrix_Printing == 1 || p->Matrix_Printing == 3) { Message::Info("Matrix printing"); skit_(&M->N, a, ja, ia, &douze, &douze, &ierr); pf = fopen("fort.13","w"); for (i=0 ; iN ; i++) fprintf(pf, "%d %22.15E\n", i+1, b[i]); fclose(pf); psplot_(&M->N, ja, ia, &trente, &zero); } /* Incomplete factorizations */ if (!M->ILU_Exists) { if (p->Re_Use_ILU) M->ILU_Exists = 1; #if defined(HAVE_ILU_FLOAT) #define ILUSTORAGE "Float" #else #define ILUSTORAGE "Double" #endif end = 0 ; switch (p->Preconditioner){ case ILUT : Message::Info("ILUT (%s, fill-in = %d)", ILUSTORAGE, p->Nb_Fill); nnz_ilu = 2 * (M->N+1) * (p->Nb_Fill+1); break; case ILUTP : Message::Info("ILUTP (%s, fill-in = %d)", ILUSTORAGE, p->Nb_Fill); nnz_ilu = 2 * (M->N+1) * (p->Nb_Fill+1); break; case ILUD : Message::Info("ILUD (%s)", ILUSTORAGE); /* first guess */ nnz_ilu = List_Nbr(M->S.a); break; case ILUDP : Message::Info("ILUDP (%s)", ILUSTORAGE); /* first guess */ nnz_ilu = List_Nbr(M->S.a); break ; case ILUK : Message::Info("ILU%d (%s)", p->Nb_Fill, ILUSTORAGE); /* exact for nbfill=0, first guess otherwise */ nnz_ilu = (p->Nb_Fill+1) * List_Nbr(M->S.a) + (M->N+1); break; case ILU0 : Message::Info("ILU0 (%s)", ILUSTORAGE); nnz_ilu = List_Nbr(M->S.a) + (M->N+1); break; case MILU0 : Message::Info("MILU0 (%s)", ILUSTORAGE); nnz_ilu = List_Nbr(M->S.a) + (M->N+1); break; case DIAGONAL : Message::Info("Diagonal scaling (%s)", ILUSTORAGE); M->S.alu = (sscalar*) Malloc((M->N+1) * sizeof(sscalar)); M->S.jlu = (int*) Malloc((M->N+1) * sizeof(int)); M->S.ju = (int*) Malloc((M->N+1) * sizeof(int)); for (i=0 ; iN ; i++) { M->S.alu[i] = 1.0 ; M->S.jlu[i] = M->N+2 ; M->S.ju[i] = M->N+2 ; } M->S.alu[M->N] = 0.0 ; M->S.jlu[M->N] = M->N+2 ; M->S.ju[M->N] = 0 ; end = 1; ierr = 0; break; case NONE : Message::Info("No ILU"); end = 1; ierr = 0; break ; default : Message::Error("Unknown ILU method"); break; } if(!end){ M->S.alu = (sscalar*) Malloc(nnz_ilu * sizeof(sscalar)); M->S.jlu = (int*) Malloc(nnz_ilu * sizeof(int)); M->S.ju = (int*) Malloc((M->N+1) * sizeof(int)); } reallocate : switch(p->Preconditioner){ case ILUT : w = (double*) Malloc((M->N+1) * sizeof(double)); jw = (int*) Malloc(2 * (M->N+1) * sizeof(int)); ilut_(&M->N, a, ja, ia, &p->Nb_Fill, &p->Dropping_Tolerance, M->S.alu, M->S.jlu, M->S.ju, &nnz_ilu, w, jw, &ierr); Free(w); Free(jw); break; case ILUTP : w = (double*) Malloc((M->N+1) * sizeof(double)); jw = (int*) Malloc(2 * (M->N+1) * sizeof(int)); ilutp_(&M->N, a, ja, ia, &p->Nb_Fill, &p->Dropping_Tolerance, &p->Permutation_Tolerance, &M->N, M->S.alu, M->S.jlu, M->S.ju, &nnz_ilu, w, jw, M->S.permp, &ierr); Free(jw); Free(w); break; case ILUD : w = (double*) Malloc((M->N+1) * sizeof(double)); jw = (int*) Malloc(2 * (M->N+1) * sizeof(int)); ilud_(&M->N, a, ja, ia, &p->Diagonal_Compensation, &p->Dropping_Tolerance, M->S.alu, M->S.jlu, M->S.ju, &nnz_ilu, w, jw, &ierr); Free(w); Free(jw); break; case ILUDP : w = (double*) Malloc((M->N+1) * sizeof(double)); jw = (int*) Malloc(2 * (M->N+1) * sizeof(int)); iludp_(&M->N, a, ja, ia, &p->Diagonal_Compensation, &p->Dropping_Tolerance, &p->Permutation_Tolerance, &M->N, M->S.alu, M->S.jlu, M->S.ju, &nnz_ilu, w, jw, M->S.permp, &ierr); Free(jw); Free(w); break; case ILUK : levels = (int*) Malloc(nnz_ilu * sizeof(int)); w = (double*) Malloc((M->N+1) * sizeof(double)); jw = (int*) Malloc(3 * (M->N+1) * sizeof(int)); iluk_(&M->N, a, ja, ia, &p->Nb_Fill, M->S.alu, M->S.jlu, M->S.ju, levels, &nnz_ilu, w, jw, &ierr); Free(levels); Free(w); Free(jw); break; case ILU0 : jw = (int*) Malloc((M->N+1) * sizeof(int)); ilu0_(&M->N, a, ja, ia, M->S.alu, M->S.jlu, M->S.ju, jw, &ierr); Free(jw); break; case MILU0 : jw = (int*) Malloc((M->N+1) * sizeof(int)); milu0_(&M->N, a, ja, ia, M->S.alu, M->S.jlu, M->S.ju, jw, &ierr); Free(jw); break; } switch (ierr){ case 0 : break; case -1 : Message::Error("Input matrix may be wrong"); break; case -2 : /* Matrix L in ILU overflows work array 'al' */ case -3 : /* Matrix U in ILU overflows work array 'alu' */ nnz_ilu += nnz_ilu/2 ; Message::Info("Reallocating ILU (NZ: %d)", nnz_ilu); Free(M->S.alu) ; M->S.alu = (sscalar*) Malloc(nnz_ilu * sizeof(sscalar)); Free(M->S.jlu) ; M->S.jlu = (int*) Malloc(nnz_ilu * sizeof(int)); goto reallocate ; case -4 : Message::Error("Illegal value of nb_fill in ILU"); break; case -5 : Message::Error("Zero row encountered in ILU"); break; default : Message::Error("Zero pivot on line %d in ILU",ierr); break; } if(p->Preconditioner != NONE) print_matrix_info_MSR(M->N, M->S.alu, M->S.jlu); if(p->Matrix_Printing == 2 || p->Matrix_Printing == 3){ Message::Info("ILU printing"); psplot_(&M->N, M->S.jlu, M->S.jlu, &trente_et_un, &deux); } Message::Cpu(""); } /* RHS reordering */ for(i=0;iN;i++){ rhs[i] = b[M->S.rpermr[i] - 1]; } /* Iterations */ ipar[1] = 0; ipar[2] = (p->Preconditioner == NONE) ? 0 : p->Preconditioner_Position; ipar[3] = 1; ipar[4] = 0; ipar[5] = p->Krylov_Size; ipar[6] = p->Nb_Iter_Max; fpar[1] = p->Stopping_Test; fpar[2] = 0.0; fpar[11] = 0.0; switch (p->Algorithm){ case CG : Message::Info("Conjugate Gradient (CG)"); ipar[4] = 5 * M->N; break; case CGNR : Message::Info("CG Normal Residual equation (CGNR)"); ipar[4] = 5 * M->N; break; case BCG : Message::Info("Bi-Conjugate Gradient (BCG)"); ipar[4] = 7 * M->N; break; case DBCG : Message::Info("BCG with partial pivoting (DBCG)"); ipar[4] = 11 * M->N; break; case BCGSTAB : Message::Info("BCG stabilized (BCGSTAB)"); ipar[4] = 8 * M->N; break; case TFQMR : Message::Info("Transpose-Free Quasi-Minimum Residual (TFQMR)"); ipar[4] = 11 * M->N; break; case FOM : Message::Info("Full Orthogonalization Method (FOM)"); ipar[4] = (M->N+3) * (ipar[5]+2) + (ipar[5]+1) * ipar[5]/2; break; case GMRES : Message::Info("Generalized Minimum RESidual (GMRES)"); ipar[4] = (M->N+3) * (ipar[5]+2) + (ipar[5]+1) * ipar[5]/2; break; case FGMRES : Message::Info("Flexible version of Generalized Minimum RESidual (FGMRES)"); ipar[4] = 2*M->N * (ipar[5]+1) + (ipar[5]+1)*ipar[5]/2 + 3*ipar[5] + 2; break; case DQGMRES : Message::Info("Direct version of Quasi Generalize Minimum RESidual (DQGMRES)"); ipar[4] = M->N + (ipar[5]+1) * (2*M->N+4); break; case PGMRES : Message::Info("Alternative Generalized Minimum RESidual (GMRES)"); ipar[4] = (M->N+4) * (ipar[5]+2) + (ipar[5]+1) * ipar[5]/2; break; default : Message::Error("Unknown algorithm for sparse matrix solver"); break; } w = (double*) Malloc(ipar[4] * sizeof(double)); its = 0; end = 0; res = 0.0; while(1){ switch(p->Algorithm){ case CG : cg_(&M->N, rhs, sol, &ipar[1], &fpar[1], w); break; case CGNR : cgnr_(&M->N, rhs, sol, &ipar[1], &fpar[1], w); break; case BCG : bcg_(&M->N, rhs, sol, &ipar[1], &fpar[1], w); break; case DBCG : dbcg_(&M->N, rhs, sol, &ipar[1], &fpar[1], w); break; case BCGSTAB : bcgstab_(&M->N, rhs, sol, &ipar[1], &fpar[1], w); break; case TFQMR : tfqmr_(&M->N, rhs, sol, &ipar[1], &fpar[1], w); break; case FOM : fom_(&M->N, rhs, sol, &ipar[1], &fpar[1], w); break; case GMRES : gmres_(&M->N, rhs, sol, &ipar[1], &fpar[1], w); break; case FGMRES : fgmres_(&M->N, rhs, sol, &ipar[1], &fpar[1], w); break; case DQGMRES : dqgmres_(&M->N, rhs, sol, &ipar[1], &fpar[1], w); break; case PGMRES : pgmres_ (&M->N, &p->Krylov_Size, rhs, sol, w, &p->Stopping_Test, &p->Nb_Iter_Max, &six, a, ja, ia, M->S.alu, M->S.jlu, M->S.ju, &ierr); end = 1; break; } if(!end){ if(ipar[7] != its){ if(its) Message::Info(" %4d %.7e %.7e", its, res, res/res1); its = ipar[7] ; } res = fpar[5]; if(its==1) res1 = fpar[5] ; switch(ipar[1]){ case 1 : amux_(&M->N, &w[ipar[8]-1], &w[ipar[9]-1], a, ja, ia); break; case 2 : atmux_(&M->N, &w[ipar[8]-1], &w[ipar[9]-1], a, ja, ia); break; case 3 : case 5 : lusol_(&M->N, &w[ipar[8]-1], &w[ipar[9]-1], M->S.alu, M->S.jlu, M->S.ju); break; case 4 : case 6 : lutsol_(&M->N, &w[ipar[8]-1], &w[ipar[9]-1], M->S.alu, M->S.jlu, M->S.ju); break; case 0 : end = 1; break; case -1 : Message::Warning("Iterative solver has iterated too many times"); end = 1; break; case -2 : Message::Warning("Iterative solver was not given enough work space"); Message::Warning("The work space should at least have %d elements", ipar[4]); end = 1; break; case -3 : Message::Warning("Iterative solver is facing a break-down"); end = 1; break; default : Message::Warning("Iterative solver terminated (code = %d)", ipar[1]); end = 1; break; } } if(end) break; } /* Convergence results monitoring */ Message::Info(" %4d %.7e %.7e", ipar[7], fpar[6], fpar[6]/res1); amux_(&M->N, sol, w, a, ja, ia); for(i=0 ; iN ; i++){ w[M->N+i] = sol[i] - 1.0 ; w[i] -= rhs[i] ; } Message::Info("%d Iterations / Residual: %g", ipar[7], dnrm2_(&M->N,w,&un)); /* Message::Info("Conv. Rate: %g, |Res|: %g, |Err|: %g", fpar[7], dnrm2_(&M->N,w,&un), dnrm2_(&M->N,&w[M->N],&un)); */ Free(w); /* Inverse renumbering */ for (i=0;iN;i++) { j = M->S.permr[i] - 1; k = M->S.permp[j+M->N] - 1; x[i] = sol[k]; } /* Free memory */ Free(rhs); Free(sol); if (!M->ILU_Exists){ if(p->Preconditioner != NONE) { Free(M->S.alu); Free(M->S.jlu); Free(M->S.ju); } if (p->Renumbering_Technique == RCMK) { Free(M->S.rpermr); Free(M->S.permr); Free(M->S.permp); Free(M->S.a_rcmk); Free(M->S.ia_rcmk); Free(M->S.ja_rcmk); } } if(M->T == DENSE){ List_Delete(M->S.a); List_Delete(M->S.jptr); List_Delete(M->S.ai); } if(p->Scaling) scale_vector (COLUMN, M, x) ; } /* ------------------------------------------------------------------------ */ /* p r i n t */ /* ------------------------------------------------------------------------ */ void print_parametres (Solver_Params *p){ printf(" Matrix_Format : %d\n", p->Matrix_Format); printf(" Matrix_Printing : %d\n", p->Matrix_Printing); printf(" Renumbering_Technique : %d\n", p->Renumbering_Technique); printf(" Preconditioner : %d\n", p->Preconditioner); printf(" Preconditioner_Position : %d\n", p->Preconditioner_Position); printf(" Nb_Fill : %d\n", p->Nb_Fill); printf(" Dropping_Tolerance : %g\n", p->Dropping_Tolerance); printf(" Permutation_Tolerance : %g\n", p->Permutation_Tolerance); printf(" Diagonal_Compensation : %g\n", p->Diagonal_Compensation); printf(" Algorithm : %d\n", p->Algorithm); printf(" Krylov_Size : %d\n", p->Krylov_Size); printf(" IC_Acceleration : %g\n", p->IC_Acceleration); printf(" Iterative_Improvement : %d\n", p->Iterative_Improvement); printf(" Nb_Iter_Max : %d\n", p->Nb_Iter_Max); printf(" Stopping_Test : %g\n", p->Stopping_Test); } /* ------------------------------------------------------------------------ */ /* i n i t */ /* ------------------------------------------------------------------------ */ void init_matrix (int NbLines, Matrix *M, Solver_Params *p){ int i, j=0; M->T = p->Matrix_Format; M->N = NbLines; M->changed = 1 ; M->ILU_Exists = 0; M->notranspose = 0 ; M->scaled = 0 ; switch (M->T) { case SPARSE : M->S.a = List_Create (NbLines, NbLines, sizeof(double)); M->S.ai = List_Create (NbLines, NbLines, sizeof(int)); M->S.ptr = List_Create (NbLines, NbLines, sizeof(int)); M->S.jptr = List_Create (NbLines+1, NbLines, sizeof(int)); /* '+1' indispensable: csr_format ecrit 'nnz+1' dans jptr[NbLine] */ for(i=0; iS.jptr, &j); break; case DENSE : M->F.LU_Exist = 0; /* Tous les algos iteratifs sont programmes pour resoudre A^T x = b... C'est tres con, mais bon. L'algo LU est le seul qui demande la vraie matrice en entree... */ if(p->Algorithm == LU){ M->F.lu = (double*) Malloc (NbLines * NbLines * sizeof(double)); M->notranspose = 1 ; } else M->F.lu = NULL; M->F.a = (double*) Malloc (NbLines * NbLines * sizeof(double)); break; default : Message::Error("Unknown type of matrix storage format: %d", M->T); break; } } void init_vector (int Nb, double **V){ *V = (double*) Malloc (Nb * sizeof(double)); } /* ------------------------------------------------------------------------ */ /* f r e e */ /* ------------------------------------------------------------------------ */ void free_matrix (Matrix *M){ if(M->scaled){ Free(M->rowscal) ; Free(M->colscal) ; } switch (M->T) { case SPARSE : List_Delete(M->S.a); List_Delete(M->S.ai); List_Delete(M->S.ptr); List_Delete(M->S.jptr); break; case DENSE : Free(M->F.a); Free(M->F.lu); break; } } /* ------------------------------------------------------------------------ */ /* z e r o */ /* ------------------------------------------------------------------------ */ void zero_matrix (Matrix *M){ int i,j=0; M->changed = 1 ; switch (M->T) { case SPARSE : List_Reset (M->S.a); List_Reset (M->S.ai); List_Reset (M->S.ptr); List_Reset (M->S.jptr); for (i=0; iN; i++) List_Add (M->S.jptr, &j); break; case DENSE : for(i=0; i<(M->N)*(M->N); i++) M->F.a[i] = 0.0; break; } } void zero_matrix2 (Matrix *M){ int i, iptr; int *jptr, *ptr; double *a; M->changed = 1 ; switch (M->T) { case SPARSE : jptr = (int*) M->S.jptr->array; ptr = (int*) M->S.ptr->array; a = (double*) M->S.a->array; for (i=0; iN; i++) { iptr = jptr[i]; while (iptr>0) { a[iptr-1]= 0. ; iptr = ptr[iptr-1]; } } break; case DENSE : for(i=0; i<(M->N)*(M->N); i++) M->F.a[i] = 0.0; break; } } void zero_vector (int Nb, double *V){ int i; for(i=0; i u */ int i; for(i=0; i u */ int i; for(i=0; ichanged = 1 ; switch (M->T) { case SPARSE : il--; pp = (int*) M->S.jptr->array; ptr = (int*) M->S.ptr->array; ai = (int*) M->S.ai->array; a = (double*) M->S.a->array; iptr = pp[il]; iptr2 = iptr-1; while(iptr>0){ iptr2 = iptr-1; jptr = ai[iptr2]; if(jptr == ic){ a[iptr2] += val; return; } iptr = ptr[iptr2]; } List_Add (M->S.a, &val); List_Add (M->S.ai, &ic); List_Add (M->S.ptr, &zero); /* Les pointeurs ont pu etre modifies s'il y a eu une reallocation dans List_Add */ ptr = (int*) M->S.ptr->array; ai = (int*) M->S.ai->array; a = (double*) M->S.a->array; n = List_Nbr(M->S.a); if(!pp[il]) pp[il] = n; else ptr[iptr2] = n; break; case DENSE : if(M->notranspose) M->F.a[((M->N))*(il-1)+(ic-1)] += val; else M->F.a[((M->N))*(ic-1)+(il-1)] += val; break; } } void add_matrix_matrix (Matrix *M, Matrix *N){ /* M+N -> M */ int i, *ai, iptr, *jptr, *ptr; double *a; switch (M->T) { case SPARSE : jptr = (int*) N->S.jptr->array; ptr = (int*) N->S.ptr->array; a = (double*) N->S.a->array; ai = (int*) N->S.ai->array; for (i=0; iN; i++) { iptr = jptr[i]; while (iptr>0) { add_matrix_double (M, ai[iptr-1], i+1, a[iptr-1]); /* add_matrix_double transpose, donc pour additionner, il faut transposer une seconde fois */ iptr = ptr[iptr-1]; } } break; case DENSE : for(i=0; i<(M->N)*(M->N); i++) M->F.a[i] += N->F.a[i]; break; } } void add_matrix_prod_matrix_double (Matrix *M, Matrix *N, double d){ /* M+N*d -> M */ int i, *ai, iptr, *jptr, *ptr; double *a; switch (M->T) { case SPARSE : jptr = (int*) N->S.jptr->array; ptr = (int*) N->S.ptr->array; a = (double*) N->S.a->array; ai = (int*) N->S.ai->array; for (i=0; iN; i++) { iptr = jptr[i]; while (iptr>0) { add_matrix_double (M, ai[iptr-1], i+1, d*a[iptr-1]); /* add_matrix_double transpose, donc pour additionner, il faut transposer une seconde fois */ iptr = ptr[iptr-1]; } } break; case DENSE : for(i=0; i<(M->N)*(M->N); i++) M->F.a[i] += d*N->F.a[i]; break; } } /* ------------------------------------------------------------------------ */ /* s u b */ /* ------------------------------------------------------------------------ */ void sub_vector_vector_1 (int Nb, double *U, double *V){ /* u-v -> u */ int i; for(i=0; i v */ int i; for(i=0; i u */ int i; for(i=0; i prosca */ int i; *prosca = 0.0 ; for (i=0; iT) { case SPARSE : jptr = (int*) M->S.jptr->array; a = (double*) M->S.a->array; ai = (int*) M->S.ai->array; switch (scaling) { case DIAG_SCALING : rowscal = colscal = (double*)Malloc(M->N * sizeof(double)); /* extract diagonal */ idiag = (int*)Malloc(M->N * sizeof(int)); getdia_ (&M->N, &M->N, &job0, a, ai, jptr, &len, rowscal, idiag, &ioff) ; Free (idiag); for (i = 0 ; i < M->N ; i++){ if (rowscal[i]){ rowscal[i] = 1./sqrt(fabs(rowscal[i])) ; /* printf(" %d %e \n", i, rowscal[i] ); */ } else { Message::Warning("Diagonal scaling aborted because of zero diagonal element (%d)",i+1) ; Free (rowscal) ; return ; } } diamua_ (&M->N, &job1, a, ai, jptr, rowscal, a, ai, jptr) ; amudia_ (&M->N, &job1, a, ai, jptr, colscal, a, ai, jptr) ; break ; case MAX_SCALING : case NORM1_SCALING : case NORM2_SCALING : switch (scaling) { case MAX_SCALING : norm = 0 ; break ; case NORM1_SCALING : norm = 1 ; break ; case NORM2_SCALING : norm = 2 ; break ; } rowscal = (double*)Malloc(M->N * sizeof(double)); rnrms_ (&M->N, &norm, a, ai, jptr, rowscal); for (i = 0 ; i < M->N ; i++){ /* printf(" %d %e \n", i, rowscal[i] ); */ if (rowscal[i]) rowscal[i] = 1./rowscal[i] ; else { Message::Warning("Scaling aborted because of zero row (%d)", i+1) ; Free (rowscal) ; return ; } } diamua_ (&M->N, &job1, a, ai, jptr, rowscal, a, ai, jptr) ; colscal = (double*)Malloc(M->N * sizeof(double)); cnrms_ (&M->N, &norm, a, ai, jptr, colscal); for (i = 0 ; i < M->N ; i++){ if (colscal[i]){ colscal[i] = 1./colscal[i] ; /* printf(" %d %e %e \n", i, 1./rowscal[i], 1./colscal[i] ); */ } else { Message::Warning("Scaling aborted because of zero column (%d)", i+1) ; Free (colscal) ; return ; } } amudia_ (&M->N, &job1, a, ai, jptr, colscal, a, ai, jptr) ; break; default : Message::Error("Unknown type of matrix scaling: %d", scaling); break; } M->scaled = 1 ; M->rowscal = rowscal ; M->colscal = colscal ; break; case DENSE : Message::Warning("Scaling is not implemented for dense matrices") ; break; } } void scale_vector (int ROW_or_COLUMN, Matrix *M, double *V){ double *scal = NULL; int i; if (!M->scaled) return ; switch (ROW_or_COLUMN) { case 0 : scal = M->rowscal ; break ; case 1 : scal = M->colscal ; break ; } if (scal == NULL) Message::Error("scale_vector : no scaling factors available !") ; for (i = 0 ; i < M->N ; i++) V[i] *= scal[i] ; } void prod_matrix_vector (Matrix *M, double *V , double *res ){ /* M*V -> res ou M est la transposee!! */ int k, i, j, *ai, *jptr ; double *a; switch (M->T) { case SPARSE : /* csr_format transpose! donc la matrice arrivant dans cette routine doit bel et bien etre la transposee !!! */ if(M->changed){ csr_format (&M->S, M->N); restore_format (&M->S); M->changed = 0 ; } jptr = (int*) M->S.jptr->array; a = (double*) M->S.a->array; ai = (int*) M->S.ai->array; for(i=0; iN; i++){ res[i] = 0.0 ; for(k=jptr[i]; k<=jptr[i+1]-1; k++){ res[i] += V[ai[k-1]-1] * a[k-1]; } } break; case DENSE : if(M->notranspose){ for(i=0; iN; i++){ res[i] = 0.0 ; for(j=0; jN; j++) res[i] += M->F.a[(M->N)*i+j] * V[j]; } } else{ for(i=0; iN; i++){ res[i] = 0.0 ; for(j=0; jN; j++) res[i] += M->F.a[(M->N)*j+i] * V[j]; } } break; } } void prod_matrix_double (Matrix *M, double v){ /* M*v -> M */ int i; double *a; switch (M->T) { case SPARSE : a = (double*) M->S.a->array; for(i=0; iS.a); i++){ a[i] *= v; } break; case DENSE : for(i=0; i<(M->N)*(M->N); i++) M->F.a[i] *= v; break; } } void multi_prod_matrix_double(int n, Matrix **Mat, double *coef, Matrix *MatRes){ int k; zero_matrix(MatRes); for(k=0;k proscar + i prodscai */ int i; *proscar = *proscai = 0.0 ; for (i=0; i *norm) *norm = fabs(U[i]); } /* ------------------------------------------------------------------------ */ /* i d e n t i t y */ /* ------------------------------------------------------------------------ */ void identity_matrix (Matrix *M){ int i; zero_matrix(M); for (i=1;i<=M->N;i++) add_matrix_double(M,i,i,1.0); } /* ------------------------------------------------------------------------ */ /* w r i t e */ /* ------------------------------------------------------------------------ */ void binary_write_matrix (Matrix *M, const char *name, const char *ext){ int Nb; FILE *pfile; char filename[256]; if(!M->N){ Message::Warning("No elements in matrix"); return; } strcpy(filename, name); strcat(filename, ext); pfile = fopen(filename, "wb") ; fprintf(pfile,"%d\n",M->T); switch (M->T) { case SPARSE : Nb = List_Nbr(M->S.a) ; fprintf(pfile,"%d %d\n", M->N, Nb); fprintf(pfile,"%d %d %d %d %d\n", M->S.ptr->nmax, M->S.ptr->size, M->S.ptr->incr, M->S.ptr->n, M->S.ptr->isorder); fprintf(pfile,"%d %d %d %d %d\n", M->S.ai->nmax, M->S.ai->size, M->S.ai->incr, M->S.ai->n, M->S.ai->isorder); fprintf(pfile,"%d %d %d %d %d\n", M->S.jptr->nmax, M->S.jptr->size, M->S.jptr->incr, M->S.jptr->n, M->S.jptr->isorder); fprintf(pfile,"%d %d %d %d %d\n", M->S.a->nmax, M->S.a->size, M->S.a->incr, M->S.a->n, M->S.a->isorder); fwrite(M->S.ptr->array, sizeof(int), Nb, pfile); fwrite(M->S.ai->array, sizeof(int), Nb, pfile); fwrite(M->S.jptr->array, sizeof(int), M->N, pfile); fwrite(M->S.a->array, sizeof(double), Nb, pfile); break; case DENSE : fprintf(pfile,"%d\n", M->N); fwrite(M->F.a, sizeof(double), M->N*M->N, pfile); break; } fclose(pfile) ; } void binary_write_vector (int Nb, double *V, const char *name, const char *ext){ char filename[256]; FILE *pfile; strcpy(filename, name); strcat(filename, ext); pfile = fopen(filename, "wb") ; fwrite(V, sizeof(double), Nb, pfile); fclose(pfile) ; } void formatted_write_matrix (FILE *pfile, Matrix *M, int style){ int *ptr,*ai,i,j,*jptr, *ia, *ja, *ir, nnz, ierr; int un=1; double *a; if(!M->N){ Message::Warning("No element in matrix"); return; } switch (M->T) { case DENSE : if(M->notranspose) for(i=0 ; iN ; i++) for(j=0 ; jN ; j++) fprintf(pfile,"%d %d %.16g\n", j+1, i+1, M->F.a[i*(M->N)+j]); else for(i=0 ; iN ; i++) for(j=0 ; jN ; j++) fprintf(pfile,"%d %d %.16g\n", i+1, j+1, M->F.a[i*(M->N)+j]); break; case SPARSE : switch(style){ case ELAP : fprintf(pfile,"%d\n",M->T); a = (double*)M->S.a->array; ai = (int*)M->S.ai->array; ptr = (int*)M->S.ptr->array; jptr = (int*)M->S.jptr->array; fprintf(pfile,"%d\n",M->N); fprintf(pfile,"%d\n",List_Nbr(M->S.a)); for(i=0;iN;i++) fprintf(pfile," %d",jptr[i]); fprintf(pfile,"\n"); for(i=0;iS.a);i++) fprintf(pfile,"%d %d %.16g \n",ai[i],ptr[i],a[i]); break; case KUL : csr_format(&M->S, M->N); a = (double*) M->S.a->array; ia = (int*) M->S.jptr->array; ja = (int*) M->S.ptr->array; nnz = List_Nbr(M->S.a); ir = (int*) Malloc(nnz * sizeof(int)); csrcoo_(&M->N, &un, &nnz, a, ja, ia, &nnz, a, ir, ja, &ierr); for(i=0 ; iS); break; default : Message::Error("Unknown print style for formatted matrix output"); } break ; default : Message::Error("Unknown matrix format for formatted matrix output"); } } void formatted_write_vector (FILE *pfile, int Nb, double *V, int style){ int i; /* for(i=0 ; iT); M->ILU_Exists = 0; switch (M->T) { case SPARSE : fscanf(pfile,"%d %d\n", &M->N, &Nb); M->S.ptr = List_Create (Nb, 1, sizeof(int)); M->S.ai = List_Create (Nb, 1, sizeof(int)); M->S.jptr = List_Create (M->N, 1, sizeof(int)); M->S.a = List_Create (Nb, 1, sizeof(double)); fscanf(pfile,"%d %d %d %d %d\n", &M->S.ptr->nmax, &M->S.ptr->size, &M->S.ptr->incr, &M->S.ptr->n, &M->S.ptr->isorder); fscanf(pfile,"%d %d %d %d %d\n", &M->S.ai->nmax, &M->S.ai->size, &M->S.ai->incr, &M->S.ai->n, &M->S.ai->isorder); fscanf(pfile,"%d %d %d %d %d\n", &M->S.jptr->nmax, &M->S.jptr->size, &M->S.jptr->incr, &M->S.jptr->n, &M->S.jptr->isorder); fscanf(pfile,"%d %d %d %d %d\n", &M->S.a->nmax, &M->S.a->size, &M->S.a->incr, &M->S.a->n, &M->S.a->isorder); fread(M->S.ptr->array, sizeof(int), Nb, pfile); fread(M->S.ai->array, sizeof(int), Nb, pfile); fread(M->S.jptr->array, sizeof(int), M->N, pfile); fread(M->S.a->array, sizeof(double), Nb, pfile); break; case DENSE : fscanf(pfile,"%d\n", &M->N); M->F.LU_Exist = 0; M->F.a = (double*) Malloc(M->N * M->N * sizeof(double)); M->F.lu = (double*) Malloc(M->N * M->N * sizeof(double)); fread(M->F.a, sizeof(double), M->N * M->N, pfile); break ; } fclose(pfile) ; } void binary_read_vector (int Nb, double **V, const char *name, const char *ext){ char filename[256]; FILE *pfile; strcpy(filename, name); strcat(filename, ext); pfile = fopen(filename, "rb") ; if (pfile == NULL) { Message::Error("Error opening file %s", filename); } init_vector(Nb, V); fread(*V, sizeof(double), Nb, pfile); fclose(pfile) ; } void formatted_read_matrix (Matrix *M, const char *name , const char *ext, int style){ int i,nnz,inb,inb2; double nb; FILE *pfile; char filename[256]; strcpy(filename, name); strcat(filename, ext); pfile = fopen(filename, "r") ; if (pfile == NULL) { Message::Error("Error opening file %s", filename); } fscanf(pfile,"%d",&M->T); switch (M->T) { case SPARSE : List_Reset(M->S.jptr); fscanf(pfile,"%d",&M->N); fscanf(pfile,"%d",&nnz); for(i=0;iN;i++){ fscanf(pfile," %d",&inb); List_Add(M->S.jptr,&inb); } for(i=0;iS.ai,&inb); List_Add(M->S.ptr,&inb2); List_Add(M->S.a,&nb); } break; case DENSE : fscanf(pfile,"%d",&M->N); for(i=0;i<(M->N)*(M->N);i++){ fscanf(pfile,"%d %lf ", &inb, &M->F.a[i]); } break; } fclose(pfile) ; } void formatted_read_vector (int Nb, double *V, const char *name, const char *ext, int style){ int i; FILE *pfile; char filename[256]; strcpy(filename, name); strcat(filename, ext); pfile = fopen(filename, "r") ; if (pfile == NULL) { Message::Error("Error opening file %s", filename); } for(i=0 ; ib) return(a); else return(b); } void print_matrix_info_CSR (int N, int *jptr, int *ai){ int i, j, k, l, m, n; l = n = 0; j = jptr[N]-1 ; for (i=0; iT) { case SPARSE : /* csr_format transpose! donc la matrice arrivant dans cette routine doit bel et bien etre la transposee !!! */ if(M->changed){ csr_format (&M->S, M->N); restore_format (&M->S); M->changed = 0 ; } jptr = (int*) M->S.jptr->array; a = (double*) M->S.a->array; ai = (int*) M->S.ai->array; for(i=0; iN; i++){ /* lignes */ found=0; for(k=jptr[i]-1;k col) { break; } } if (!found) V[i]=0; printf(" V[%d] = %g \n",i, V[i]); } break; case DENSE : if(M->notranspose){ for(j=0; jN; j++) V[j] = M->F.a[(M->N)*col+j]; } else{ for(i=0; iN; i++){ for(j=0; jN; j++) V[j] = M->F.a[(M->N)*j+col]; } } break; } } void get_element_in_matrix (Matrix *M, int row, int col, double *V){ int k, i, *ai, *jptr ; double *a; int found; switch (M->T) { case SPARSE : /* csr_format transpose! donc la matrice arrivant dans cette routine doit bel et bien etre la transposee !!! */ if(M->changed){ csr_format (&M->S, M->N); restore_format (&M->S); M->changed = 0 ; } jptr = (int*) M->S.jptr->array; a = (double*) M->S.a->array; ai = (int*) M->S.ai->array; for(i=0; iN; i++){ /* lignes */ found=0; for(k=jptr[i]-1;k col) { break; } } if (!found) V[i]=0; printf(" V[%d] = %g \n",i, V[i]); } break; case DENSE : if(M->notranspose){ *V = M->F.a[(M->N)*col+row]; } else{ for(i=0; iN; i++){ *V = M->F.a[(M->N)*row+col]; } } break; } } /* ------------------------------------------------------------------------ */ /* S o l v e r p a r a m e t e r s */ /* ------------------------------------------------------------------------ */ static char comALGORITHM[] = "\n%s (Integer): \n\ - 1 CG Conjugate Gradient \n\ - 2 CGNR CG (Normal Residual equation) \n\ - 3 BCG Bi-Conjugate Gradient \n\ - 4 DBCG BCG with partial pivoting \n\ - 5 BCGSTAB BCG stabilized \n\ - 6 TFQMR Transpose-Free Quasi-Minimum Residual \n\ - 7 FOM Full Orthogonalization Method \n\ - 8 GMRES Generalized Minimum RESidual \n\ - 9 FGMRES Flexible version of GMRES \n\ - 10 DQGMRES Direct versions of GMRES \n\ - 11 LU LU Factorization \n\ - 12 PGMRES Alternative version of GMRES \n\ - default : %d\n"; static char comPRECONDITIONER[] = "\n%s (Integer): \n\ - 0 NONE No Factorization\n\ - 1 ILUT Incomplete LU factorization with dual truncation strategy \n\ - 2 ILUTP ILUT with column pivoting \n\ - 3 ILUD ILU with single dropping + diagonal compensation (~MILUT) \n\ - 4 ILUDP ILUD with column pivoting \n\ - 5 ILUK level-k ILU \n\ - 6 ILU0 simple ILU(0) preconditioning \n\ - 7 MILU0 MILU(0) preconditioning \n\ - 8 DIAGONAL \n\ - default : %d \n"; static char comPRECONDITIONER_POSITION[] = "\n%s (Integer): \n\ - 0 No Preconditioner \n\ - 1 Left Preconditioner \n\ - 2 Right Preconditioner \n\ - 3 Both Left and Right Preconditioner \n\ - default : %d \n"; static char comRENUMBERING_TECHNIQUE[] = "\n%s (Integer): \n\ - 0 No renumbering \n\ - 1 Reverse Cuthill-Mc Kee \n\ - default : %d \n"; static char comNB_ITER_MAX[] = "\n%s (Integer): Maximum number of iterations \n\ - default : %d \n"; static char comMATRIX_FORMAT[] = "\n%s (Integer): \n\ - 1 Sparse \n\ - 2 Full \n\ - default : %d\n"; static char comMATRIX_PRINTING[] = "\n%s (Integer): Disk write ('fort.*') \n\ - 1 matrix (csr) \n\ - 2 preconditioner (msr) \n\ - 3 both \n\ - default : %d\n"; static char comMATRIX_STORAGE[] = "\n%s (Integer): Disk Write or Read in internal format \n\ - 0 none \n\ - 1 write matrix (sparse) \n\ - 2 read matrix (sparse) \n\ - default : %d\n"; static char comNB_FILL[] = "\n%s (Integer): \n\ - ILUT/ILUTP : maximum number of elements per line \n\ of L and U (except diagonal element) \n\ - ILUK : each element whose fill-in level is greater than NB_FILL \n\ is dropped. \n\ - default : %d\n"; static char comKRYLOV_SIZE[] = "\n%s (Integer): Krylov subspace size \n\ - default : %d\n"; static char comSTOPPING_TEST[] = "\n%s (Real): Target relative residual \n\ - default : %g \n"; static char comIC_ACCELERATION[] = "\n%s (Real): IC accelerator\n\ - default : %g \n"; static char comITERATIVE_IMPROVEMENT[] = "\n%s (Integer): Iterative improvement of the solution obtained by a LU \n\ - default : %d\n"; static char comDROPPING_TOLERANCE[] = "\n%s (Real): \n\ - ILUT/ILUTP/ILUK: a(i,j) is dropped if \n\ abs(a(i,j)) < DROPPING_TOLERANCE * abs(diagonal element in U). \n\ - ILUD/ILUDP : a(i,j) is dropped if \n\ abs(a(i,j)) < DROPPING_TOLERANCE * [weighted norm of line i]. \n\ Weighted norm = 1-norm / number of nonzero elements on the line. \n\ - default : %g\n"; static char comPERMUTATION_TOLERANCE[] = "\n%s (Real): Tolerance for column permutation in ILUTP/ILUDP. \n\ At stage i, columns i and j are permuted if \n\ abs(a(i,j))*PERMUTATION_TOLERANCE > abs(a(i,i)). \n\ - 0 no permutations \n\ - 0.001 -> 0.1 classical \n\ - default : %g\n"; static char comRE_USE_LU[] = "\n%s (Integer): Reuse LU decomposition\n\ - 0 no \n\ - 1 yes \n\ - default : %d\n"; static char comRE_USE_ILU[] = "\n%s (Integer): Reuse ILU decomposition (and renumbering if any)\n\ - 0 no \n\ - 1 yes \n\ - default : %d\n"; static char comDIAGONAL_COMPENSATION[] = "\n%s (Real): ILUD/ILUDP: the term 'DIAGONAL_COMPENSATION * (sum \n\ of all dropped elements of the line)' is added to the diagonal element in U \n\ - 0 ~ ILU with threshold \n\ 1 ~ MILU with threshold. \n\ - default : %g\n"; static char comSCALING[] = "\n%s (Integer): Scale system \n\ - 0 no \n\ - 1 on basis of diagonal elements (no loss of possible symmetry) \n\ - 2 on basis of inf. norm of first rows and then columns (asymmetric) \n\ - 3 on basis of norm 1 of first rows and then columns (asymmetric) \n\ - 4 on basis of norm 2 of first rows and then columns (asymmetric) \n\ - default : %d\n"; /* ------------------------------------------------------------------------ */ /* A c t i o n s */ /* ------------------------------------------------------------------------ */ #define act_ARGS Solver_Params *p, int i, double d void actALGORITHM (act_ARGS){ p->Algorithm = i; } void actPRECONDITIONER (act_ARGS){ p->Preconditioner = i; } void actPRECONDITIONER_POSITION (act_ARGS){ p->Preconditioner_Position = i; } void actRENUMBERING_TECHNIQUE (act_ARGS){ p->Renumbering_Technique = i; } void actNB_ITER_MAX (act_ARGS){ p->Nb_Iter_Max = i; } void actMATRIX_FORMAT (act_ARGS){ p->Matrix_Format = i; } void actMATRIX_PRINTING (act_ARGS){ p->Matrix_Printing = i; } void actMATRIX_STORAGE (act_ARGS){ p->Matrix_Storage = i; } void actNB_FILL (act_ARGS){ p->Nb_Fill = i; } void actKRYLOV_SIZE (act_ARGS){ p->Krylov_Size = i; } void actSTOPPING_TEST (act_ARGS){ p->Stopping_Test = d; } void actIC_ACCELERATION (act_ARGS){ p->IC_Acceleration = d; } void actITERATIVE_IMPROVEMENT (act_ARGS){ p->Iterative_Improvement = i; } void actRE_USE_LU (act_ARGS){ p->Re_Use_LU = i; } void actDROPPING_TOLERANCE (act_ARGS){ p->Dropping_Tolerance = d; } void actPERMUTATION_TOLERANCE (act_ARGS){ p->Permutation_Tolerance = d; } void actRE_USE_ILU (act_ARGS){ p->Re_Use_ILU = i; } void actDIAGONAL_COMPENSATION (act_ARGS){ p->Diagonal_Compensation = d; } void actSCALING (act_ARGS){ p->Scaling = i; } /* ------------------------------------------------------------------------ */ /* P a r a m e t e r s w i t h d e f a u l t v a l u e s */ /* ------------------------------------------------------------------------ */ #define REEL 1 #define ENTIER 2 typedef struct { const char *str; int typeinfo; int defaultint; double defaultfloat; const char *com; void (*action) (Solver_Params *p , int i , double d); }InfoSolver; int compInfoSolver(const void *a, const void *b){ return(strcmp(((InfoSolver*)a)->str, ((InfoSolver*)b)->str)); } static InfoSolver Tab_Params[] = { {"Matrix_Format", ENTIER, 1, 0., comMATRIX_FORMAT, actMATRIX_FORMAT}, {"Matrix_Printing", ENTIER, 0, 0., comMATRIX_PRINTING, actMATRIX_PRINTING}, {"Matrix_Storage", ENTIER, 0, 0., comMATRIX_STORAGE, actMATRIX_STORAGE}, {"Scaling", ENTIER, 0, 0., comSCALING, actSCALING}, {"Renumbering_Technique", ENTIER, 1, 0., comRENUMBERING_TECHNIQUE, actRENUMBERING_TECHNIQUE}, {"Preconditioner", ENTIER, 2, 0., comPRECONDITIONER, actPRECONDITIONER}, {"Preconditioner_Position", ENTIER, 2, 0., comPRECONDITIONER_POSITION, actPRECONDITIONER_POSITION}, {"Nb_Fill", ENTIER, 20, 0., comNB_FILL, actNB_FILL}, {"Permutation_Tolerance", REEL, 0, 5.e-2, comPERMUTATION_TOLERANCE, actPERMUTATION_TOLERANCE}, {"Dropping_Tolerance", REEL, 0, 0., comDROPPING_TOLERANCE, actDROPPING_TOLERANCE}, {"Diagonal_Compensation", REEL, 0, 0., comDIAGONAL_COMPENSATION, actDIAGONAL_COMPENSATION}, {"Re_Use_ILU", ENTIER, 0, 0., comRE_USE_ILU, actRE_USE_ILU}, {"Algorithm", ENTIER, 8, 0., comALGORITHM, actALGORITHM}, {"Krylov_Size", ENTIER, 40, 0., comKRYLOV_SIZE, actKRYLOV_SIZE}, {"IC_Acceleration", REEL, 0, 1., comIC_ACCELERATION, actIC_ACCELERATION}, {"Re_Use_LU", ENTIER, 0, 0., comRE_USE_LU, actRE_USE_LU}, {"Iterative_Improvement", ENTIER, 0, 0., comITERATIVE_IMPROVEMENT, actITERATIVE_IMPROVEMENT}, {"Nb_Iter_Max", ENTIER, 1000, 0., comNB_ITER_MAX, actNB_ITER_MAX}, {"Stopping_Test", REEL, 0, 1.e-10,comSTOPPING_TEST, actSTOPPING_TEST} }; /* ------------------------------------------------------------------------ */ /* i n i t _ s o l v e r */ /* ------------------------------------------------------------------------ */ #define NbInfosSolver (int)(sizeof(Tab_Params)/sizeof(Tab_Params[0])) void Commentaires (FILE *out){ int i; InfoSolver *pI; for(i=0;itypeinfo){ case REEL : fprintf(out,pI->com,pI->str,pI->defaultfloat); break; case ENTIER : fprintf(out,pI->com,pI->str,pI->defaultint); break; } } fprintf(out,"\n"); } void init_solver (Solver_Params *p , const char *name){ char buff[128]; FILE *file; InfoSolver *pI,I; int i; double ff; int ii; for(i=0;iaction)(p,pI->defaultint,pI->defaultfloat); } if(!(file = fopen(name,"r"))){ file = fopen(name,"w"); fprintf(file,"/*\n"); Commentaires(file); fprintf(file,"*/\n\n"); Message::Info("Parameter file not found"); Message::Info("Enter parameter values:"); for(i=0;itypeinfo){ case REEL : getfloat : if(Message::UseSocket()) strcpy(buff, "\n"); else{ printf("%25s (Real) [=help, =%g]: ",pI->str,pI->defaultfloat); fgets(buff, 128, stdin); } if(!strcmp(buff,"h\n")){ printf(pI->com,pI->str,pI->defaultfloat); printf("\n"); goto getfloat; } if(!strcmp(buff,"\n")){ fprintf(file,"%25s %12g\n",pI->str,pI->defaultfloat); (pI->action)(p,pI->defaultint,pI->defaultfloat); } else{ fprintf(file,"%25s %12g\n",pI->str,atof(buff)); (pI->action)(p,pI->defaultint,atof(buff)); } break; case ENTIER : getint : if(Message::UseSocket()) strcpy(buff, "\n"); else{ printf("%25s (Integer) [=help, =%d]: ",pI->str,pI->defaultint); fgets(buff, 128, stdin); } if(!strcmp(buff,"h\n")){ printf(pI->com,pI->str,pI->defaultint); printf("\n"); goto getint; } if(!strcmp(buff,"\n")){ fprintf(file,"%25s %12d\n",pI->str,pI->defaultint); (pI->action)(p,pI->defaultint,pI->defaultfloat); } else{ fprintf(file,"%25s %12d\n",pI->str,atoi(buff)); (pI->action)(p,atoi(buff),pI->defaultfloat); } break; } } fclose(file); } else { qsort(Tab_Params, NbInfosSolver, sizeof(InfoSolver), compInfoSolver); rewind(file); while (!feof(file)){ fscanf(file,"%s",buff); I.str = buff; if(!(pI = (InfoSolver*)bsearch(&I,Tab_Params, NbInfosSolver, sizeof(InfoSolver),compInfoSolver))){ if(buff[0] == '/' && buff[1] == '*'){ while(1){ if(feof(file)){ Message::Warning("End of comment not detected"); fclose(file); return; } if((getc(file)=='*')&&(getc(file)=='/')){ break; } } } else{ Message::Warning("Unknown solver parameter '%s'", buff); fscanf(file,"%s",buff); } } else{ switch(pI->typeinfo){ case REEL : fscanf(file,"%lf",&ff); (pI->action)(p,ii,ff); break; case ENTIER : fscanf(file,"%d",&ii); (pI->action)(p,ii,ff); break; } } } } fclose(file); } void init_solver_option (Solver_Params *p , const char *name, const char *value){ InfoSolver *pI; int i, vali; float valf; for(i=0;istr, name)){ switch(pI->typeinfo){ case REEL : valf = atof(value); (pI->action)(p,pI->defaultint,valf); Message::Info("Overriding parameter '%s': %g", pI->str, valf); break; case ENTIER : vali = atoi(value); (pI->action)(p,vali,pI->defaultfloat); Message::Info("Overriding parameter '%s': %d", pI->str, vali); break; } return; } } Message::Error("Unknown solver parameter '%s'", name); } /* ------------------------------------------------------------------------ */ /* dynamic CSR format */ /* ------------------------------------------------------------------------ */ static int cmpij(int ai,int aj,int bi,int bj){ if(aibi)return 1; if(ajbj)return 1; return 0; } static int *alloc_ivec(long nl, long nh){ int *v; v=(int *)Malloc((size_t) ((nh-nl+1+1)*sizeof(int))); return v-nl+1; } static void free_ivec(int *v, long nl, long nh){ Free(v+nl-1); } #define SWAP(a,b) temp=(a);(a)=(b);(b)=temp; #define SWAPI(a,b) tempi=(a);(a)=(b);(b)=tempi; #define M 7 #define NSTACK 50 #define M1 -1 static void sort2(unsigned long n, double arr[], int ai[] , int aj []){ unsigned long i,ir=n,j,k,l=1; int *istack,jstack=0,tempi; double a,temp; int b,c; istack=alloc_ivec(1,NSTACK); for (;;) { if (ir-l < M) { for (j=l+1;j<=ir;j++) { a=arr[j M1]; b=ai[j M1]; c=aj[j M1]; for (i=j-1;i>=1;i--) { if (cmpij(ai[i M1],aj[i M1],b,c) <= 0) break; arr[i+1 M1]=arr[i M1]; ai[i+1 M1]=ai[i M1]; aj[i+1 M1]=aj[i M1]; } arr[i+1 M1]=a; ai[i+1 M1]=b; aj[i+1 M1]=c; } if (!jstack) { free_ivec(istack,1,NSTACK); return; } ir=istack[jstack]; l=istack[jstack-1]; jstack -= 2; } else { k=(l+ir) >> 1; SWAP(arr[k M1],arr[l+1 M1]) SWAPI(ai[k M1],ai[l+1 M1]) SWAPI(aj[k M1],aj[l+1 M1]) if (cmpij(ai[l+1 M1],aj[l+1 M1],ai[ir M1],aj[ir M1])>0){ SWAP(arr[l+1 M1],arr[ir M1]) SWAPI(ai[l+1 M1],ai[ir M1]) SWAPI(aj[l+1 M1],aj[ir M1]) } if (cmpij(ai[l M1],aj[l M1],ai[ir M1],aj[ir M1])>0){ SWAP(arr[l M1],arr[ir M1]) SWAPI(ai[l M1],ai[ir M1]) SWAPI(aj[l M1],aj[ir M1]) } if (cmpij(ai[l+1 M1],aj[l+1 M1],ai[l M1],aj[l M1])>0){ SWAP(arr[l+1 M1],arr[l M1]) SWAPI(ai[l+1 M1],ai[l M1]) SWAPI(aj[l+1 M1],aj[l M1]) } i=l+1; j=ir; a=arr[l M1]; b=ai[l M1]; c=aj[l M1]; for (;;) { do i++; while (cmpij(ai[i M1],aj[i M1],b,c) < 0); do j--; while (cmpij(ai[j M1],aj[j M1],b,c) > 0); if (j < i) break; SWAP(arr[i M1],arr[j M1]) SWAPI(ai[i M1],ai[j M1]) SWAPI(aj[i M1],aj[j M1]) } arr[l M1]=arr[j M1]; arr[j M1]=a; ai[l M1]=ai[j M1]; ai[j M1]=b; aj[l M1]=aj[j M1]; aj[j M1]=c; jstack += 2; if (jstack > NSTACK) { Message::Error("NSTACK too small in sort2"); } if (ir-i+1 >= j-l) { istack[jstack]=ir; istack[jstack-1]=i; ir=j-1; } else { istack[jstack]=j-1; istack[jstack-1]=l; l=i; } } } } #undef M #undef NSTACK #undef SWAP #undef SWAPI #undef M1 static void deblign ( int nz , int *ptr , int *jptr , int *ai){ int i,ilign; ilign = 1; jptr[0] = 1; for(i=1; iptr->array; jptr = (int*)MM->jptr->array; ai = (int*)MM->ai->array; a = (double*)MM->a->array; n = N; for(i=0;ia),a,ai,ptr); deblign(List_Nbr(MM->a),ptr,jptr,ai); jptr[N]=List_Nbr(MM->a)+1; } void restore_format (Sparse_Matrix *MM){ char *temp; temp = MM->ptr->array; MM->ptr->array = MM->ai->array; MM->ai->array = temp; } getdp-2.4.2-source/contrib/Sparskit/ilut.F000644 001750 001750 00000234426 11741264640 022144 0ustar00geuzainegeuzaine000000 000000 c $Id: ilut.F,v 1.2 2009-03-17 08:48:47 geuzaine Exp $ c----------------------------------------------------------------------c c The file has been renamed from ilut.f to ilut.F to permit c c preprocessing by 'cpp' c c The '-cpp' flag is not standard c c c c WARNING: the preprocessing is NOT done under AIX with the native C c c compiler -> you CANNOT use the -DHAVE_ILU_FLOAT option. c c----------------------------------------------------------------------c #ifndef HAVE_ILU_FLOAT #define scalar real*8 #else #define scalar real*4 #endif c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c ITERATIVE SOLVERS MODULE c c----------------------------------------------------------------------c c This Version Dated: August 13, 1996. Warning: meaning of some c c ============ arguments have changed w.r.t. earlier versions. Some c c Calling sequences may also have changed c c----------------------------------------------------------------------c c Contents: c c-------------------------preconditioners------------------------------c c c c ILUT : Incomplete LU factorization with dual truncation strategy c c ILUTP : ILUT with column pivoting c c ILUD : ILU with single dropping + diagonal compensation (~MILUT) c c ILUDP : ILUD with column pivoting c c ILUK : level-k ILU c c ILU0 : simple ILU(0) preconditioning c c MILU0 : MILU(0) preconditioning c c c c----------sample-accelerator-and-LU-solvers---------------------------c c c c PGMRES : preconditioned GMRES solver c c LUSOL : forward followed by backward triangular solve (Precond.) c c LUTSOL : solving v = (LU)^{-T} u (used for preconditioning) c c c c-------------------------utility-routine------------------------------c c c c QSPLIT : quick split routine used by ilut to sort out the k largest c c elements in absolute value c c c c----------------------------------------------------------------------c c c c Note: all preconditioners are preprocessors to pgmres. c c usage: call preconditioner then call pgmres c c c c----------------------------------------------------------------------c subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr) c----------------------------------------------------------------------- implicit none integer n real*8 a(*),w(n),droptol scalar alu(*) integer ja(*),ia(n+1),jlu(*),ju(n),jw(2*n),lfil,iwk,ierr c----------------------------------------------------------------------* c *** ILUT preconditioner *** * c incomplete LU factorization with dual truncation mechanism * c----------------------------------------------------------------------* c Author: Yousef Saad *May, 5, 1990, Latest revision, August 1996 * c----------------------------------------------------------------------* c PARAMETERS c----------- c c on entry: c========== c n = integer. The row dimension of the matrix A. The matrix c c a,ja,ia = matrix stored in Compressed Sparse Row format. c c lfil = integer. The fill-in parameter. Each row of L and each row c of U will have a maximum of lfil elements (excluding the c diagonal element). lfil must be .ge. 0. c ** WARNING: THE MEANING OF LFIL HAS CHANGED WITH RESPECT TO c EARLIER VERSIONS. c c droptol = real*8. Sets the threshold for dropping small terms in the c factorization. See below for details on dropping strategy. c c c iwk = integer. The lengths of arrays alu and jlu. If the arrays c are not big enough to store the ILU factorizations, ilut c will stop with an error message. c c On return: c=========== c c alu,jlu = matrix stored in Modified Sparse Row (MSR) format containing c the L and U factors together. The diagonal (stored in c alu(1:n) ) is inverted. Each i-th row of the alu,jlu matrix c contains the i-th row of L (excluding the diagonal entry=1) c followed by the i-th row of U. c c ju = integer array of length n containing the pointers to c the beginning of each row of U in the matrix alu,jlu. c c ierr = integer. Error message with the following meaning. c ierr = 0 --> successful return. c ierr .gt. 0 --> zero pivot encountered at step number ierr. c ierr = -1 --> Error. input matrix may be wrong. c (The elimination process has generated a c row in L or U whose length is .gt. n.) c ierr = -2 --> The matrix L overflows the array al. c ierr = -3 --> The matrix U overflows the array alu. c ierr = -4 --> Illegal value for lfil. c ierr = -5 --> zero row encountered. c c work arrays: c============= c jw = integer work array of length 2*n. c w = real work array of length n c c---------------------------------------------------------------------- c w, ju (1:n) store the working array [1:ii-1 = L-part, ii:n = u] c jw(n+1:2n) stores nonzero indicators c c Notes: c ------ c The diagonal elements of the input matrix must be nonzero (at least c 'structurally'). c c----------------------------------------------------------------------* c---- Dual drop strategy works as follows. * c * c 1) Theresholding in L and U as set by droptol. Any element whose * c magnitude is less than some tolerance (relative to the abs * c value of diagonal element in u) is dropped. * c * c 2) Keeping only the largest lfil elements in the i-th row of L * c and the largest lfil elements in the i-th row of U (excluding * c diagonal elements). * c * c Flexibility: one can use droptol=0 to get a strategy based on * c keeping the largest elements in each row of L and U. Taking * c droptol .ne. 0 but lfil=n will give the usual threshold strategy * c (however, fill-in is then mpredictible). * c----------------------------------------------------------------------* c locals integer ju0,k,j1,j2,j,ii,i,lenl,lenu,jj,jrow,jpos,len real*8 tnorm, t, abs, s, fact if (lfil .lt. 0) goto 998 c----------------------------------------------------------------------- c initialize ju0 (points to next element to be added to alu,jlu) c and pointer array. c----------------------------------------------------------------------- ju0 = n+2 jlu(1) = ju0 c c initialize nonzero indicator array. c do 1 j=1,n jw(n+j) = 0 1 continue c----------------------------------------------------------------------- c beginning of main loop. c----------------------------------------------------------------------- do 500 ii = 1, n j1 = ia(ii) j2 = ia(ii+1) - 1 tnorm = 0.0d0 do 501 k=j1,j2 tnorm = tnorm+abs(a(k)) 501 continue if (tnorm .eq. 0.0) goto 999 tnorm = tnorm/real(j2-j1+1) c c unpack L-part and U-part of row of A in arrays w c lenu = 1 lenl = 0 jw(ii) = ii w(ii) = 0.0 jw(n+ii) = ii c do 170 j = j1, j2 k = ja(j) t = a(j) if (k .lt. ii) then lenl = lenl+1 jw(lenl) = k w(lenl) = t jw(n+k) = lenl else if (k .eq. ii) then w(ii) = t else lenu = lenu+1 jpos = ii+lenu-1 jw(jpos) = k w(jpos) = t jw(n+k) = jpos endif 170 continue jj = 0 len = 0 c c eliminate previous rows c 150 jj = jj+1 if (jj .gt. lenl) goto 160 c----------------------------------------------------------------------- c in order to do the elimination in the correct order we must select c the smallest column index among jw(k), k=jj+1, ..., lenl. c----------------------------------------------------------------------- jrow = jw(jj) k = jj c c determine smallest column index c do 151 j=jj+1,lenl if (jw(j) .lt. jrow) then jrow = jw(j) k = j endif 151 continue c if (k .ne. jj) then c exchange in jw j = jw(jj) jw(jj) = jw(k) jw(k) = j c exchange in jr jw(n+jrow) = jj jw(n+j) = k c exchange in w s = w(jj) w(jj) = w(k) w(k) = s endif c c zero out element in row by setting jw(n+jrow) to zero. c jw(n+jrow) = 0 c c get the multiplier for row to be eliminated (jrow). c fact = w(jj)*alu(jrow) if (abs(fact) .le. droptol) goto 150 c c combine current row and row jrow c do 203 k = ju(jrow), jlu(jrow+1)-1 s = fact*alu(k) j = jlu(k) jpos = jw(n+j) if (j .ge. ii) then c c dealing with upper part. c if (jpos .eq. 0) then c c this is a fill-in element c lenu = lenu+1 if (lenu .gt. n) goto 995 i = ii+lenu-1 jw(i) = j jw(n+j) = i w(i) = - s else c c this is not a fill-in element c w(jpos) = w(jpos) - s endif else c c dealing with lower part. c if (jpos .eq. 0) then c c this is a fill-in element c lenl = lenl+1 if (lenl .gt. n) goto 995 jw(lenl) = j jw(n+j) = lenl w(lenl) = - s else c c this is not a fill-in element c w(jpos) = w(jpos) - s endif endif 203 continue c c store this pivot element -- (from left to right -- no danger of c overlap with the working elements in L (pivots). c len = len+1 w(len) = fact jw(len) = jrow goto 150 160 continue c c reset double-pointer to zero (U-part) c do 308 k=1, lenu jw(n+jw(ii+k-1)) = 0 308 continue c c update L-matrix c lenl = len len = min0(lenl,lfil) c c sort by quick-split c call qsplit (w,jw,lenl,len) c c store L-part c do 204 k=1, len if (ju0 .gt. iwk) goto 996 alu(ju0) = w(k) jlu(ju0) = jw(k) ju0 = ju0+1 204 continue c c save pointer to beginning of row ii of U c ju(ii) = ju0 c c update U-matrix -- first apply dropping strategy c len = 0 do k=1, lenu-1 if (abs(w(ii+k)) .gt. droptol*tnorm) then len = len+1 w(ii+len) = w(ii+k) jw(ii+len) = jw(ii+k) endif enddo lenu = len+1 len = min0(lenu,lfil) c call qsplit (w(ii+1), jw(ii+1), lenu-1,len) c c copy c t = abs(w(ii)) if (len + ju0 .gt. iwk) goto 997 do 302 k=ii+1,ii+len-1 jlu(ju0) = jw(k) alu(ju0) = w(k) t = t + abs(w(k) ) ju0 = ju0+1 302 continue c c store inverse of diagonal element of u c if (w(ii) .eq. 0.0) w(ii) = (0.0001 + droptol)*tnorm c alu(ii) = 1.0d0/ w(ii) c c update pointer to beginning of next row of U. c jlu(ii+1) = ju0 c----------------------------------------------------------------------- c end main loop c----------------------------------------------------------------------- 500 continue ierr = 0 return c c incomprehensible error. Matrix must be wrong. c 995 ierr = -1 return c c insufficient storage in L. c 996 ierr = -2 return c c insufficient storage in U. c 997 ierr = -3 return c c illegal lfil entered. c 998 ierr = -4 return c c zero row encountered c 999 ierr = -5 return c----------------end-of-ilut-------------------------------------------- c----------------------------------------------------------------------- end c---------------------------------------------------------------------- subroutine ilutp(n,a,ja,ia,lfil,droptol,permtol,mbloc,alu, * jlu,ju,iwk,w,jw,iperm,ierr) c----------------------------------------------------------------------- c implicit none integer n,ja(*),ia(n+1),lfil,jlu(*),ju(n),jw(2*n),iwk, * iperm(2*n),ierr scalar alu(*) real*8 a(*), w(n), droptol c----------------------------------------------------------------------* c *** ILUTP preconditioner -- ILUT with pivoting *** * c incomplete LU factorization with dual truncation mechanism * c----------------------------------------------------------------------* c author Yousef Saad *Sep 8, 1993 -- Latest revision, August 1996. * c----------------------------------------------------------------------* c on entry: c========== c n = integer. The dimension of the matrix A. c c a,ja,ia = matrix stored in Compressed Sparse Row format. c ON RETURN THE COLUMNS OF A ARE PERMUTED. SEE BELOW FOR c DETAILS. c c lfil = integer. The fill-in parameter. Each row of L and each row c of U will have a maximum of lfil elements (excluding the c diagonal element). lfil must be .ge. 0. c ** WARNING: THE MEANING OF LFIL HAS CHANGED WITH RESPECT TO c EARLIER VERSIONS. c c droptol = real*8. Sets the threshold for dropping small terms in the c factorization. See below for details on dropping strategy. c c lfil = integer. The fill-in parameter. Each row of L and c each row of U will have a maximum of lfil elements. c WARNING: THE MEANING OF LFIL HAS CHANGED WITH RESPECT TO c EARLIER VERSIONS. c lfil must be .ge. 0. c c permtol = tolerance ratio used to determne whether or not to permute c two columns. At step i columns i and j are permuted when c c abs(a(i,j))*permtol .gt. abs(a(i,i)) c c [0 --> never permute; good values 0.1 to 0.01] c c mbloc = if desired, permuting can be done only within the diagonal c blocks of size mbloc. Useful for PDE problems with several c degrees of freedom.. If feature not wanted take mbloc=n. c c c iwk = integer. The lengths of arrays alu and jlu. If the arrays c are not big enough to store the ILU factorizations, ilut c will stop with an error message. c c On return: c=========== c c alu,jlu = matrix stored in Modified Sparse Row (MSR) format containing c the L and U factors together. The diagonal (stored in c alu(1:n) ) is inverted. Each i-th row of the alu,jlu matrix c contains the i-th row of L (excluding the diagonal entry=1) c followed by the i-th row of U. c c ju = integer array of length n containing the pointers to c the beginning of each row of U in the matrix alu,jlu. c c iperm = contains the permutation arrays. c iperm(1:n) = old numbers of unknowns c iperm(n+1:2*n) = reverse permutation = new unknowns. c c ierr = integer. Error message with the following meaning. c ierr = 0 --> successful return. c ierr .gt. 0 --> zero pivot encountered at step number ierr. c ierr = -1 --> Error. input matrix may be wrong. c (The elimination process has generated a c row in L or U whose length is .gt. n.) c ierr = -2 --> The matrix L overflows the array al. c ierr = -3 --> The matrix U overflows the array alu. c ierr = -4 --> Illegal value for lfil. c ierr = -5 --> zero row encountered. c c work arrays: c============= c jw = integer work array of length 2*n. c w = real work array of length n c c IMPORTANR NOTE: c -------------- c TO AVOID PERMUTING THE SOLUTION VECTORS ARRAYS FOR EACH LU-SOLVE, C THE MATRIX A IS PERMUTED ON RETURN. [all column indices are c changed]. SIMILARLY FOR THE U MATRIX. c To permute the matrix back to its original state use the loop: c c do k=ia(1), ia(n+1)-1 c ja(k) = iperm(ja(k)) c enddo c c----------------------------------------------------------------------- c local variables c integer k,i,j,jrow,ju0,ii,j1,j2,jpos,len,imax,lenu,lenl,jj,mbloc, * icut real*8 s, tmp, tnorm,xmax,xmax0, fact, abs, t, permtol c if (lfil .lt. 0) goto 998 c----------------------------------------------------------------------- c initialize ju0 (points to next element to be added to alu,jlu) c and pointer array. c----------------------------------------------------------------------- ju0 = n+2 jlu(1) = ju0 c c integer double pointer array. c do 1 j=1, n jw(n+j) = 0 iperm(j) = j iperm(n+j) = j 1 continue c----------------------------------------------------------------------- c beginning of main loop. c----------------------------------------------------------------------- do 500 ii = 1, n c c avancement de l'ilutp c if (mod(ii/1000) .eq. 0) c write(*, '(A1,$)') '*' c c j1 = ia(ii) j2 = ia(ii+1) - 1 tnorm = 0.0d0 do 501 k=j1,j2 tnorm = tnorm+abs(a(k)) 501 continue if (tnorm .eq. 0.0) goto 999 tnorm = tnorm/(j2-j1+1) c c unpack L-part and U-part of row of A in arrays w -- c lenu = 1 lenl = 0 jw(ii) = ii w(ii) = 0.0 jw(n+ii) = ii c do 170 j = j1, j2 k = iperm(n+ja(j)) t = a(j) if (k .lt. ii) then lenl = lenl+1 jw(lenl) = k w(lenl) = t jw(n+k) = lenl else if (k .eq. ii) then w(ii) = t else lenu = lenu+1 jpos = ii+lenu-1 jw(jpos) = k w(jpos) = t jw(n+k) = jpos endif 170 continue jj = 0 len = 0 c c eliminate previous rows c 150 jj = jj+1 if (jj .gt. lenl) goto 160 c----------------------------------------------------------------------- c in order to do the elimination in the correct order we must select c the smallest column index among jw(k), k=jj+1, ..., lenl. c----------------------------------------------------------------------- jrow = jw(jj) k = jj c c determine smallest column index c do 151 j=jj+1,lenl if (jw(j) .lt. jrow) then jrow = jw(j) k = j endif 151 continue c if (k .ne. jj) then c exchange in jw j = jw(jj) jw(jj) = jw(k) jw(k) = j c exchange in jr jw(n+jrow) = jj jw(n+j) = k c exchange in w s = w(jj) w(jj) = w(k) w(k) = s endif c c zero out element in row by resetting jw(n+jrow) to zero. c jw(n+jrow) = 0 c c get the multiplier for row to be eliminated: jrow c fact = w(jj)*alu(jrow) c c drop term if small c if (abs(fact) .le. droptol) goto 150 c c combine current row and row jrow c do 203 k = ju(jrow), jlu(jrow+1)-1 s = fact*alu(k) c new column number j = iperm(n+jlu(k)) jpos = jw(n+j) if (j .ge. ii) then c c dealing with upper part. c if (jpos .eq. 0) then c c this is a fill-in element c lenu = lenu+1 i = ii+lenu-1 if (lenu .gt. n) goto 995 jw(i) = j jw(n+j) = i w(i) = - s else c no fill-in element -- w(jpos) = w(jpos) - s endif else c c dealing with lower part. c if (jpos .eq. 0) then c c this is a fill-in element c lenl = lenl+1 if (lenl .gt. n) goto 995 jw(lenl) = j jw(n+j) = lenl w(lenl) = - s else c c this is not a fill-in element c w(jpos) = w(jpos) - s endif endif 203 continue c c store this pivot element -- (from left to right -- no danger of c overlap with the working elements in L (pivots). c len = len+1 w(len) = fact jw(len) = jrow goto 150 160 continue c c reset double-pointer to zero (U-part) c do 308 k=1, lenu jw(n+jw(ii+k-1)) = 0 308 continue c c update L-matrix c lenl = len len = min0(lenl,lfil) c c sort by quick-split c call qsplit (w,jw,lenl,len) c c store L-part -- in original coordinates .. c do 204 k=1, len if (ju0 .gt. iwk) goto 996 alu(ju0) = w(k) jlu(ju0) = iperm(jw(k)) ju0 = ju0+1 204 continue c c save pointer to beginning of row ii of U c ju(ii) = ju0 c c update U-matrix -- first apply dropping strategy c len = 0 do k=1, lenu-1 if (abs(w(ii+k)) .gt. droptol*tnorm) then len = len+1 w(ii+len) = w(ii+k) jw(ii+len) = jw(ii+k) endif enddo lenu = len+1 len = min0(lenu,lfil) call qsplit (w(ii+1), jw(ii+1), lenu-1,len) c c determine next pivot -- c imax = ii xmax = abs(w(imax)) xmax0 = xmax icut = ii - 1 + mbloc - mod(ii-1,mbloc) do k=ii+1,ii+len-1 t = abs(w(k)) if (t .gt. xmax .and. t*permtol .gt. xmax0 .and. * jw(k) .le. icut) then imax = k xmax = t endif enddo c c exchange w's c tmp = w(ii) w(ii) = w(imax) w(imax) = tmp c c update iperm and reverse iperm c j = jw(imax) i = iperm(ii) iperm(ii) = iperm(j) iperm(j) = i c c reverse iperm c iperm(n+iperm(ii)) = ii iperm(n+iperm(j)) = j c----------------------------------------------------------------------- c if (len + ju0 .gt. iwk) goto 997 c c copy U-part in original coordinates c do 302 k=ii+1,ii+len-1 jlu(ju0) = iperm(jw(k)) alu(ju0) = w(k) ju0 = ju0+1 302 continue c c store inverse of diagonal element of u c if (w(ii) .eq. 0.0) w(ii) = (1.0D-4 + droptol)*tnorm alu(ii) = 1.0d0/ w(ii) c c update pointer to beginning of next row of U. c jlu(ii+1) = ju0 c----------------------------------------------------------------------- c end main loop c----------------------------------------------------------------------- 500 continue c c permute all column indices of LU ... c do k = jlu(1),jlu(n+1)-1 jlu(k) = iperm(n+jlu(k)) enddo c c ...and of A c do k=ia(1), ia(n+1)-1 ja(k) = iperm(n+ja(k)) enddo c ierr = 0 return c c incomprehensible error. Matrix must be wrong. c 995 ierr = -1 return c c insufficient storage in L. c 996 ierr = -2 return c c insufficient storage in U. c 997 ierr = -3 return c c illegal lfil entered. c 998 ierr = -4 return c c zero row encountered c 999 ierr = -5 return c----------------end-of-ilutp------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine ilud(n,a,ja,ia,alph,tol,alu,jlu,ju,iwk,w,jw,ierr) c----------------------------------------------------------------------- implicit none integer n scalar alu(*) real*8 a(*),w(2*n),tol, alph integer ja(*),ia(n+1),jlu(*),ju(n),jw(2*n),iwk,ierr c----------------------------------------------------------------------* c *** ILUD preconditioner *** * c incomplete LU factorization with standard droppoing strategy * c----------------------------------------------------------------------* c Author: Yousef Saad * Aug. 1995 -- * c----------------------------------------------------------------------* c This routine computes the ILU factorization with standard threshold * c dropping: at i-th step of elimination, an element a(i,j) in row i is * c dropped if it satisfies the criterion: * c * c abs(a(i,j)) < tol * [average magnitude of elements in row i of A] * c * c There is no control on memory size required for the factors as is * c done in ILUT. This routines computes also various diagonal compensa- * c tion ILU's such MILU. These are defined through the parameter alph * c----------------------------------------------------------------------* c on entry: c========== c n = integer. The row dimension of the matrix A. The matrix c c a,ja,ia = matrix stored in Compressed Sparse Row format c c alph = diagonal compensation parameter -- the term: c c alph*(sum of all dropped out elements in a given row) c c is added to the diagonal element of U of the factorization c Thus: alph = 0 ---> ~ ILU with threshold, c alph = 1 ---> ~ MILU with threshold. c c tol = Threshold parameter for dropping small terms in the c factorization. During the elimination, a term a(i,j) is c dropped whenever abs(a(i,j)) .lt. tol * [weighted norm of c row i]. Here weighted norm = 1-norm / number of nnz c elements in the row. c c iwk = The length of arrays alu and jlu -- this routine will stop c if storage for the factors L and U is not sufficient c c On return: c=========== c c alu,jlu = matrix stored in Modified Sparse Row (MSR) format containing c the L and U factors together. The diagonal (stored in c alu(1:n) ) is inverted. Each i-th row of the alu,jlu matrix c contains the i-th row of L (excluding the diagonal entry=1) c followed by the i-th row of U. c c ju = integer array of length n containing the pointers to c the beginning of each row of U in the matrix alu,jlu. c c ierr = integer. Error message with the following meaning. c ierr = 0 --> successful return. c ierr .gt. 0 --> zero pivot encountered at step number ierr. c ierr = -1 --> Error. input matrix may be wrong. c (The elimination process has generated a c row in L or U whose length is .gt. n.) c ierr = -2 --> Insufficient storage for the LU factors -- c arrays alu/ jalu are overflowed. c ierr = -3 --> Zero row encountered. c c Work Arrays: c============= c jw = integer work array of length 2*n. c w = real work array of length n c c---------------------------------------------------------------------- c c w, ju (1:n) store the working array [1:ii-1 = L-part, ii:n = u] c jw(n+1:2n) stores the nonzero indicator. c c Notes: c ------ c All diagonal elements of the input matrix must be nonzero. c c----------------------------------------------------------------------- c locals integer ju0,k,j1,j2,j,ii,i,lenl,lenu,jj,jrow,jpos,len real*8 tnorm, t, abs, s, fact, dropsum c----------------------------------------------------------------------- c initialize ju0 (points to next element to be added to alu,jlu) c and pointer array. c----------------------------------------------------------------------- ju0 = n+2 jlu(1) = ju0 c c initialize nonzero indicator array. c do 1 j=1,n jw(n+j) = 0 1 continue c----------------------------------------------------------------------- c beginning of main loop. c----------------------------------------------------------------------- do 500 ii = 1, n j1 = ia(ii) j2 = ia(ii+1) - 1 dropsum = 0.0d0 tnorm = 0.0d0 do 501 k=j1,j2 tnorm = tnorm + abs(a(k)) 501 continue if (tnorm .eq. 0.0) goto 997 tnorm = tnorm / real(j2-j1+1) c c unpack L-part and U-part of row of A in arrays w c lenu = 1 lenl = 0 jw(ii) = ii w(ii) = 0.0 jw(n+ii) = ii c do 170 j = j1, j2 k = ja(j) t = a(j) if (k .lt. ii) then lenl = lenl+1 jw(lenl) = k w(lenl) = t jw(n+k) = lenl else if (k .eq. ii) then w(ii) = t else lenu = lenu+1 jpos = ii+lenu-1 jw(jpos) = k w(jpos) = t jw(n+k) = jpos endif 170 continue jj = 0 len = 0 c c eliminate previous rows c 150 jj = jj+1 if (jj .gt. lenl) goto 160 c----------------------------------------------------------------------- c in order to do the elimination in the correct order we must select c the smallest column index among jw(k), k=jj+1, ..., lenl. c----------------------------------------------------------------------- jrow = jw(jj) k = jj c c determine smallest column index c do 151 j=jj+1,lenl if (jw(j) .lt. jrow) then jrow = jw(j) k = j endif 151 continue c if (k .ne. jj) then c exchange in jw j = jw(jj) jw(jj) = jw(k) jw(k) = j c exchange in jr jw(n+jrow) = jj jw(n+j) = k c exchange in w s = w(jj) w(jj) = w(k) w(k) = s endif c c zero out element in row by setting resetting jw(n+jrow) to zero. c jw(n+jrow) = 0 c c drop term if small c c if (abs(w(jj)) .le. tol*tnorm) then c dropsum = dropsum + w(jj) c goto 150 c endif c c get the multiplier for row to be eliminated (jrow). c fact = w(jj)*alu(jrow) c c drop term if small c if (abs(fact) .le. tol) then dropsum = dropsum + w(jj) goto 150 endif c c combine current row and row jrow c do 203 k = ju(jrow), jlu(jrow+1)-1 s = fact*alu(k) j = jlu(k) jpos = jw(n+j) if (j .ge. ii) then c c dealing with upper part. c if (jpos .eq. 0) then c c this is a fill-in element c lenu = lenu+1 if (lenu .gt. n) goto 995 i = ii+lenu-1 jw(i) = j jw(n+j) = i w(i) = - s else c c this is not a fill-in element c w(jpos) = w(jpos) - s endif else c c dealing with lower part. c if (jpos .eq. 0) then c c this is a fill-in element c lenl = lenl+1 if (lenl .gt. n) goto 995 jw(lenl) = j jw(n+j) = lenl w(lenl) = - s else c c this is not a fill-in element c w(jpos) = w(jpos) - s endif endif 203 continue len = len+1 w(len) = fact jw(len) = jrow goto 150 160 continue c c reset double-pointer to zero (For U-part only) c do 308 k=1, lenu jw(n+jw(ii+k-1)) = 0 308 continue c c update l-matrix c do 204 k=1, len if (ju0 .gt. iwk) goto 996 alu(ju0) = w(k) jlu(ju0) = jw(k) ju0 = ju0+1 204 continue c c save pointer to beginning of row ii of U c ju(ii) = ju0 c c go through elements in U-part of w to determine elements to keep c len = 0 do k=1, lenu-1 c if (abs(w(ii+k)) .gt. tnorm*tol) then if (abs(w(ii+k)) .gt. abs(w(ii))*tol) then len = len+1 w(ii+len) = w(ii+k) jw(ii+len) = jw(ii+k) else dropsum = dropsum + w(ii+k) endif enddo c c now update u-matrix c if (ju0 + len-1 .gt. iwk) goto 996 do 302 k=ii+1,ii+len jlu(ju0) = jw(k) alu(ju0) = w(k) ju0 = ju0+1 302 continue c c define diagonal element c w(ii) = w(ii) + alph*dropsum c c store inverse of diagonal element of u c if (w(ii) .eq. 0.0) w(ii) = (0.0001 + tol)*tnorm c alu(ii) = 1.0d0/ w(ii) c c update pointer to beginning of next row of U. c jlu(ii+1) = ju0 c----------------------------------------------------------------------- c end main loop c----------------------------------------------------------------------- 500 continue ierr = 0 return c c incomprehensible error. Matrix must be wrong. c 995 ierr = -1 return c c insufficient storage in alu/ jlu arrays for L / U factors c 996 ierr = -2 return c c zero row encountered c 997 ierr = -3 return c----------------end-of-ilud ------------------------------------------ c----------------------------------------------------------------------- end c---------------------------------------------------------------------- subroutine iludp(n,a,ja,ia,alph,droptol,permtol,mbloc,alu, * jlu,ju,iwk,w,jw,iperm,ierr) c----------------------------------------------------------------------- implicit none integer n,ja(*),ia(n+1),mbloc,jlu(*),ju(n),jw(2*n),iwk, * iperm(2*n),ierr scalar alu(*) real*8 a(*), w(2*n), alph, droptol, permtol c----------------------------------------------------------------------* c *** ILUDP preconditioner *** * c incomplete LU factorization with standard droppoing strategy * c and column pivoting * c----------------------------------------------------------------------* c author Yousef Saad -- Aug 1995. * c----------------------------------------------------------------------* c on entry: c========== c n = integer. The dimension of the matrix A. c c a,ja,ia = matrix stored in Compressed Sparse Row format. c ON RETURN THE COLUMNS OF A ARE PERMUTED. c c alph = diagonal compensation parameter -- the term: c c alph*(sum of all dropped out elements in a given row) c c is added to the diagonal element of U of the factorization c Thus: alph = 0 ---> ~ ILU with threshold, c alph = 1 ---> ~ MILU with threshold. c c droptol = tolerance used for dropping elements in L and U. c elements are dropped if they are .lt. norm(row) x droptol c row = row being eliminated c c permtol = tolerance ratio used for determning whether to permute c two columns. Two columns are permuted only when c abs(a(i,j))*permtol .gt. abs(a(i,i)) c [0 --> never permute; good values 0.1 to 0.01] c c mbloc = if desired, permuting can be done only within the diagonal c blocks of size mbloc. Useful for PDE problems with several c degrees of freedom.. If feature not wanted take mbloc=n. c c iwk = integer. The declared lengths of arrays alu and jlu c if iwk is not large enough the code will stop prematurely c with ierr = -2 or ierr = -3 (see below). c c On return: c=========== c c alu,jlu = matrix stored in Modified Sparse Row (MSR) format containing c the L and U factors together. The diagonal (stored in c alu(1:n) ) is inverted. Each i-th row of the alu,jlu matrix c contains the i-th row of L (excluding the diagonal entry=1) c followed by the i-th row of U. c c ju = integer array of length n containing the pointers to c the beginning of each row of U in the matrix alu,jlu. c iperm = contains the permutation arrays .. c iperm(1:n) = old numbers of unknowns c iperm(n+1:2*n) = reverse permutation = new unknowns. c c ierr = integer. Error message with the following meaning. c ierr = 0 --> successful return. c ierr .gt. 0 --> zero pivot encountered at step number ierr. c ierr = -1 --> Error. input matrix may be wrong. c (The elimination process has generated a c row in L or U whose length is .gt. n.) c ierr = -2 --> The L/U matrix overflows the arrays alu,jlu c ierr = -3 --> zero row encountered. c c work arrays: c============= c jw = integer work array of length 2*n. c w = real work array of length 2*n c c Notes: c ------ c IMPORTANT: TO AVOID PERMUTING THE SOLUTION VECTORS ARRAYS FOR EACH c LU-SOLVE, THE MATRIX A IS PERMUTED ON RETURN. [all column indices are c changed]. SIMILARLY FOR THE U MATRIX. c To permute the matrix back to its original state use the loop: c c do k=ia(1), ia(n+1)-1 c ja(k) = perm(ja(k)) c enddo c c----------------------------------------------------------------------- c local variables c integer k,i,j,jrow,ju0,ii,j1,j2,jpos,len,imax,lenu,lenl,jj,icut real*8 s,tmp,tnorm,xmax,xmax0,fact,abs,t,dropsum c----------------------------------------------------------------------- c initialize ju0 (points to next element to be added to alu,jlu) c and pointer array. c----------------------------------------------------------------------- ju0 = n+2 jlu(1) = ju0 c c integer double pointer array. c do 1 j=1,n jw(n+j) = 0 iperm(j) = j iperm(n+j) = j 1 continue c----------------------------------------------------------------------- c beginning of main loop. c----------------------------------------------------------------------- do 500 ii = 1, n j1 = ia(ii) j2 = ia(ii+1) - 1 dropsum = 0.0d0 tnorm = 0.0d0 do 501 k=j1,j2 tnorm = tnorm+abs(a(k)) 501 continue if (tnorm .eq. 0.0) goto 997 tnorm = tnorm/(j2-j1+1) c c unpack L-part and U-part of row of A in arrays w -- c lenu = 1 lenl = 0 jw(ii) = ii w(ii) = 0.0 jw(n+ii) = ii c do 170 j = j1, j2 k = iperm(n+ja(j)) t = a(j) if (k .lt. ii) then lenl = lenl+1 jw(lenl) = k w(lenl) = t jw(n+k) = lenl else if (k .eq. ii) then w(ii) = t else lenu = lenu+1 jpos = ii+lenu-1 jw(jpos) = k w(jpos) = t jw(n+k) = jpos endif 170 continue jj = 0 len = 0 c c eliminate previous rows c 150 jj = jj+1 if (jj .gt. lenl) goto 160 c----------------------------------------------------------------------- c in order to do the elimination in the correct order we must select c the smallest column index among jw(k), k=jj+1, ..., lenl. c----------------------------------------------------------------------- jrow = jw(jj) k = jj c c determine smallest column index c do 151 j=jj+1,lenl if (jw(j) .lt. jrow) then jrow = jw(j) k = j endif 151 continue c if (k .ne. jj) then c exchange in jw j = jw(jj) jw(jj) = jw(k) jw(k) = j c exchange in jr jw(n+jrow) = jj jw(n+j) = k c exchange in w s = w(jj) w(jj) = w(k) w(k) = s endif c c zero out element in row by resetting jw(n+jrow) to zero. c jw(n+jrow) = 0 c c drop term if small c if (abs(w(jj)) .le. droptol*tnorm) then dropsum = dropsum + w(jj) goto 150 endif c c get the multiplier for row to be eliminated: jrow c fact = w(jj)*alu(jrow) c c combine current row and row jrow c do 203 k = ju(jrow), jlu(jrow+1)-1 s = fact*alu(k) c new column number j = iperm(n+jlu(k)) jpos = jw(n+j) c c if fill-in element is small then disregard: c if (j .ge. ii) then c c dealing with upper part. c if (jpos .eq. 0) then c this is a fill-in element lenu = lenu+1 i = ii+lenu-1 if (lenu .gt. n) goto 995 jw(i) = j jw(n+j) = i w(i) = - s else c no fill-in element -- w(jpos) = w(jpos) - s endif else c c dealing with lower part. c if (jpos .eq. 0) then c this is a fill-in element lenl = lenl+1 if (lenl .gt. n) goto 995 jw(lenl) = j jw(n+j) = lenl w(lenl) = - s else c no fill-in element -- w(jpos) = w(jpos) - s endif endif 203 continue len = len+1 w(len) = fact jw(len) = jrow goto 150 160 continue c c reset double-pointer to zero (U-part) c do 308 k=1, lenu jw(n+jw(ii+k-1)) = 0 308 continue c c update L-matrix c do 204 k=1, len if (ju0 .gt. iwk) goto 996 alu(ju0) = w(k) jlu(ju0) = iperm(jw(k)) ju0 = ju0+1 204 continue c c save pointer to beginning of row ii of U c ju(ii) = ju0 c c update u-matrix -- first apply dropping strategy c len = 0 do k=1, lenu-1 if (abs(w(ii+k)) .gt. tnorm*droptol) then len = len+1 w(ii+len) = w(ii+k) jw(ii+len) = jw(ii+k) else dropsum = dropsum + w(ii+k) endif enddo c imax = ii xmax = abs(w(imax)) xmax0 = xmax icut = ii - 1 + mbloc - mod(ii-1,mbloc) c c determine next pivot -- c do k=ii+1,ii+len t = abs(w(k)) if (t .gt. xmax .and. t*permtol .gt. xmax0 .and. * jw(k) .le. icut) then imax = k xmax = t endif enddo c c exchange w's c tmp = w(ii) w(ii) = w(imax) w(imax) = tmp c c update iperm and reverse iperm c j = jw(imax) i = iperm(ii) iperm(ii) = iperm(j) iperm(j) = i c reverse iperm iperm(n+iperm(ii)) = ii iperm(n+iperm(j)) = j c----------------------------------------------------------------------- if (len + ju0-1 .gt. iwk) goto 996 c c copy U-part in original coordinates c do 302 k=ii+1,ii+len jlu(ju0) = iperm(jw(k)) alu(ju0) = w(k) ju0 = ju0+1 302 continue c c define diagonal element c w(ii) = w(ii) + alph*dropsum c c store inverse of diagonal element of u c if (w(ii) .eq. 0.0) w(ii) = (1.0D-4 + droptol)*tnorm c alu(ii) = 1.0d0/ w(ii) c c update pointer to beginning of next row of U. c jlu(ii+1) = ju0 c----------------------------------------------------------------------- c end main loop c----------------------------------------------------------------------- 500 continue c c permute all column indices of LU ... c do k = jlu(1),jlu(n+1)-1 jlu(k) = iperm(n+jlu(k)) enddo c c ...and of A c do k=ia(1), ia(n+1)-1 ja(k) = iperm(n+ja(k)) enddo c ierr = 0 return c c incomprehensible error. Matrix must be wrong. c 995 ierr = -1 return c c insufficient storage in arrays alu, jlu to store factors c 996 ierr = -2 return c c zero row encountered c 997 ierr = -3 return c----------------end-of-iludp------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine iluk(n,a,ja,ia,lfil,alu,jlu,ju,levs,iwk,w,jw,ierr) implicit none integer n scalar alu(*) real*8 a(*),w(n) integer ja(*),ia(n+1),jlu(*),ju(n),levs(*),jw(3*n),lfil,iwk,ierr c----------------------------------------------------------------------* c SPARSKIT ROUTINE ILUK -- ILU WITH LEVEL OF FILL-IN OF K (ILU(k)) * c----------------------------------------------------------------------* c c on entry: c========== c n = integer. The row dimension of the matrix A. The matrix c c a,ja,ia = matrix stored in Compressed Sparse Row format. c c lfil = integer. The fill-in parameter. Each element whose c leve-of-fill exceeds lfil during the ILU process is dropped. c lfil must be .ge. 0 c c tol = real*8. Sets the threshold for dropping small terms in the c factorization. See below for details on dropping strategy. c c iwk = integer. The minimum length of arrays alu, jlu, and levs. c c On return: c=========== c c alu,jlu = matrix stored in Modified Sparse Row (MSR) format containing c the L and U factors together. The diagonal (stored in c alu(1:n) ) is inverted. Each i-th row of the alu,jlu matrix c contains the i-th row of L (excluding the diagonal entry=1) c followed by the i-th row of U. c c ju = integer array of length n containing the pointers to c the beginning of each row of U in the matrix alu,jlu. c c levs = integer (work) array of size iwk -- which contains the c levels of each element in alu, jlu. c c ierr = integer. Error message with the following meaning. c ierr = 0 --> successful return. c ierr .gt. 0 --> zero pivot encountered at step number ierr. c ierr = -1 --> Error. input matrix may be wrong. c (The elimination process has generated a c row in L or U whose length is .gt. n.) c ierr = -2 --> The matrix L overflows the array al. c ierr = -3 --> The matrix U overflows the array alu. c ierr = -4 --> Illegal value for lfil. c ierr = -5 --> zero row encountered in A or U. c c work arrays: c============= c jw = integer work array of length 3*n. c w = real work array of length n c c Notes/known bugs: This is not implemented efficiently storage-wise. c For example: Only the part of the array levs(*) associated with c the U-matrix is needed in the routine.. So some storage can c be saved if needed. The levels of fills in the LU matrix are c output for information only -- they are not needed by LU-solve. c c---------------------------------------------------------------------- c w, ju (1:n) store the working array [1:ii-1 = L-part, ii:n = u] c jw(n+1:2n) stores the nonzero indicator. c c Notes: c ------ c All the diagonal elements of the input matrix must be nonzero. c c----------------------------------------------------------------------* c locals integer ju0,k,j1,j2,j,ii,i,lenl,lenu,jj,jrow,jpos,n2, * jlev, min real*8 t, s, fact if (lfil .lt. 0) goto 998 c----------------------------------------------------------------------- c initialize ju0 (points to next element to be added to alu,jlu) c and pointer array. c----------------------------------------------------------------------- n2 = n+n ju0 = n+2 jlu(1) = ju0 c c initialize nonzero indicator array + levs array -- c do 1 j=1,2*n jw(j) = 0 1 continue c----------------------------------------------------------------------- c beginning of main loop. c----------------------------------------------------------------------- do 500 ii = 1, n j1 = ia(ii) j2 = ia(ii+1) - 1 c c unpack L-part and U-part of row of A in arrays w c lenu = 1 lenl = 0 jw(ii) = ii w(ii) = 0.0 jw(n+ii) = ii c do 170 j = j1, j2 k = ja(j) t = a(j) if (t .eq. 0.0) goto 170 if (k .lt. ii) then lenl = lenl+1 jw(lenl) = k w(lenl) = t jw(n2+lenl) = 0 jw(n+k) = lenl else if (k .eq. ii) then w(ii) = t jw(n2+ii) = 0 else lenu = lenu+1 jpos = ii+lenu-1 jw(jpos) = k w(jpos) = t jw(n2+jpos) = 0 jw(n+k) = jpos endif 170 continue c jj = 0 c c eliminate previous rows c 150 jj = jj+1 if (jj .gt. lenl) goto 160 c----------------------------------------------------------------------- c in order to do the elimination in the correct order we must select c the smallest column index among jw(k), k=jj+1, ..., lenl. c----------------------------------------------------------------------- jrow = jw(jj) k = jj c c determine smallest column index c do 151 j=jj+1,lenl if (jw(j) .lt. jrow) then jrow = jw(j) k = j endif 151 continue c if (k .ne. jj) then c exchange in jw j = jw(jj) jw(jj) = jw(k) jw(k) = j c exchange in jw(n+ (pointers/ nonzero indicator). jw(n+jrow) = jj jw(n+j) = k c exchange in jw(n2+ (levels) j = jw(n2+jj) jw(n2+jj) = jw(n2+k) jw(n2+k) = j c exchange in w s = w(jj) w(jj) = w(k) w(k) = s endif c c zero out element in row by resetting jw(n+jrow) to zero. c jw(n+jrow) = 0 c c get the multiplier for row to be eliminated (jrow) + its level c fact = w(jj)*alu(jrow) jlev = jw(n2+jj) if (jlev .gt. lfil) goto 150 c c combine current row and row jrow c do 203 k = ju(jrow), jlu(jrow+1)-1 s = fact*alu(k) j = jlu(k) jpos = jw(n+j) if (j .ge. ii) then c c dealing with upper part. c if (jpos .eq. 0) then c c this is a fill-in element c lenu = lenu+1 if (lenu .gt. n) goto 995 i = ii+lenu-1 jw(i) = j jw(n+j) = i w(i) = - s jw(n2+i) = jlev+levs(k)+1 else c c this is not a fill-in element c w(jpos) = w(jpos) - s jw(n2+jpos) = min(jw(n2+jpos),jlev+levs(k)+1) endif else c c dealing with lower part. c if (jpos .eq. 0) then c c this is a fill-in element c lenl = lenl+1 if (lenl .gt. n) goto 995 jw(lenl) = j jw(n+j) = lenl w(lenl) = - s jw(n2+lenl) = jlev+levs(k)+1 else c c this is not a fill-in element c w(jpos) = w(jpos) - s jw(n2+jpos) = min(jw(n2+jpos),jlev+levs(k)+1) endif endif 203 continue w(jj) = fact jw(jj) = jrow goto 150 160 continue c c reset double-pointer to zero (U-part) c do 308 k=1, lenu jw(n+jw(ii+k-1)) = 0 308 continue c c update l-matrix c do 204 k=1, lenl if (ju0 .gt. iwk) goto 996 if (jw(n2+k) .le. lfil) then alu(ju0) = w(k) jlu(ju0) = jw(k) ju0 = ju0+1 endif 204 continue c c save pointer to beginning of row ii of U c ju(ii) = ju0 c c update u-matrix c do 302 k=ii+1,ii+lenu-1 c oups: who suppressed the following test in getdp < 0.81? if (ju0 .gt. iwk) goto 997 if (jw(n2+k) .le. lfil) then jlu(ju0) = jw(k) alu(ju0) = w(k) levs(ju0) = jw(n2+k) ju0 = ju0+1 endif 302 continue if (w(ii) .eq. 0.0) goto 999 c alu(ii) = 1.0d0/ w(ii) c c update pointer to beginning of next row of U. c jlu(ii+1) = ju0 c----------------------------------------------------------------------- c end main loop c----------------------------------------------------------------------- 500 continue ierr = 0 return c c incomprehensible error. Matrix must be wrong. c 995 ierr = -1 return c c insufficient storage in L. c 996 ierr = -2 return c c insufficient storage in U. c 997 ierr = -3 return c c illegal lfil entered. c 998 ierr = -4 return c c zero row encountered in A or U. c 999 ierr = -5 return c----------------end-of-iluk-------------------------------------------- c----------------------------------------------------------------------- end c---------------------------------------------------------------------- subroutine ilu0(n, a, ja, ia, alu, jlu, ju, iw, ierr) implicit real*8 (a-h,o-z) scalar alu(*) real*8 a(*) integer ja(*), ia(*), ju(*), jlu(*), iw(*) c------------------ right preconditioner ------------------------------* c *** ilu(0) preconditioner. *** * c----------------------------------------------------------------------* c Note that this has been coded in such a way that it can be used c with pgmres. Normally, since the data structure of the L+U matrix is c the same as that the A matrix, savings can be made. In fact with c some definitions (not correct for general sparse matrices) all we c need in addition to a, ja, ia is an additional diagonal. c ILU0 is not recommended for serious problems. It is only provided c here for comparison purposes. c----------------------------------------------------------------------- c c on entry: c--------- c n = dimension of matrix c a, ja, c ia = original matrix in compressed sparse row storage. c c on return: c----------- c alu,jlu = matrix stored in Modified Sparse Row (MSR) format containing c the L and U factors together. The diagonal (stored in c alu(1:n) ) is inverted. Each i-th row of the alu,jlu matrix c contains the i-th row of L (excluding the diagonal entry=1) c followed by the i-th row of U. c c ju = pointer to the diagonal elements in alu, jlu. c c ierr = integer indicating error code on return c ierr = 0 --> normal return c ierr = k --> code encountered a zero pivot at step k. c work arrays: c------------- c iw = integer work array of length n. c------------ c IMPORTANT c----------- c it is assumed that the the elements in the input matrix are stored c in such a way that in each row the lower part comes first and c then the upper part. To get the correct ILU factorization, it is c also necessary to have the elements of L sorted by increasing c column number. It may therefore be necessary to sort the c elements of a, ja, ia prior to calling ilu0. This can be c achieved by transposing the matrix twice using csrcsc. c c----------------------------------------------------------------------- ju0 = n+2 jlu(1) = ju0 c c initialize work vector to zero's c do 31 i=1, n iw(i) = 0 31 continue c c main loop c do 500 ii = 1, n js = ju0 c c generating row number ii of L and U. c do 100 j=ia(ii),ia(ii+1)-1 c c copy row ii of a, ja, ia into row ii of alu, jlu (L/U) matrix. c jcol = ja(j) if (jcol .eq. ii) then alu(ii) = a(j) iw(jcol) = ii ju(ii) = ju0 else alu(ju0) = a(j) jlu(ju0) = ja(j) iw(jcol) = ju0 ju0 = ju0+1 endif 100 continue jlu(ii+1) = ju0 jf = ju0-1 jm = ju(ii)-1 c c exit if diagonal element is reached. c do 150 j=js, jm jrow = jlu(j) tl = alu(j)*alu(jrow) alu(j) = tl c c perform linear combination c do 140 jj = ju(jrow), jlu(jrow+1)-1 jw = iw(jlu(jj)) if (jw .ne. 0) alu(jw) = alu(jw) - tl*alu(jj) 140 continue 150 continue c c invert and store diagonal element. c if (alu(ii) .eq. 0.0d0) goto 600 alu(ii) = 1.0d0/alu(ii) c c reset pointer iw to zero c iw(ii) = 0 do 201 i = js, jf 201 iw(jlu(i)) = 0 500 continue ierr = 0 return c c zero pivot : c 600 ierr = ii c return c------- end-of-ilu0 --------------------------------------------------- c----------------------------------------------------------------------- end c---------------------------------------------------------------------- subroutine milu0(n, a, ja, ia, alu, jlu, ju, iw, ierr) implicit real*8 (a-h,o-z) scalar alu(*) real*8 a(*) integer ja(*), ia(*), ju(*), jlu(*), iw(*) c----------------------------------------------------------------------* c *** simple milu(0) preconditioner. *** * c----------------------------------------------------------------------* c Note that this has been coded in such a way that it can be used c with pgmres. Normally, since the data structure of a, ja, ia is c the same as that of a, ja, ia, savings can be made. In fact with c some definitions (not correct for general sparse matrices) all we c need in addition to a, ja, ia is an additional diagonal. c Ilu0 is not recommended for serious problems. It is only provided c here for comparison purposes. c----------------------------------------------------------------------- c c on entry: c---------- c n = dimension of matrix c a, ja, c ia = original matrix in compressed sparse row storage. c c on return: c---------- c alu,jlu = matrix stored in Modified Sparse Row (MSR) format containing c the L and U factors together. The diagonal (stored in c alu(1:n) ) is inverted. Each i-th row of the alu,jlu matrix c contains the i-th row of L (excluding the diagonal entry=1) c followed by the i-th row of U. c c ju = pointer to the diagonal elements in alu, jlu. c c ierr = integer indicating error code on return c ierr = 0 --> normal return c ierr = k --> code encountered a zero pivot at step k. c work arrays: c------------- c iw = integer work array of length n. c------------ c Note (IMPORTANT): c----------- C it is assumed that the the elements in the input matrix are ordered c in such a way that in each row the lower part comes first and c then the upper part. To get the correct ILU factorization, it is c also necessary to have the elements of L ordered by increasing c column number. It may therefore be necessary to sort the c elements of a, ja, ia prior to calling milu0. This can be c achieved by transposing the matrix twice using csrcsc. c----------------------------------------------------------- ju0 = n+2 jlu(1) = ju0 c initialize work vector to zero's do 31 i=1, n 31 iw(i) = 0 c c-------------- MAIN LOOP ---------------------------------- c do 500 ii = 1, n js = ju0 c c generating row number ii or L and U. c do 100 j=ia(ii),ia(ii+1)-1 c c copy row ii of a, ja, ia into row ii of alu, jlu (L/U) matrix. c jcol = ja(j) if (jcol .eq. ii) then alu(ii) = a(j) iw(jcol) = ii ju(ii) = ju0 else alu(ju0) = a(j) jlu(ju0) = ja(j) iw(jcol) = ju0 ju0 = ju0+1 endif 100 continue jlu(ii+1) = ju0 jf = ju0-1 jm = ju(ii)-1 c s accumulates fill-in values s = 0.0d0 do 150 j=js, jm jrow = jlu(j) tl = alu(j)*alu(jrow) alu(j) = tl c-----------------------perform linear combination -------- do 140 jj = ju(jrow), jlu(jrow+1)-1 jw = iw(jlu(jj)) if (jw .ne. 0) then alu(jw) = alu(jw) - tl*alu(jj) else s = s + tl*alu(jj) endif 140 continue 150 continue c----------------------- invert and store diagonal element. alu(ii) = alu(ii)-s if (alu(ii) .eq. 0.0d0) goto 600 alu(ii) = 1.0d0/alu(ii) c----------------------- reset pointer iw to zero iw(ii) = 0 do 201 i = js, jf 201 iw(jlu(i)) = 0 500 continue ierr = 0 return c zero pivot : 600 ierr = ii return c------- end-of-milu0 -------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine pgmres(n, im, rhs, sol, vv, eps, maxits, iout, * aa, ja, ia, alu, jlu, ju, ierr) c----------------------------------------------------------------------- implicit real*8 (a-h,o-z) integer n, im, maxits, iout, ierr, ja(*), ia(n+1), jlu(*), ju(n) scalar alu(*) real*8 vv(n,*), rhs(n), sol(n), aa(*), eps c----------------------------------------------------------------------* c * c *** ILUT - Preconditioned GMRES *** * c * c----------------------------------------------------------------------* c This is a simple version of the ILUT preconditioned GMRES algorithm. * c The ILUT preconditioner uses a dual strategy for dropping elements * c instead of the usual level of-fill-in approach. See details in ILUT * c subroutine documentation. PGMRES uses the L and U matrices generated * c from the subroutine ILUT to precondition the GMRES algorithm. * c The preconditioning is applied to the right. The stopping criterion * c utilized is based simply on reducing the residual norm by epsilon. * c This preconditioning is more reliable than ilu0 but requires more * c storage. It seems to be much less prone to difficulties related to * c strong nonsymmetries in the matrix. We recommend using a nonzero tol * c (tol=.005 or .001 usually give good results) in ILUT. Use a large * c lfil whenever possible (e.g. lfil = 5 to 10). The higher lfil the * c more reliable the code is. Efficiency may also be much improved. * c Note that lfil=n and tol=0.0 in ILUT will yield the same factors as * c Gaussian elimination without pivoting. * c * c ILU(0) and MILU(0) are also provided for comparison purposes * c USAGE: first call ILUT or ILU0 or MILU0 to set up preconditioner and * c then call pgmres. * c----------------------------------------------------------------------* c Coded by Y. Saad - This version dated May, 7, 1990. * c----------------------------------------------------------------------* c parameters * c----------- * c on entry: * c========== * c * c n == integer. The dimension of the matrix. * c im == size of krylov subspace: should not exceed 50 in this * c version (can be reset by changing parameter command for * c kmax below) * c rhs == real vector of length n containing the right hand side. * c Destroyed on return. * c sol == real vector of length n containing an initial guess to the * c solution on input. approximate solution on output * c eps == tolerance for stopping criterion. process is stopped * c as soon as ( ||.|| is the euclidean norm): * c || current residual||/||initial residual|| <= eps * c maxits== maximum number of iterations allowed * c iout == output unit number number for printing intermediate results * c if (iout .le. 0) nothing is printed out. * c * c aa, ja, * c ia == the input matrix in compressed sparse row format: * c aa(1:nnz) = nonzero elements of A stored row-wise in order * c ja(1:nnz) = corresponding column indices. * c ia(1:n+1) = pointer to beginning of each row in aa and ja. * c here nnz = number of nonzero elements in A = ia(n+1)-ia(1) * c * c alu,jlu== A matrix stored in Modified Sparse Row format containing * c the L and U factors, as computed by subroutine ilut. * c * c ju == integer array of length n containing the pointers to * c the beginning of each row of U in alu, jlu as computed * c by subroutine ILUT. * c * c on return: * c========== * c sol == contains an approximate solution (upon successful return). * c ierr == integer. Error message with the following meaning. * c ierr = 0 --> successful return. * c ierr = 1 --> convergence not achieved in itmax iterations. * c ierr =-1 --> the initial guess seems to be the exact * c solution (initial residual computed was zero) * c * c----------------------------------------------------------------------* c * c work arrays: * c============= * c vv == work array of length n x (im+1) (used to store the Arnoli * c basis) * c----------------------------------------------------------------------* c subroutines called : * c amux : SPARSKIT routine to do the matrix by vector multiplication * c delivers y=Ax, given x -- see SPARSKIT/BLASSM/amux * c lusol : combined forward and backward solves (Preconditioning ope.) * c BLAS1 routines. * c----------------------------------------------------------------------* parameter (kmax=50) real*8 hh(kmax+1,kmax), c(kmax), s(kmax), rs(kmax+1),t c------------------------------------------------------------- c arnoldi size should not exceed kmax=50 in this version.. c to reset modify paramter kmax accordingly. c------------------------------------------------------------- data epsmac/1.d-16/ n1 = n + 1 its = 0 c------------------------------------------------------------- c outer loop starts here.. c-------------- compute initial residual vector -------------- call amux (n, sol, vv, aa, ja, ia) do 21 j=1,n vv(j,1) = rhs(j) - vv(j,1) 21 continue c------------------------------------------------------------- 20 ro = dnrm2(n, vv, 1) if (iout .gt. 0 .and. its .eq. 0) * write(iout, 199) its, ro if (ro .eq. 0.0d0) goto 999 t = 1.0d0/ ro do 210 j=1, n vv(j,1) = vv(j,1)*t 210 continue if (its .eq. 0) eps1=eps*ro c ** initialize 1-st term of rhs of hessenberg system.. rs(1) = ro i = 0 4 i=i+1 its = its + 1 i1 = i + 1 call lusol (n, vv(1,i), rhs, alu, jlu, ju) call amux (n, rhs, vv(1,i1), aa, ja, ia) c----------------------------------------- c modified gram - schmidt... c----------------------------------------- do 55 j=1, i t = ddot(n, vv(1,j),1,vv(1,i1),1) hh(j,i) = t call daxpy(n, -t, vv(1,j), 1, vv(1,i1), 1) 55 continue t = dnrm2(n, vv(1,i1), 1) hh(i1,i) = t if ( t .eq. 0.0d0) goto 58 t = 1.0d0/t do 57 k=1,n vv(k,i1) = vv(k,i1)*t 57 continue c c done with modified gram schimd and arnoldi step.. c now update factorization of hh c 58 if (i .eq. 1) goto 121 c--------perfrom previous transformations on i-th column of h do 66 k=2,i k1 = k-1 t = hh(k1,i) hh(k1,i) = c(k1)*t + s(k1)*hh(k,i) hh(k,i) = -s(k1)*t + c(k1)*hh(k,i) 66 continue 121 gam = sqrt(hh(i,i)**2 + hh(i1,i)**2) c c if gamma is zero then any small value will do... c will affect only residual estimate c if (gam .eq. 0.0d0) gam = epsmac c c get next plane rotation c c(i) = hh(i,i)/gam s(i) = hh(i1,i)/gam rs(i1) = -s(i)*rs(i) rs(i) = c(i)*rs(i) c c detrermine residual norm and test for convergence- c hh(i,i) = c(i)*hh(i,i) + s(i)*hh(i1,i) ro = abs(rs(i1)) 131 format(1h ,2e14.4) if (iout .gt. 0) * write(iout, 199) its, ro if (i .lt. im .and. (ro .gt. eps1)) goto 4 c c now compute solution. first solve upper triangular system. c rs(i) = rs(i)/hh(i,i) do 30 ii=2,i k=i-ii+1 k1 = k+1 t=rs(k) do 40 j=k1,i t = t-hh(k,j)*rs(j) 40 continue rs(k) = t/hh(k,k) 30 continue c c form linear combination of v(*,i)'s to get solution c t = rs(1) do 15 k=1, n rhs(k) = vv(k,1)*t 15 continue do 16 j=2, i t = rs(j) do 161 k=1, n rhs(k) = rhs(k)+t*vv(k,j) 161 continue 16 continue c c call preconditioner. c call lusol (n, rhs, rhs, alu, jlu, ju) do 17 k=1, n sol(k) = sol(k) + rhs(k) 17 continue c c restart outer loop when necessary c if (ro .le. eps1) goto 990 if (its .ge. maxits) goto 991 c c else compute residual vector and continue.. c do 24 j=1,i jj = i1-j+1 rs(jj-1) = -s(jj-1)*rs(jj) rs(jj) = c(jj-1)*rs(jj) 24 continue do 25 j=1,i1 t = rs(j) if (j .eq. 1) t = t-1.0d0 call daxpy (n, t, vv(1,j), 1, vv, 1) 25 continue 199 format(' its =', i4, ' res. norm =', d20.6) c restart outer loop. goto 20 990 ierr = 0 return 991 ierr = 1 return 999 continue ierr = -1 return c-----------------end of pgmres --------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine lusol(n, y, x, alu, jlu, ju) scalar alu(*) real*8 x(n), y(n) integer n, jlu(*), ju(*) c----------------------------------------------------------------------- c c This routine solves the system (LU) x = y, c given an LU decomposition of a matrix stored in (alu, jlu, ju) c modified sparse row format c c----------------------------------------------------------------------- c on entry: c n = dimension of system c y = the right-hand-side vector c alu, jlu, ju c = the LU matrix as provided from the ILU routines. c c on return c x = solution of LU x = y. c----------------------------------------------------------------------- c c Note: routine is in place: call lusol (n, x, x, alu, jlu, ju) c will solve the system with rhs x and overwrite the result on x . c c----------------------------------------------------------------------- c local variables c integer i,k c c forward solve c do 40 i = 1, n x(i) = y(i) do 41 k=jlu(i),ju(i)-1 x(i) = x(i) - alu(k)* x(jlu(k)) 41 continue 40 continue c c backward solve. c do 90 i = n, 1, -1 do 91 k=ju(i),jlu(i+1)-1 x(i) = x(i) - alu(k)*x(jlu(k)) 91 continue x(i) = alu(i)*x(i) 90 continue c return c----------------end of lusol ------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine lutsol(n, y, x, alu, jlu, ju) scalar alu(*) real*8 x(n), y(n) integer n, jlu(*), ju(*) c----------------------------------------------------------------------- c c This routine solves the system Transp(LU) x = y, c given an LU decomposition of a matrix stored in (alu, jlu, ju) c modified sparse row format. Transp(M) is the transpose of M. c----------------------------------------------------------------------- c on entry: c n = dimension of system c y = the right-hand-side vector c alu, jlu, ju c = the LU matrix as provided from the ILU routines. c c on return c x = solution of transp(LU) x = y. c----------------------------------------------------------------------- c c Note: routine is in place: call lutsol (n, x, x, alu, jlu, ju) c will solve the system with rhs x and overwrite the result on x . c c----------------------------------------------------------------------- c local variables c integer i,k c do 10 i = 1, n x(i) = y(i) 10 continue c c forward solve (with U^T) c do 20 i = 1, n x(i) = x(i) * alu(i) do 30 k=ju(i),jlu(i+1)-1 x(jlu(k)) = x(jlu(k)) - alu(k)* x(i) 30 continue 20 continue c c backward solve (with L^T) c do 40 i = n, 1, -1 do 50 k=jlu(i),ju(i)-1 x(jlu(k)) = x(jlu(k)) - alu(k)*x(i) 50 continue 40 continue c return c----------------end of lutsol ----------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine qsplit(a,ind,n,ncut) real*8 a(n) integer ind(n), n, ncut c----------------------------------------------------------------------- c does a quick-sort split of a real array. c on input a(1:n). is a real array c on output a(1:n) is permuted such that its elements satisfy: c c abs(a(i)) .ge. abs(a(ncut)) for i .lt. ncut and c abs(a(i)) .le. abs(a(ncut)) for i .gt. ncut c c ind(1:n) is an integer array which permuted in the same way as a(*). c----------------------------------------------------------------------- real*8 tmp, abskey integer itmp, first, last c----- first = 1 last = n if (ncut .lt. first .or. ncut .gt. last) return c c outer loop -- while mid .ne. ncut do c 1 mid = first abskey = abs(a(mid)) do 2 j=first+1, last if (abs(a(j)) .gt. abskey) then mid = mid+1 c interchange tmp = a(mid) itmp = ind(mid) a(mid) = a(j) ind(mid) = ind(j) a(j) = tmp ind(j) = itmp endif 2 continue c c interchange c tmp = a(mid) a(mid) = a(first) a(first) = tmp c itmp = ind(mid) ind(mid) = ind(first) ind(first) = itmp c c test for while loop c if (mid .eq. ncut) return if (mid .gt. ncut) then last = mid-1 else first = mid+1 endif goto 1 c----------------end-of-qsplit------------------------------------------ c----------------------------------------------------------------------- end getdp-2.4.2-source/contrib/Sparskit/iters.f000644 001750 001750 00000313557 11266605601 022356 0ustar00geuzainegeuzaine000000 000000 c $Id: iters.f,v 1.1 2008-04-11 06:01:06 geuzaine Exp $ c----------------------------------------------------------------------c function distdot(n,x,ix,y,iy) c----------------------------------------------------------------------c integer n, ix, iy real*8 distdot, x(*), y(*), ddot external ddot distdot = ddot(n,x,ix,y,iy) return end c----------------------------------------------------------------------c c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c Basic Iterative Solvers with Reverse Communication c c----------------------------------------------------------------------c c This file currently has several basic iterative linear system c c solvers. They are: c c CG -- Conjugate Gradient Method c c CGNR -- Conjugate Gradient Method (Normal Residual equation) c c BCG -- Bi-Conjugate Gradient Method c c DBCG -- BCG with partial pivoting c c BCGSTAB -- BCG stabilized c c TFQMR -- Transpose-Free Quasi-Minimum Residual method c c FOM -- Full Orthogonalization Method c c GMRES -- Generalized Minimum RESidual method c c FGMRES -- Flexible version of Generalized Minimum c c RESidual method c c DQGMRES -- Direct versions of Quasi Generalize Minimum c c Residual method c c----------------------------------------------------------------------c c They all have the following calling sequence: c subroutine solver(n, rhs, sol, ipar, fpar, w) c integer n, ipar(16) c real*8 rhs(n), sol(n), fpar(16), w(*) c Where c (1) 'n' is the size of the linear system, c (2) 'rhs' is the right-hand side of the linear system, c (3) 'sol' is the solution to the linear system, c (4) 'ipar' is an integer parameter array for the reverse c communication protocol, c (5) 'fpar' is an floating-point parameter array storing c information to and from the iterative solvers. c (6) 'w' is the work space (size is specified in ipar) c c They are preconditioned iterative solvers with reverse c communication. The preconditioners can be applied from either c from left or right or both (specified by ipar(2), see below). c c Author: Kesheng John Wu (kewu@mail.cs.umn.edu) 1993 c c NOTES: c c (1) Work space required by each of the iterative solver c routines is as follows: c CG == 5 * n c CGNR == 5 * n c BCG == 7 * n c DBCG == 11 * n c BCGSTAB == 8 * n c TFQMR == 11 * n c FOM == (n+3)*(m+2) + (m+1)*m/2 (m = ipar(5), default m=15) c GMRES == (n+3)*(m+2) + (m+1)*m/2 (m = ipar(5), default m=15) c FGMRES == 2*n*(m+1) + (m+1)*m/2 + 3*m + 2 (m = ipar(5), c default m=15) c DQGMRES == n + lb * (2*n+4) (lb=ipar(5)+1, default lb = 16) c c (2) ALL iterative solvers require a user-supplied DOT-product c routine named DISTDOT. The prototype of DISTDOT is c c real*8 function distdot(n,x,ix,y,iy) c integer n, ix, iy c real*8 x(1+(n-1)*ix), y(1+(n-1)*iy) c c This interface of DISTDOT is exactly the same as that of c DDOT (or SDOT if real == real*8) from BLAS-1. It should have c same functionality as DDOT on a single processor machine. On a c parallel/distributed environment, each processor can perform c DDOT on the data it has, then perform a summation on all the c partial results. c c (3) To use this set of routines under SPMD/MIMD program paradigm, c several things are to be noted: (a) 'n' should be the number of c vector elements of 'rhs' that is present on the local processor. c (b) if RHS(i) is on processor j, it is expected that SOL(i) c will be on the same processor, i.e. the vectors are distributed c to each processor in the same way. (c) the preconditioning and c stopping criteria specifications have to be the same on all c processor involved, ipar and fpar have to be the same on each c processor. (d) DISTDOT should be replaced by a distributed c dot-product function. c c .................................................................. c Reverse Communication Protocols c c When a reverse-communication routine returns, it could be either c that the routine has terminated or it simply requires the caller c to perform one matrix-vector multiplication. The possible matrices c that involve in the matrix-vector multiplications are: c A (the matrix of the linear system), c A^T (A transposed), c Ml^{-1} (inverse of the left preconditioner), c Ml^{-T} (inverse of the left preconditioner transposed), c Mr^{-1} (inverse of the right preconditioner), c Mr^{-T} (inverse of the right preconditioner transposed). c For all the matrix vector multiplication, v = A u. The input and c output vectors are supposed to be part of the work space 'w', and c the starting positions of them are stored in ipar(8:9), see below. c c The array 'ipar' is used to store the information about the solver. c Here is the list of what each element represents: c c ipar(1) -- status of the call/return. c A call to the solver with ipar(1) == 0 will initialize the c iterative solver. On return from the iterative solver, ipar(1) c carries the status flag which indicates the condition of the c return. The status information is divided into two categories, c (1) a positive value indicates the solver requires a matrix-vector c multiplication, c (2) a non-positive value indicates termination of the solver. c Here is the current definition: c 1 == request a matvec with A, c 2 == request a matvec with A^T, c 3 == request a left preconditioner solve (Ml^{-1}), c 4 == request a left preconditioner transposed solve (Ml^{-T}), c 5 == request a right preconditioner solve (Mr^{-1}), c 6 == request a right preconditioner transposed solve (Mr^{-T}), c 10 == request the caller to perform stopping test, c 0 == normal termination of the solver, satisfied the stopping c criteria, c -1 == termination because iteration number is greater than the c preset limit, c -2 == return due to insufficient work space, c -3 == return due to anticipated break-down / divide by zero, c in the case where Arnoldi procedure is used, additional c error code can be found in ipar(12), where ipar(12) is c the error code of orthogonalization procedure MGSRO: c -1: zero input vector c -2: input vector contains abnormal numbers c -3: input vector is a linear combination of others c -4: trianguler system in GMRES/FOM/etc. has rank 0 (zero) c -4 == the values of fpar(1) and fpar(2) are both <= 0, the valid c ranges are 0 <= fpar(1) < 1, 0 <= fpar(2), and they can c not be zero at the same time c -9 == while trying to detect a break-down, an abnormal number is c detected. c -10 == return due to some non-numerical reasons, e.g. invalid c floating-point numbers etc. c c ipar(2) -- status of the preconditioning: c 0 == no preconditioning c 1 == left preconditioning only c 2 == right preconditioning only c 3 == both left and right preconditioning c c ipar(3) -- stopping criteria (details of this will be c discussed later). c c ipar(4) -- number of elements in the array 'w'. if this is less c than the desired size, it will be over-written with the minimum c requirement. In which case the status flag ipar(1) = -2. c c ipar(5) -- size of the Krylov subspace (used by GMRES and its c variants), e.g. GMRES(ipar(5)), FGMRES(ipar(5)), c DQGMRES(ipar(5)). c c ipar(6) -- maximum number of matrix-vector multiplies, if not a c positive number the iterative solver will run till convergence c test is satisfied. c c ipar(7) -- current number of matrix-vector multiplies. It is c incremented after each matrix-vector multiplication. If there c is preconditioning, the counter is incremented after the c preconditioning associated with each matrix-vector multiplication. c c ipar(8) -- pointer to the input vector to the requested matrix- c vector multiplication. c c ipar(9) -- pointer to the output vector of the requested matrix- c vector multiplication. c c To perform v = A * u, it is assumed that u is w(ipar(8):ipar(8)+n-1) c and v is stored as w(ipar(9):ipar(9)+n-1). c c ipar(10) -- the return address (used to determine where to go to c inside the iterative solvers after the caller has performed the c requested services). c c ipar(11) -- the result of the external convergence test c On final return from the iterative solvers, this value c will be reflected by ipar(1) = 0 (details discussed later) c c ipar(12) -- error code of MGSRO, it is c 1 if the input vector to MGSRO is linear combination c of others, c 0 if MGSRO was successful, c -1 if the input vector to MGSRO is zero, c -2 if the input vector contains invalid number. c c ipar(13) -- number of initializations. During each initilization c residual norm is computed directly from M_l(b - A x). c c ipar(14) to ipar(16) are NOT defined, they are NOT USED by c any iterative solver at this time. c c Information about the error and tolerance are stored in the array c FPAR. So are some internal variables that need to be saved from c one iteration to the next one. Since the internal variables are c not the same for each routine, we only define the common ones. c c The first two are input parameters: c fpar(1) -- the relative tolerance, c fpar(2) -- the absolute tolerance (details discussed later), c c When the iterative solver terminates, c fpar(3) -- initial residual/error norm, c fpar(4) -- target residual/error norm, c fpar(5) -- current residual norm (if available), c fpar(6) -- current residual/error norm, c fpar(7) -- convergence rate, c c fpar(8:10) are used by some of the iterative solvers to save some c internal information. c c fpar(11) -- number of floating-point operations. The iterative c solvers will add the number of FLOPS they used to this variable, c but they do NOT initialize it, nor add the number of FLOPS due to c matrix-vector multiplications (since matvec is outside of the c iterative solvers). To insure the correct FLOPS count, the c caller should set fpar(11) = 0 before invoking the iterative c solvers and account for the number of FLOPS from matrix-vector c multiplications and preconditioners. c c fpar(12:16) are not used in current implementation. c c Whether the content of fpar(3), fpar(4) and fpar(6) are residual c norms or error norms depends on ipar(3). If the requested c convergence test is based on the residual norm, they will be c residual norms. If the caller want to test convergence based the c error norms (estimated by the norm of the modifications applied c to the approximate solution), they will be error norms. c Convergence rate is defined by (Fortran 77 statement) c fpar(7) = log10(fpar(3) / fpar(6)) / (ipar(7)-ipar(13)) c If fpar(7) = 0.5, it means that approximately every 2 (= 1/0.5) c steps the residual/error norm decrease by a factor of 10. c c .................................................................. c Stopping criteria, c c An iterative solver may be terminated due to (1) satisfying c convergence test; (2) exceeding iteration limit; (3) insufficient c work space; (4) break-down. Checking of the work space is c only done in the initialization stage, i.e. when it is called with c ipar(1) == 0. A complete convergence test is done after each c update of the solutions. Other conditions are monitored c continuously. c c With regard to the number of iteration, when ipar(6) is positive, c the current iteration number will be checked against it. If c current iteration number is greater the ipar(6) than the solver c will return with status -1. If ipar(6) is not positive, the c iteration will continue until convergence test is satisfied. c c Two things may be used in the convergence tests, one is the c residual 2-norm, the other one is 2-norm of the change in the c approximate solution. The residual and the change in approximate c solution are from the preconditioned system (if preconditioning c is applied). The DQGMRES and TFQMR use two estimates for the c residual norms. The estimates are not accurate, but they are c acceptable in most of the cases. Generally speaking, the error c of the TFQMR's estimate is less accurate. c c The convergence test type is indicated by ipar(3). There are four c type convergence tests: (1) tests based on the residual norm; c (2) tests based on change in approximate solution; (3) caller c does not care, the solver choose one from above two on its own; c (4) caller will perform the test, the solver should simply continue. c Here is the complete definition: c -2 == || dx(i) || <= rtol * || rhs || + atol c -1 == || dx(i) || <= rtol * || dx(1) || + atol c 0 == solver will choose test 1 (next) c 1 == || residual || <= rtol * || initial residual || + atol c 2 == || residual || <= rtol * || rhs || + atol c 999 == caller will perform the test c where dx(i) denote the change in the solution at the ith update. c ||.|| denotes 2-norm. rtol = fpar(1) and atol = fpar(2). c c If the caller is to perform the convergence test, the outcome c should be stored in ipar(11). c ipar(11) = 0 -- failed the convergence test, iterative solver c should continue c ipar(11) = 1 -- satisfied convergence test, iterative solver c should perform the clean up job and stop. c c Upon return with ipar(1) = 10, c ipar(8) points to the starting position of the change in c solution Sx, where the actual solution of the step is c x_j = x_0 + M_r^{-1} Sx. c Exception: ipar(8) < 0, Sx = 0. It is mostly used by c GMRES and variants to indicate (1) Sx was not necessary, c (2) intermediate result of Sx is not computed. c ipar(9) points to the starting position of a work vector that c can be used by the caller. c c NOTE: the caller should allow the iterative solver to perform c clean up job after the external convergence test is satisfied, c since some of the iterative solvers do not directly c update the 'sol' array. A typical clean-up stage includes c performing the final update of the approximate solution and c computing the convergence information (e.g. values of fpar(3:7)). c c NOTE: fpar(4) and fpar(6) are not set by the accelerators (the c routines implemented here) if ipar(3) = 999. c c .................................................................. c Usage: c c To start solving a linear system, the user needs to specify c first 6 elements of the ipar, and first 2 elements of fpar. c The user may optionally set fpar(11) = 0 if one wants to count c the number of floating-point operations. (Note: the iterative c solvers will only add the floating-point operations inside c themselves, the caller will have to add the FLOPS from the c matrix-vector multiplication routines and the preconditioning c routines in order to account for all the arithmetic operations.) c c Here is an example: c ipar(1) = 0 ! always 0 to start an iterative solver c ipar(2) = 2 ! right preconditioning c ipar(3) = 1 ! use convergence test scheme 1 c ipar(4) = 10000 ! the 'w' has 10,000 elements c ipar(5) = 10 ! use *GMRES(10) (e.g. FGMRES(10)) c ipar(6) = 100 ! use at most 100 matvec's c fpar(1) = 1.0E-6 ! relative tolerance 1.0E-6 c fpar(2) = 1.0E-10 ! absolute tolerance 1.0E-10 c fpar(11) = 0.0 ! clearing the FLOPS counter c c After the above specifications, one can start to call an iterative c solver, say BCG. Here is a piece of pseudo-code showing how it can c be done, c c 10 call bcg(n,rhs,sol,ipar,fpar,w) c if (ipar(1).eq.1) then c call amux(n,w(ipar(8)),w(ipar(9)),a,ja,ia) c goto 10 c else if (ipar(1).eq.2) then c call atmux(n,w(ipar(8)),w(ipar(9)),a,ja,ia) c goto 10 c else if (ipar(1).eq.3) then c left preconditioner solver c goto 10 c else if (ipar(1).eq.4) then c left preconditioner transposed solve c goto 10 c else if (ipar(1).eq.5) then c right preconditioner solve c goto 10 c else if (ipar(1).eq.6) then c right preconditioner transposed solve c goto 10 c else if (ipar(1).eq.10) then c call my own stopping test routine c goto 10 c else if (ipar(1).gt.0) then c ipar(1) is an unspecified code c else c the iterative solver terminated with code = ipar(1) c endif c c This segment of pseudo-code assumes the matrix is in CSR format, c AMUX and ATMUX are two routines from the SPARSKIT MATVEC module. c They perform matrix-vector multiplications for CSR matrices, c where w(ipar(8)) is the first element of the input vectors to the c two routines, and w(ipar(9)) is the first element of the output c vectors from them. For simplicity, we did not show the name of c the routine that performs the preconditioning operations or the c convergence tests. c----------------------------------------------------------------------- subroutine cg(n, rhs, sol, ipar, fpar, w) implicit none integer n, ipar(16) real*8 rhs(n), sol(n), fpar(16), w(n,*) c----------------------------------------------------------------------- c This is a implementation of the Conjugate Gradient (CG) method c for solving linear system. c c NOTE: This is not the PCG algorithm. It is a regular CG algorithm. c To be consistent with the other solvers, the preconditioners are c applied by performing Ml^{-1} A Mr^{-1} P in place of A P in the c CG algorithm. The PCG uses its preconditioners very differently. c c fpar(7) is used here internally to store . c w(:,1) -- residual vector c w(:,2) -- P, the conjugate direction c w(:,3) -- A P, matrix multiply the conjugate direction c w(:,4) -- temporary storage for results of preconditioning c w(:,5) -- change in the solution (sol) is stored here until c termination of this solver c----------------------------------------------------------------------- c external functions used c real*8 distdot logical stopbis, brkdn external distdot, stopbis, brkdn, bisinit c c local variables c integer i real*8 alpha logical lp,rp save c c check the status of the call c if (ipar(1).le.0) ipar(10) = 0 goto (10, 20, 40, 50, 60, 70, 80), ipar(10) c c initialization c call bisinit(ipar,fpar,5*n,1,lp,rp,w) if (ipar(1).lt.0) return c c request for matrix vector multiplication A*x in the initialization c ipar(1) = 1 ipar(8) = n+1 ipar(9) = ipar(8) + n ipar(10) = 1 do i = 1, n w(i,2) = sol(i) enddo return 10 ipar(7) = ipar(7) + 1 ipar(13) = 1 do i = 1, n w(i,2) = rhs(i) - w(i,3) enddo fpar(11) = fpar(11) + n c c if left preconditioned c if (lp) then ipar(1) = 3 ipar(9) = 1 ipar(10) = 2 return endif c 20 if (lp) then do i = 1, n w(i,2) = w(i,1) enddo else do i = 1, n w(i,1) = w(i,2) enddo endif c fpar(7) = distdot(n,w,1,w,1) fpar(11) = fpar(11) + 2 * n fpar(3) = sqrt(fpar(7)) fpar(5) = fpar(3) if (abs(ipar(3)).eq.2) then fpar(4) = fpar(1) * sqrt(distdot(n,rhs,1,rhs,1)) + fpar(2) fpar(11) = fpar(11) + 2 * n else if (ipar(3).ne.999) then fpar(4) = fpar(1) * fpar(3) + fpar(2) endif c c before iteration can continue, we need to compute A * p, which c includes the preconditioning operations c 30 if (rp) then ipar(1) = 5 ipar(8) = n + 1 if (lp) then ipar(9) = ipar(8) + n else ipar(9) = 3*n + 1 endif ipar(10) = 3 return endif c 40 ipar(1) = 1 if (rp) then ipar(8) = ipar(9) else ipar(8) = n + 1 endif if (lp) then ipar(9) = 3*n+1 else ipar(9) = n+n+1 endif ipar(10) = 4 return c 50 if (lp) then ipar(1) = 3 ipar(8) = ipar(9) ipar(9) = n+n+1 ipar(10) = 5 return endif c c continuing with the iterations c 60 ipar(7) = ipar(7) + 1 alpha = distdot(n,w(1,2),1,w(1,3),1) fpar(11) = fpar(11) + 2*n if (brkdn(alpha,ipar)) goto 900 alpha = fpar(7) / alpha do i = 1, n w(i,5) = w(i,5) + alpha * w(i,2) w(i,1) = w(i,1) - alpha * w(i,3) enddo fpar(11) = fpar(11) + 4*n c c are we ready to terminate ? c if (ipar(3).eq.999) then ipar(1) = 10 ipar(8) = 4*n + 1 ipar(9) = 3*n + 1 ipar(10) = 6 return endif 70 if (ipar(3).eq.999) then if (ipar(11).eq.1) goto 900 else if (stopbis(n,ipar,1,fpar,w,w(1,2),alpha)) then goto 900 endif c c continue the iterations c alpha = fpar(5)*fpar(5) / fpar(7) fpar(7) = fpar(5)*fpar(5) do i = 1, n w(i,2) = w(i,1) + alpha * w(i,2) enddo fpar(11) = fpar(11) + 2*n goto 30 c c clean up -- necessary to accommodate the right-preconditioning c 900 if (rp) then if (ipar(1).lt.0) ipar(12) = ipar(1) ipar(1) = 5 ipar(8) = 4*n + 1 ipar(9) = ipar(8) - n ipar(10) = 7 return endif 80 if (rp) then call tidycg(n,ipar,fpar,sol,w(1,4)) else call tidycg(n,ipar,fpar,sol,w(1,5)) endif c return end c-----end-of-cg c----------------------------------------------------------------------- subroutine cgnr(n,rhs,sol,ipar,fpar,wk) implicit none integer n, ipar(16) real*8 rhs(n),sol(n),fpar(16),wk(n,*) c----------------------------------------------------------------------- c CGNR -- Using CG algorithm solving A x = b by solving c Normal Residual equation: A^T A x = A^T b c As long as the matrix is not singular, A^T A is symmetric c positive definite, therefore CG (CGNR) will converge. c c Usage of the work space: c wk(:,1) == residual vector R c wk(:,2) == the conjugate direction vector P c wk(:,3) == a scratch vector holds A P, or A^T R c wk(:,4) == a scratch vector holds intermediate results of the c preconditioning c wk(:,5) == a place to hold the modification to SOL c c size of the work space WK is required = 5*n c----------------------------------------------------------------------- c external functions used c real*8 distdot logical stopbis, brkdn external distdot, stopbis, brkdn, bisinit c c local variables c integer i real*8 alpha, zz, zzm1 logical lp, rp save c c check the status of the call c if (ipar(1).le.0) ipar(10) = 0 goto (10, 20, 40, 50, 60, 70, 80, 90, 100, 110), ipar(10) c c initialization c call bisinit(ipar,fpar,5*n,1,lp,rp,wk) if (ipar(1).lt.0) return c c request for matrix vector multiplication A*x in the initialization c ipar(1) = 1 ipar(8) = 1 ipar(9) = 1 + n ipar(10) = 1 do i = 1, n wk(i,1) = sol(i) enddo return 10 ipar(7) = ipar(7) + 1 ipar(13) = ipar(13) + 1 do i = 1, n wk(i,1) = rhs(i) - wk(i,2) enddo fpar(11) = fpar(11) + n c c if left preconditioned, precondition the initial residual c if (lp) then ipar(1) = 3 ipar(10) = 2 return endif c 20 if (lp) then do i = 1, n wk(i,1) = wk(i,2) enddo endif c zz = distdot(n,wk,1,wk,1) fpar(11) = fpar(11) + 2 * n fpar(3) = sqrt(zz) fpar(5) = fpar(3) if (abs(ipar(3)).eq.2) then fpar(4) = fpar(1) * sqrt(distdot(n,rhs,1,rhs,1)) + fpar(2) fpar(11) = fpar(11) + 2 * n else if (ipar(3).ne.999) then fpar(4) = fpar(1) * fpar(3) + fpar(2) endif c c normal iteration begins here, first half of the iteration c computes the conjugate direction c 30 continue c c request the caller to perform a A^T r --> wk(:,3) c if (lp) then ipar(1) = 4 ipar(8) = 1 if (rp) then ipar(9) = n + n + 1 else ipar(9) = 3*n + 1 endif ipar(10) = 3 return endif c 40 ipar(1) = 2 if (lp) then ipar(8) = ipar(9) else ipar(8) = 1 endif if (rp) then ipar(9) = 3*n + 1 else ipar(9) = n + n + 1 endif ipar(10) = 4 return c 50 if (rp) then ipar(1) = 6 ipar(8) = ipar(9) ipar(9) = n + n + 1 ipar(10) = 5 return endif c 60 ipar(7) = ipar(7) + 1 zzm1 = zz zz = distdot(n,wk(1,3),1,wk(1,3),1) fpar(11) = fpar(11) + 2 * n if (brkdn(zz,ipar)) goto 900 if (ipar(7).gt.3) then alpha = zz / zzm1 do i = 1, n wk(i,2) = wk(i,3) + alpha * wk(i,2) enddo fpar(11) = fpar(11) + 2 * n else do i = 1, n wk(i,2) = wk(i,3) enddo endif c c before iteration can continue, we need to compute A * p c if (rp) then ipar(1) = 5 ipar(8) = n + 1 if (lp) then ipar(9) = ipar(8) + n else ipar(9) = 3*n + 1 endif ipar(10) = 6 return endif c 70 ipar(1) = 1 if (rp) then ipar(8) = ipar(9) else ipar(8) = n + 1 endif if (lp) then ipar(9) = 3*n+1 else ipar(9) = n+n+1 endif ipar(10) = 7 return c 80 if (lp) then ipar(1) = 3 ipar(8) = ipar(9) ipar(9) = n+n+1 ipar(10) = 8 return endif c c update the solution -- accumulate the changes in w(:,5) c 90 ipar(7) = ipar(7) + 1 alpha = distdot(n,wk(1,3),1,wk(1,3),1) fpar(11) = fpar(11) + 2 * n if (brkdn(alpha,ipar)) goto 900 alpha = zz / alpha do i = 1, n wk(i,5) = wk(i,5) + alpha * wk(i,2) wk(i,1) = wk(i,1) - alpha * wk(i,3) enddo fpar(11) = fpar(11) + 4 * n c c are we ready to terminate ? c if (ipar(3).eq.999) then ipar(1) = 10 ipar(8) = 4*n + 1 ipar(9) = 3*n + 1 ipar(10) = 9 return endif 100 if (ipar(3).eq.999) then if (ipar(11).eq.1) goto 900 else if (stopbis(n,ipar,1,fpar,wk,wk(1,2),alpha)) then goto 900 endif c c continue the iterations c goto 30 c c clean up -- necessary to accommodate the right-preconditioning c 900 if (rp) then if (ipar(1).lt.0) ipar(12) = ipar(1) ipar(1) = 5 ipar(8) = 4*n + 1 ipar(9) = ipar(8) - n ipar(10) = 10 return endif 110 if (rp) then call tidycg(n,ipar,fpar,sol,wk(1,4)) else call tidycg(n,ipar,fpar,sol,wk(1,5)) endif return end c-----end-of-cgnr c----------------------------------------------------------------------- subroutine bcg(n,rhs,sol,ipar,fpar,w) implicit none integer n, ipar(16) real*8 fpar(16), rhs(n), sol(n), w(n,*) c----------------------------------------------------------------------- c BCG: Bi Conjugate Gradient method. Programmed with reverse c communication, see the header for detailed specifications c of the protocol. c c in this routine, before successful return, the fpar's are c fpar(3) == initial residual norm c fpar(4) == target residual norm c fpar(5) == current residual norm c fpar(7) == current rho (rhok = ) c fpar(8) == previous rho (rhokm1) c c w(:,1) -- r, the residual c w(:,2) -- s, the dual of the 'r' c w(:,3) -- p, the projection direction c w(:,4) -- q, the dual of the 'p' c w(:,5) -- v, a scratch vector to store A*p, or A*q. c w(:,6) -- a scratch vector to store intermediate results c w(:,7) -- changes in the solution c----------------------------------------------------------------------- c external routines used c real*8 distdot logical stopbis,brkdn external distdot, stopbis, brkdn c real*8 one parameter(one=1.0D0) c c local variables c integer i real*8 alpha logical rp, lp save c c status of the program c if (ipar(1).le.0) ipar(10) = 0 goto (10, 20, 40, 50, 60, 70, 80, 90, 100, 110), ipar(10) c c initialization, initial residual c call bisinit(ipar,fpar,7*n,1,lp,rp,w) if (ipar(1).lt.0) return c c compute initial residual, request a matvecc c ipar(1) = 1 ipar(8) = 3*n+1 ipar(9) = ipar(8) + n do i = 1, n w(i,4) = sol(i) enddo ipar(10) = 1 return 10 ipar(7) = ipar(7) + 1 ipar(13) = ipar(13) + 1 do i = 1, n w(i,1) = rhs(i) - w(i,5) enddo fpar(11) = fpar(11) + n if (lp) then ipar(1) = 3 ipar(8) = 1 ipar(9) = n+1 ipar(10) = 2 return endif c 20 if (lp) then do i = 1, n w(i,1) = w(i,2) w(i,3) = w(i,2) w(i,4) = w(i,2) enddo else do i = 1, n w(i,2) = w(i,1) w(i,3) = w(i,1) w(i,4) = w(i,1) enddo endif c fpar(7) = distdot(n,w,1,w,1) fpar(11) = fpar(11) + 2 * n fpar(3) = sqrt(fpar(7)) fpar(5) = fpar(3) fpar(8) = one if (abs(ipar(3)).eq.2) then fpar(4) = fpar(1) * sqrt(distdot(n,rhs,1,rhs,1)) + fpar(2) fpar(11) = fpar(11) + 2 * n else if (ipar(3).ne.999) then fpar(4) = fpar(1) * fpar(3) + fpar(2) endif if (ipar(3).ge.0.and.fpar(5).le.fpar(4)) then fpar(6) = fpar(5) goto 900 endif c c end of initialization, begin iteration, v = A p c 30 if (rp) then ipar(1) = 5 ipar(8) = n + n + 1 if (lp) then ipar(9) = 4*n + 1 else ipar(9) = 5*n + 1 endif ipar(10) = 3 return endif c 40 ipar(1) = 1 if (rp) then ipar(8) = ipar(9) else ipar(8) = n + n + 1 endif if (lp) then ipar(9) = 5*n + 1 else ipar(9) = 4*n + 1 endif ipar(10) = 4 return c 50 if (lp) then ipar(1) = 3 ipar(8) = ipar(9) ipar(9) = 4*n + 1 ipar(10) = 5 return endif c 60 ipar(7) = ipar(7) + 1 alpha = distdot(n,w(1,4),1,w(1,5),1) fpar(11) = fpar(11) + 2 * n if (brkdn(alpha,ipar)) goto 900 alpha = fpar(7) / alpha do i = 1, n w(i,7) = w(i,7) + alpha * w(i,3) w(i,1) = w(i,1) - alpha * w(i,5) enddo fpar(11) = fpar(11) + 4 * n if (ipar(3).eq.999) then ipar(1) = 10 ipar(8) = 6*n + 1 ipar(9) = 5*n + 1 ipar(10) = 6 return endif 70 if (ipar(3).eq.999) then if (ipar(11).eq.1) goto 900 else if (stopbis(n,ipar,1,fpar,w,w(1,3),alpha)) then goto 900 endif c c A^t * x c if (lp) then ipar(1) = 4 ipar(8) = 3*n + 1 if (rp) then ipar(9) = 4*n + 1 else ipar(9) = 5*n + 1 endif ipar(10) = 7 return endif c 80 ipar(1) = 2 if (lp) then ipar(8) = ipar(9) else ipar(8) = 3*n + 1 endif if (rp) then ipar(9) = 5*n + 1 else ipar(9) = 4*n + 1 endif ipar(10) = 8 return c 90 if (rp) then ipar(1) = 6 ipar(8) = ipar(9) ipar(9) = 4*n + 1 ipar(10) = 9 return endif c 100 ipar(7) = ipar(7) + 1 do i = 1, n w(i,2) = w(i,2) - alpha * w(i,5) enddo fpar(8) = fpar(7) fpar(7) = distdot(n,w,1,w(1,2),1) fpar(11) = fpar(11) + 4 * n if (brkdn(fpar(7), ipar)) return alpha = fpar(7) / fpar(8) do i = 1, n w(i,3) = w(i,1) + alpha * w(i,3) w(i,4) = w(i,2) + alpha * w(i,4) enddo fpar(11) = fpar(11) + 4 * n c c end of the iterations c goto 30 c c some clean up job to do c 900 if (rp) then if (ipar(1).lt.0) ipar(12) = ipar(1) ipar(1) = 5 ipar(8) = 6*n + 1 ipar(9) = ipar(8) - n ipar(10) = 10 return endif 110 if (rp) then call tidycg(n,ipar,fpar,sol,w(1,6)) else call tidycg(n,ipar,fpar,sol,w(1,7)) endif return c-----end-of-bcg end c----------------------------------------------------------------------- subroutine bcgstab(n, rhs, sol, ipar, fpar, w) implicit none integer n, ipar(16) real*8 rhs(n), sol(n), fpar(16), w(n,8) c----------------------------------------------------------------------- c BCGSTAB --- Bi Conjugate Gradient stabilized (BCGSTAB) c This is an improved BCG routine. (1) no matrix transpose is c involved. (2) the convergence is smoother. c c c Algorithm: c Initialization - r = b - A x, r0 = r, p = r, rho = (r0, r), c Iterate - c (1) v = A p c (2) alpha = rho / (r0, v) c (3) s = r - alpha v c (4) t = A s c (5) omega = (t, s) / (t, t) c (6) x = x + alpha * p + omega * s c (7) r = s - omega * t c convergence test goes here c (8) beta = rho, rho = (r0, r), beta = rho * alpha / (beta * omega) c p = r + beta * (p - omega * v) c c in this routine, before successful return, the fpar's are c fpar(3) == initial (preconditionied-)residual norm c fpar(4) == target (preconditionied-)residual norm c fpar(5) == current (preconditionied-)residual norm c fpar(6) == current residual norm or error c fpar(7) == current rho (rhok = ) c fpar(8) == alpha c fpar(9) == omega c c Usage of the work space W c w(:, 1) = r0, the initial residual vector c w(:, 2) = r, current residual vector c w(:, 3) = s c w(:, 4) = t c w(:, 5) = v c w(:, 6) = p c w(:, 7) = tmp, used in preconditioning, etc. c w(:, 8) = delta x, the correction to the answer is accumulated c here, so that the right-preconditioning may be applied c at the end c----------------------------------------------------------------------- c external routines used c real*8 distdot logical stopbis, brkdn external distdot, stopbis, brkdn c real*8 one parameter(one=1.0D0) c c local variables c integer i real*8 alpha,beta,rho,omega logical lp, rp save lp, rp c c where to go c if (ipar(1).gt.0) then goto (10, 20, 40, 50, 60, 70, 80, 90, 100, 110) ipar(10) else if (ipar(1).lt.0) then goto 900 endif c c call the initialization routine c call bisinit(ipar,fpar,8*n,1,lp,rp,w) if (ipar(1).lt.0) return c c perform a matvec to compute the initial residual c ipar(1) = 1 ipar(8) = 1 ipar(9) = 1 + n do i = 1, n w(i,1) = sol(i) enddo ipar(10) = 1 return 10 ipar(7) = ipar(7) + 1 ipar(13) = ipar(13) + 1 do i = 1, n w(i,1) = rhs(i) - w(i,2) enddo fpar(11) = fpar(11) + n if (lp) then ipar(1) = 3 ipar(10) = 2 return endif c 20 if (lp) then do i = 1, n w(i,1) = w(i,2) w(i,6) = w(i,2) enddo else do i = 1, n w(i,2) = w(i,1) w(i,6) = w(i,1) enddo endif c fpar(7) = distdot(n,w,1,w,1) fpar(11) = fpar(11) + 2 * n fpar(5) = sqrt(fpar(7)) fpar(3) = fpar(5) if (abs(ipar(3)).eq.2) then fpar(4) = fpar(1) * sqrt(distdot(n,rhs,1,rhs,1)) + fpar(2) fpar(11) = fpar(11) + 2 * n else if (ipar(3).ne.999) then fpar(4) = fpar(1) * fpar(3) + fpar(2) endif if (ipar(3).ge.0) fpar(6) = fpar(5) if (ipar(3).ge.0 .and. fpar(5).le.fpar(4) .and. + ipar(3).ne.999) then goto 900 endif c c beginning of the iterations c c Step (1), v = A p 30 if (rp) then ipar(1) = 5 ipar(8) = 5*n+1 if (lp) then ipar(9) = 4*n + 1 else ipar(9) = 6*n + 1 endif ipar(10) = 3 return endif c 40 ipar(1) = 1 if (rp) then ipar(8) = ipar(9) else ipar(8) = 5*n+1 endif if (lp) then ipar(9) = 6*n + 1 else ipar(9) = 4*n + 1 endif ipar(10) = 4 return 50 if (lp) then ipar(1) = 3 ipar(8) = ipar(9) ipar(9) = 4*n + 1 ipar(10) = 5 return endif c 60 ipar(7) = ipar(7) + 1 c c step (2) alpha = distdot(n,w(1,1),1,w(1,5),1) fpar(11) = fpar(11) + 2 * n if (brkdn(alpha, ipar)) goto 900 alpha = fpar(7) / alpha fpar(8) = alpha c c step (3) do i = 1, n w(i,3) = w(i,2) - alpha * w(i,5) enddo fpar(11) = fpar(11) + 2 * n c c Step (4): the second matvec -- t = A s c if (rp) then ipar(1) = 5 ipar(8) = n+n+1 if (lp) then ipar(9) = ipar(8)+n else ipar(9) = 6*n + 1 endif ipar(10) = 6 return endif c 70 ipar(1) = 1 if (rp) then ipar(8) = ipar(9) else ipar(8) = n+n+1 endif if (lp) then ipar(9) = 6*n + 1 else ipar(9) = 3*n + 1 endif ipar(10) = 7 return 80 if (lp) then ipar(1) = 3 ipar(8) = ipar(9) ipar(9) = 3*n + 1 ipar(10) = 8 return endif 90 ipar(7) = ipar(7) + 1 c c step (5) omega = distdot(n,w(1,4),1,w(1,4),1) fpar(11) = fpar(11) + n + n if (brkdn(omega,ipar)) goto 900 omega = distdot(n,w(1,4),1,w(1,3),1) / omega fpar(11) = fpar(11) + n + n if (brkdn(omega,ipar)) goto 900 fpar(9) = omega alpha = fpar(8) c c step (6) and (7) do i = 1, n w(i,7) = alpha * w(i,6) + omega * w(i,3) w(i,8) = w(i,8) + w(i,7) w(i,2) = w(i,3) - omega * w(i,4) enddo fpar(11) = fpar(11) + 6 * n + 1 c c convergence test if (ipar(3).eq.999) then ipar(1) = 10 ipar(8) = 7*n + 1 ipar(9) = 6*n + 1 ipar(10) = 9 return endif if (stopbis(n,ipar,2,fpar,w(1,2),w(1,7),one)) goto 900 100 if (ipar(3).eq.999.and.ipar(11).eq.1) goto 900 c c step (8): computing new p and rho rho = fpar(7) fpar(7) = distdot(n,w(1,2),1,w(1,1),1) omega = fpar(9) beta = fpar(7) * fpar(8) / (fpar(9) * rho) do i = 1, n w(i,6) = w(i,2) + beta * (w(i,6) - omega * w(i,5)) enddo fpar(11) = fpar(11) + 6 * n + 3 if (brkdn(fpar(7),ipar)) goto 900 c c end of an iteration c goto 30 c c some clean up job to do c 900 if (rp) then if (ipar(1).lt.0) ipar(12) = ipar(1) ipar(1) = 5 ipar(8) = 7*n + 1 ipar(9) = ipar(8) - n ipar(10) = 10 return endif 110 if (rp) then call tidycg(n,ipar,fpar,sol,w(1,7)) else call tidycg(n,ipar,fpar,sol,w(1,8)) endif c return c-----end-of-bcgstab end c----------------------------------------------------------------------- subroutine tfqmr(n, rhs, sol, ipar, fpar, w) implicit none integer n, ipar(16) real*8 rhs(n), sol(n), fpar(16), w(n,*) c----------------------------------------------------------------------- c TFQMR --- transpose-free Quasi-Minimum Residual method c This is developed from BCG based on the principle of Quasi-Minimum c Residual, and it is transpose-free. c c It uses approximate residual norm. c c Internally, the fpar's are used as following: c fpar(3) --- initial residual norm squared c fpar(4) --- target residual norm squared c fpar(5) --- current residual norm squared c c w(:,1) -- R, residual c w(:,2) -- R0, the initial residual c w(:,3) -- W c w(:,4) -- Y c w(:,5) -- Z c w(:,6) -- A * Y c w(:,7) -- A * Z c w(:,8) -- V c w(:,9) -- D c w(:,10) -- intermediate results of preconditioning c w(:,11) -- changes in the solution c----------------------------------------------------------------------- c external functions c real*8 distdot logical stopbis, brkdn external stopbis, brkdn, distdot c real*8 one,zero parameter(one=1.0D0,zero=0.0D0) c c local variables c integer i logical lp, rp real*8 eta,sigma,theta,te,alpha,rho,tao save c c status of the call (where to go) c if (ipar(1).le.0) ipar(10) = 0 goto (10,20,40,50,60,70,80,90,100,110), ipar(10) c c initializations c call bisinit(ipar,fpar,11*n,2,lp,rp,w) if (ipar(1).lt.0) return ipar(1) = 1 ipar(8) = 1 ipar(9) = 1 + 6*n do i = 1, n w(i,1) = sol(i) enddo ipar(10) = 1 return 10 ipar(7) = ipar(7) + 1 ipar(13) = ipar(13) + 1 do i = 1, n w(i,1) = rhs(i) - w(i,7) w(i,9) = zero enddo fpar(11) = fpar(11) + n c if (lp) then ipar(1) = 3 ipar(9) = n+1 ipar(10) = 2 return endif 20 continue if (lp) then do i = 1, n w(i,1) = w(i,2) w(i,3) = w(i,2) enddo else do i = 1, n w(i,2) = w(i,1) w(i,3) = w(i,1) enddo endif c fpar(5) = sqrt(distdot(n,w,1,w,1)) fpar(3) = fpar(5) tao = fpar(5) fpar(11) = fpar(11) + n + n if (abs(ipar(3)).eq.2) then fpar(4) = fpar(1) * sqrt(distdot(n,rhs,1,rhs,1)) + fpar(2) fpar(11) = fpar(11) + n + n else if (ipar(3).ne.999) then fpar(4) = fpar(1) * tao + fpar(2) endif te = zero rho = zero c c begin iteration c 30 sigma = rho rho = distdot(n,w(1,2),1,w(1,3),1) fpar(11) = fpar(11) + n + n if (brkdn(rho,ipar)) goto 900 if (ipar(7).eq.1) then alpha = zero else alpha = rho / sigma endif do i = 1, n w(i,4) = w(i,3) + alpha * w(i,5) enddo fpar(11) = fpar(11) + n + n c c A * x -- with preconditioning c if (rp) then ipar(1) = 5 ipar(8) = 3*n + 1 if (lp) then ipar(9) = 5*n + 1 else ipar(9) = 9*n + 1 endif ipar(10) = 3 return endif c 40 ipar(1) = 1 if (rp) then ipar(8) = ipar(9) else ipar(8) = 3*n + 1 endif if (lp) then ipar(9) = 9*n + 1 else ipar(9) = 5*n + 1 endif ipar(10) = 4 return c 50 if (lp) then ipar(1) = 3 ipar(8) = ipar(9) ipar(9) = 5*n + 1 ipar(10) = 5 return endif 60 ipar(7) = ipar(7) + 1 do i = 1, n w(i,8) = w(i,6) + alpha * (w(i,7) + alpha * w(i,8)) enddo sigma = distdot(n,w(1,2),1,w(1,8),1) fpar(11) = fpar(11) + 6 * n if (brkdn(sigma,ipar)) goto 900 alpha = rho / sigma do i = 1, n w(i,5) = w(i,4) - alpha * w(i,8) enddo fpar(11) = fpar(11) + 2*n c c the second A * x c if (rp) then ipar(1) = 5 ipar(8) = 4*n + 1 if (lp) then ipar(9) = 6*n + 1 else ipar(9) = 9*n + 1 endif ipar(10) = 6 return endif c 70 ipar(1) = 1 if (rp) then ipar(8) = ipar(9) else ipar(8) = 4*n + 1 endif if (lp) then ipar(9) = 9*n + 1 else ipar(9) = 6*n + 1 endif ipar(10) = 7 return c 80 if (lp) then ipar(1) = 3 ipar(8) = ipar(9) ipar(9) = 6*n + 1 ipar(10) = 8 return endif 90 ipar(7) = ipar(7) + 1 do i = 1, n w(i,3) = w(i,3) - alpha * w(i,6) enddo c c update I c theta = distdot(n,w(1,3),1,w(1,3),1) / (tao*tao) sigma = one / (one + theta) tao = tao * sqrt(sigma * theta) fpar(11) = fpar(11) + 4*n + 6 if (brkdn(tao,ipar)) goto 900 eta = sigma * alpha sigma = te / alpha te = theta * eta do i = 1, n w(i,9) = w(i,4) + sigma * w(i,9) w(i,11) = w(i,11) + eta * w(i,9) w(i,3) = w(i,3) - alpha * w(i,7) enddo fpar(11) = fpar(11) + 6 * n + 6 if (ipar(7).eq.1) then if (ipar(3).eq.-1) then fpar(3) = eta * sqrt(distdot(n,w(1,9),1,w(1,9),1)) fpar(4) = fpar(1)*fpar(3) + fpar(2) fpar(11) = fpar(11) + n + n + 4 endif endif c c update II c theta = distdot(n,w(1,3),1,w(1,3),1) / (tao*tao) sigma = one / (one + theta) tao = tao * sqrt(sigma * theta) fpar(11) = fpar(11) + 8 + 2*n if (brkdn(tao,ipar)) goto 900 eta = sigma * alpha sigma = te / alpha te = theta * eta do i = 1, n w(i,9) = w(i,5) + sigma * w(i,9) w(i,11) = w(i,11) + eta * w(i,9) enddo fpar(11) = fpar(11) + 4*n + 3 c c this is the correct over-estimate c fpar(5) = sqrt(real(ipar(7)+1)) * tao c this is an approximation fpar(5) = tao if (ipar(3).eq.999) then ipar(1) = 10 ipar(8) = 10*n + 1 ipar(9) = 9*n + 1 ipar(10) = 9 return else if (ipar(3).lt.0) then fpar(6) = eta * sqrt(distdot(n,w(1,9),1,w(1,9),1)) fpar(11) = fpar(11) + n + n + 2 else fpar(6) = fpar(5) endif if (fpar(6).gt.fpar(4) .and. (ipar(7).lt.ipar(6) + .or. ipar(6).le.0)) goto 30 100 if (ipar(3).eq.999.and.ipar(11).eq.0) goto 30 c c clean up c 900 if (rp) then if (ipar(1).lt.0) ipar(12) = ipar(1) ipar(1) = 5 ipar(8) = 10*n + 1 ipar(9) = ipar(8) - n ipar(10) = 10 return endif 110 if (rp) then call tidycg(n,ipar,fpar,sol,w(1,10)) else call tidycg(n,ipar,fpar,sol,w(1,11)) endif c return end c-----end-of-tfqmr c----------------------------------------------------------------------- subroutine fom(n, rhs, sol, ipar, fpar, w) implicit none integer n, ipar(16) real*8 rhs(n), sol(n), fpar(16), w(*) c----------------------------------------------------------------------- c This a version of The Full Orthogonalization Method (FOM) c implemented with reverse communication. It is a simple restart c version of the FOM algorithm and is implemented with plane c rotations similarly to GMRES. c c parameters: c ----------- c ipar(5) == the dimension of the Krylov subspace c after every ipar(5) iterations, the FOM will restart with c the updated solution and recomputed residual vector. c c the work space in `w' is used as follows: c (1) the basis for the Krylov subspace, size n*(m+1); c (2) the Hessenberg matrix, only the upper triangular c portion of the matrix is stored, size (m+1)*m/2 + 1 c (3) three vectors, all are of size m, they are c the cosine and sine of the Givens rotations, the third one holds c the residuals, it is of size m+1. c c TOTAL SIZE REQUIRED == (n+3)*(m+2) + (m+1)*m/2 c Note: m == ipar(5). The default value for this is 15 if c ipar(5) <= 1. c----------------------------------------------------------------------- c external functions used c real*8 distdot external distdot c real*8 one, zero parameter(one=1.0D0, zero=0.0D0) c c local variables, ptr and p2 are temporary pointers, c hes points to the Hessenberg matrix, c vc, vs point to the cosines and sines of the Givens rotations c vrn points to the vectors of residual norms, more precisely c the right hand side of the least square problem solved. c integer i,ii,idx,k,m,ptr,p2,prs,hes,vc,vs,vrn real*8 alpha, c, s logical lp, rp save c c check the status of the call c if (ipar(1).le.0) ipar(10) = 0 goto (10, 20, 30, 40, 50, 60, 70) ipar(10) c c initialization c if (ipar(5).le.1) then m = 15 else m = ipar(5) endif idx = n * (m+1) hes = idx + n vc = hes + (m+1) * m / 2 + 1 vs = vc + m vrn = vs + m i = vrn + m + 1 call bisinit(ipar,fpar,i,1,lp,rp,w) if (ipar(1).lt.0) return c c request for matrix vector multiplication A*x in the initialization c 100 ipar(1) = 1 ipar(8) = n+1 ipar(9) = 1 ipar(10) = 1 k = 0 do i = 1, n w(n+i) = sol(i) enddo return 10 ipar(7) = ipar(7) + 1 ipar(13) = ipar(13) + 1 if (lp) then do i = 1, n w(n+i) = rhs(i) - w(i) enddo ipar(1) = 3 ipar(10) = 2 return else do i = 1, n w(i) = rhs(i) - w(i) enddo endif fpar(11) = fpar(11) + n c 20 alpha = sqrt(distdot(n,w,1,w,1)) fpar(11) = fpar(11) + 2*n + 1 if (ipar(7).eq.1 .and. ipar(3).ne.999) then if (abs(ipar(3)).eq.2) then fpar(4) = fpar(1) * sqrt(distdot(n,rhs,1,rhs,1)) + fpar(2) fpar(11) = fpar(11) + 2*n else fpar(4) = fpar(1) * alpha + fpar(2) endif fpar(3) = alpha endif fpar(5) = alpha w(vrn+1) = alpha if (alpha.le.fpar(4) .and. ipar(3).ge.0 .and. ipar(3).ne.999) then ipar(1) = 0 fpar(6) = alpha goto 300 endif alpha = one / alpha do ii = 1, n w(ii) = alpha * w(ii) enddo fpar(11) = fpar(11) + n c c request for (1) right preconditioning c (2) matrix vector multiplication c (3) left preconditioning c 110 k = k + 1 if (rp) then ipar(1) = 5 ipar(8) = k*n - n + 1 if (lp) then ipar(9) = k*n + 1 else ipar(9) = idx + 1 endif ipar(10) = 3 return endif c 30 ipar(1) = 1 if (rp) then ipar(8) = ipar(9) else ipar(8) = (k-1)*n + 1 endif if (lp) then ipar(9) = idx + 1 else ipar(9) = 1 + k*n endif ipar(10) = 4 return c 40 if (lp) then ipar(1) = 3 ipar(8) = ipar(9) ipar(9) = k*n + 1 ipar(10) = 5 return endif c c Modified Gram-Schmidt orthogonalization procedure c temporary pointer 'ptr' is pointing to the current column of the c Hessenberg matrix. 'p2' points to the new basis vector c 50 ipar(7) = ipar(7) + 1 ptr = k * (k - 1) / 2 + hes p2 = ipar(9) call mgsro(.false.,n,n,k+1,k+1,fpar(11),w,w(ptr+1), $ ipar(12)) if (ipar(12).lt.0) goto 200 c c apply previous Givens rotations to column. c p2 = ptr + 1 do i = 1, k-1 ptr = p2 p2 = p2 + 1 alpha = w(ptr) c = w(vc+i) s = w(vs+i) w(ptr) = c * alpha + s * w(p2) w(p2) = c * w(p2) - s * alpha enddo c c end of one Arnoldi iteration, alpha will store the estimated c residual norm at current stage c fpar(11) = fpar(11) + 6*k prs = vrn+k alpha = fpar(5) if (w(p2) .ne. zero) alpha = abs(w(p2+1)*w(prs)/w(p2)) fpar(5) = alpha c if (k.ge.m .or. (ipar(3).ge.0 .and. alpha.le.fpar(4)) + .or. (ipar(6).gt.0 .and. ipar(7).ge.ipar(6))) + goto 200 c call givens(w(p2), w(p2+1), c, s) w(vc+k) = c w(vs+k) = s alpha = - s * w(prs) w(prs) = c * w(prs) w(prs+1) = alpha c if (w(p2).ne.zero) goto 110 c c update the approximate solution, first solve the upper triangular c system, temporary pointer ptr points to the Hessenberg matrix, c prs points to the right-hand-side (also the solution) of the system. c 200 ptr = hes + k * (k + 1) / 2 prs = vrn + k if (w(ptr).eq.zero) then c c if the diagonal elements of the last column is zero, reduce k by 1 c so that a smaller trianguler system is solved c k = k - 1 if (k.gt.0) then goto 200 else ipar(1) = -3 ipar(12) = -4 goto 300 endif endif w(prs) = w(prs) / w(ptr) do i = k-1, 1, -1 ptr = ptr - i - 1 do ii = 1, i w(vrn+ii) = w(vrn+ii) - w(prs) * w(ptr+ii) enddo prs = prs - 1 w(prs) = w(prs) / w(ptr) enddo c do ii = 1, n w(ii) = w(ii) * w(prs) enddo do i = 1, k-1 prs = prs + 1 ptr = i*n do ii = 1, n w(ii) = w(ii) + w(prs) * w(ptr+ii) enddo enddo fpar(11) = fpar(11) + 2*(k-1)*n + n + k*(k+1) c if (rp) then ipar(1) = 5 ipar(8) = 1 ipar(9) = idx + 1 ipar(10) = 6 return endif c 60 if (rp) then do i = 1, n sol(i) = sol(i) + w(idx+i) enddo else do i = 1, n sol(i) = sol(i) + w(i) enddo endif fpar(11) = fpar(11) + n c c process the complete stopping criteria c if (ipar(3).eq.999) then ipar(1) = 10 ipar(8) = -1 ipar(9) = idx + 1 ipar(10) = 7 return else if (ipar(3).lt.0) then if (ipar(7).le.m+1) then fpar(3) = abs(w(vrn+1)) if (ipar(3).eq.-1) fpar(4) = fpar(1)*fpar(3)+fpar(2) endif alpha = abs(w(vrn+k)) endif fpar(6) = alpha c c do we need to restart ? c 70 if (ipar(12).ne.0) then ipar(1) = -3 goto 300 endif if (ipar(7).lt.ipar(6) .or. ipar(6).le.0) then if (ipar(3).ne.999) then if (fpar(6).gt.fpar(4)) goto 100 else if (ipar(11).eq.0) goto 100 endif endif c c termination, set error code, compute convergence rate c if (ipar(1).gt.0) then if (ipar(3).eq.999 .and. ipar(11).eq.1) then ipar(1) = 0 else if (ipar(3).ne.999 .and. fpar(6).le.fpar(4)) then ipar(1) = 0 else if (ipar(7).ge.ipar(6) .and. ipar(6).gt.0) then ipar(1) = -1 else ipar(1) = -10 endif endif 300 if (fpar(3).ne.zero .and. fpar(6).ne.zero .and. + ipar(7).gt.ipar(13)) then fpar(7) = log10(fpar(3) / fpar(6)) / dble(ipar(7)-ipar(13)) else fpar(7) = zero endif return end c-----end-of-fom-------------------------------------------------------- c----------------------------------------------------------------------- subroutine gmres(n, rhs, sol, ipar, fpar, w) implicit none integer n, ipar(16) real*8 rhs(n), sol(n), fpar(16), w(*) c----------------------------------------------------------------------- c This a version of GMRES implemented with reverse communication. c It is a simple restart version of the GMRES algorithm. c c ipar(5) == the dimension of the Krylov subspace c after every ipar(5) iterations, the GMRES will restart with c the updated solution and recomputed residual vector. c c the space of the `w' is used as follows: c (1) the basis for the Krylov subspace, size n*(m+1); c (2) the Hessenberg matrix, only the upper triangular c portion of the matrix is stored, size (m+1)*m/2 + 1 c (3) three vectors, all are of size m, they are c the cosine and sine of the Givens rotations, the third one holds c the residuals, it is of size m+1. c c TOTAL SIZE REQUIRED == (n+3)*(m+2) + (m+1)*m/2 c Note: m == ipar(5). The default value for this is 15 if c ipar(5) <= 1. c----------------------------------------------------------------------- c external functions used c real*8 distdot external distdot c real*8 one, zero parameter(one=1.0D0, zero=0.0D0) c c local variables, ptr and p2 are temporary pointers, c hess points to the Hessenberg matrix, c vc, vs point to the cosines and sines of the Givens rotations c vrn points to the vectors of residual norms, more precisely c the right hand side of the least square problem solved. c integer i,ii,idx,k,m,ptr,p2,hess,vc,vs,vrn real*8 alpha, c, s logical lp, rp save c c check the status of the call c if (ipar(1).le.0) ipar(10) = 0 goto (10, 20, 30, 40, 50, 60, 70) ipar(10) c c initialization c if (ipar(5).le.1) then m = 15 else m = ipar(5) endif idx = n * (m+1) hess = idx + n vc = hess + (m+1) * m / 2 + 1 vs = vc + m vrn = vs + m i = vrn + m + 1 call bisinit(ipar,fpar,i,1,lp,rp,w) if (ipar(1).lt.0) return c c request for matrix vector multiplication A*x in the initialization c 100 ipar(1) = 1 ipar(8) = n+1 ipar(9) = 1 ipar(10) = 1 k = 0 do i = 1, n w(n+i) = sol(i) enddo return 10 ipar(7) = ipar(7) + 1 ipar(13) = ipar(13) + 1 if (lp) then do i = 1, n w(n+i) = rhs(i) - w(i) enddo ipar(1) = 3 ipar(10) = 2 return else do i = 1, n w(i) = rhs(i) - w(i) enddo endif fpar(11) = fpar(11) + n c 20 alpha = sqrt(distdot(n,w,1,w,1)) fpar(11) = fpar(11) + 2*n if (ipar(7).eq.1 .and. ipar(3).ne.999) then if (abs(ipar(3)).eq.2) then fpar(4) = fpar(1) * sqrt(distdot(n,rhs,1,rhs,1)) + fpar(2) fpar(11) = fpar(11) + 2*n else fpar(4) = fpar(1) * alpha + fpar(2) endif fpar(3) = alpha endif fpar(5) = alpha w(vrn+1) = alpha if (alpha.le.fpar(4) .and. ipar(3).ge.0 .and. ipar(3).ne.999) then ipar(1) = 0 fpar(6) = alpha goto 300 endif alpha = one / alpha do ii = 1, n w(ii) = alpha * w(ii) enddo fpar(11) = fpar(11) + n c c request for (1) right preconditioning c (2) matrix vector multiplication c (3) left preconditioning c 110 k = k + 1 if (rp) then ipar(1) = 5 ipar(8) = k*n - n + 1 if (lp) then ipar(9) = k*n + 1 else ipar(9) = idx + 1 endif ipar(10) = 3 return endif c 30 ipar(1) = 1 if (rp) then ipar(8) = ipar(9) else ipar(8) = (k-1)*n + 1 endif if (lp) then ipar(9) = idx + 1 else ipar(9) = 1 + k*n endif ipar(10) = 4 return c 40 if (lp) then ipar(1) = 3 ipar(8) = ipar(9) ipar(9) = k*n + 1 ipar(10) = 5 return endif c c Modified Gram-Schmidt orthogonalization procedure c temporary pointer 'ptr' is pointing to the current column of the c Hessenberg matrix. 'p2' points to the new basis vector c 50 ipar(7) = ipar(7) + 1 ptr = k * (k - 1) / 2 + hess p2 = ipar(9) call mgsro(.false.,n,n,k+1,k+1,fpar(11),w,w(ptr+1), $ ipar(12)) if (ipar(12).lt.0) goto 200 c c apply previous Givens rotations and generate a new one to eliminate c the subdiagonal element. c p2 = ptr + 1 do i = 1, k-1 ptr = p2 p2 = p2 + 1 alpha = w(ptr) c = w(vc+i) s = w(vs+i) w(ptr) = c * alpha + s * w(p2) w(p2) = c * w(p2) - s * alpha enddo call givens(w(p2), w(p2+1), c, s) w(vc+k) = c w(vs+k) = s p2 = vrn + k alpha = - s * w(p2) w(p2) = c * w(p2) w(p2+1) = alpha c c end of one Arnoldi iteration, alpha will store the estimated c residual norm at current stage c fpar(11) = fpar(11) + 6*k + 2 alpha = abs(alpha) fpar(5) = alpha if (k.lt.m .and. .not.(ipar(3).ge.0 .and. alpha.le.fpar(4)) + .and. (ipar(6).le.0 .or. ipar(7).lt.ipar(6))) goto 110 c c update the approximate solution, first solve the upper triangular c system, temporary pointer ptr points to the Hessenberg matrix, c p2 points to the right-hand-side (also the solution) of the system. c 200 ptr = hess + k * (k + 1) / 2 p2 = vrn + k if (w(ptr).eq.zero) then c c if the diagonal elements of the last column is zero, reduce k by 1 c so that a smaller trianguler system is solved [It should only c happen when the matrix is singular, and at most once!] c k = k - 1 if (k.gt.0) then goto 200 else ipar(1) = -3 ipar(12) = -4 goto 300 endif endif w(p2) = w(p2) / w(ptr) do i = k-1, 1, -1 ptr = ptr - i - 1 do ii = 1, i w(vrn+ii) = w(vrn+ii) - w(p2) * w(ptr+ii) enddo p2 = p2 - 1 w(p2) = w(p2) / w(ptr) enddo c do ii = 1, n w(ii) = w(ii) * w(p2) enddo do i = 1, k-1 ptr = i*n p2 = p2 + 1 do ii = 1, n w(ii) = w(ii) + w(p2) * w(ptr+ii) enddo enddo fpar(11) = fpar(11) + 2*k*n - n + k*(k+1) c if (rp) then ipar(1) = 5 ipar(8) = 1 ipar(9) = idx + 1 ipar(10) = 6 return endif c 60 if (rp) then do i = 1, n sol(i) = sol(i) + w(idx+i) enddo else do i = 1, n sol(i) = sol(i) + w(i) enddo endif fpar(11) = fpar(11) + n c c process the complete stopping criteria c if (ipar(3).eq.999) then ipar(1) = 10 ipar(8) = -1 ipar(9) = idx + 1 ipar(10) = 7 return else if (ipar(3).lt.0) then if (ipar(7).le.m+1) then fpar(3) = abs(w(vrn+1)) if (ipar(3).eq.-1) fpar(4) = fpar(1)*fpar(3)+fpar(2) endif fpar(6) = abs(w(vrn+k)) else fpar(6) = fpar(5) endif c c do we need to restart ? c 70 if (ipar(12).ne.0) then ipar(1) = -3 goto 300 endif if ((ipar(7).lt.ipar(6) .or. ipar(6).le.0) .and. + ((ipar(3).eq.999.and.ipar(11).eq.0) .or. + (ipar(3).ne.999.and.fpar(6).gt.fpar(4)))) goto 100 c c termination, set error code, compute convergence rate c if (ipar(1).gt.0) then if (ipar(3).eq.999 .and. ipar(11).eq.1) then ipar(1) = 0 else if (ipar(3).ne.999 .and. fpar(6).le.fpar(4)) then ipar(1) = 0 else if (ipar(7).ge.ipar(6) .and. ipar(6).gt.0) then ipar(1) = -1 else ipar(1) = -10 endif endif 300 if (fpar(3).ne.zero .and. fpar(6).ne.zero .and. + ipar(7).gt.ipar(13)) then fpar(7) = log10(fpar(3) / fpar(6)) / dble(ipar(7)-ipar(13)) else fpar(7) = zero endif return end c-----end-of-gmres c----------------------------------------------------------------------- subroutine dqgmres(n, rhs, sol, ipar, fpar, w) implicit none integer n, ipar(16) real*8 rhs(n), sol(n), fpar(16), w(*) c----------------------------------------------------------------------- c DQGMRES -- Flexible Direct version of Quasi-General Minimum c Residual method. The right preconditioning can be varied from c step to step. c c Work space used = n + lb * (2*n+4) c where lb = ipar(5) + 1 (default 16 if ipar(5) <= 1) c----------------------------------------------------------------------- c local variables c real*8 one,zero,deps parameter(one=1.0D0,zero=0.0D0) parameter(deps=1.0D-33) c integer i,ii,j,jp1,j0,k,ptrw,ptrv,iv,iw,ic,is,ihm,ihd,lb,ptr real*8 alpha,beta,psi,c,s,distdot logical lp,rp,full external distdot,bisinit save c c where to go c if (ipar(1).le.0) ipar(10) = 0 goto (10, 20, 40, 50, 60, 70) ipar(10) c c locations of the work arrays. The arrangement is as follows: c w(1:n) -- temporary storage for the results of the preconditioning c w(iv+1:iw) -- the V's c w(iw+1:ic) -- the W's c w(ic+1:is) -- the COSINEs of the Givens rotations c w(is+1:ihm) -- the SINEs of the Givens rotations c w(ihm+1:ihd) -- the last column of the Hessenberg matrix c w(ihd+1:i) -- the inverse of the diagonals of the Hessenberg matrix c if (ipar(5).le.1) then lb = 16 else lb = ipar(5) + 1 endif iv = n iw = iv + lb * n ic = iw + lb * n is = ic + lb ihm = is + lb ihd = ihm + lb i = ihd + lb c c parameter check, initializations c full = .false. call bisinit(ipar,fpar,i,1,lp,rp,w) if (ipar(1).lt.0) return ipar(1) = 1 if (lp) then do ii = 1, n w(iv+ii) = sol(ii) enddo ipar(8) = iv+1 ipar(9) = 1 else do ii = 1, n w(ii) = sol(ii) enddo ipar(8) = 1 ipar(9) = iv+1 endif ipar(10) = 1 return c 10 ipar(7) = ipar(7) + 1 ipar(13) = ipar(13) + 1 if (lp) then do i = 1, n w(i) = rhs(i) - w(i) enddo ipar(1) = 3 ipar(8) = 1 ipar(9) = iv+1 ipar(10) = 2 return else do i = 1, n w(iv+i) = rhs(i) - w(iv+i) enddo endif fpar(11) = fpar(11) + n c 20 alpha = sqrt(distdot(n, w(iv+1), 1, w(iv+1), 1)) fpar(11) = fpar(11) + (n + n) if (abs(ipar(3)).eq.2) then fpar(4) = fpar(1) * sqrt(distdot(n,rhs,1,rhs,1)) + fpar(2) fpar(11) = fpar(11) + 2*n else if (ipar(3).ne.999) then fpar(4) = fpar(1) * alpha + fpar(2) endif fpar(3) = alpha fpar(5) = alpha psi = alpha if (alpha.le.fpar(4)) then ipar(1) = 0 fpar(6) = alpha goto 80 endif alpha = one / alpha do i = 1, n w(iv+i) = w(iv+i) * alpha enddo fpar(11) = fpar(11) + n j = 0 c c iterations start here c 30 j = j + 1 if (j.gt.lb) j = j - lb jp1 = j + 1 if (jp1.gt.lb) jp1 = jp1 - lb ptrv = iv + (j-1)*n + 1 ptrw = iv + (jp1-1)*n + 1 if (.not.full) then if (j.gt.jp1) full = .true. endif if (full) then j0 = jp1+1 if (j0.gt.lb) j0 = j0 - lb else j0 = 1 endif c c request the caller to perform matrix-vector multiplication and c preconditioning c if (rp) then ipar(1) = 5 ipar(8) = ptrv ipar(9) = ptrv + iw - iv ipar(10) = 3 return else do i = 0, n-1 w(ptrv+iw-iv+i) = w(ptrv+i) enddo endif c 40 ipar(1) = 1 if (rp) then ipar(8) = ipar(9) else ipar(8) = ptrv endif if (lp) then ipar(9) = 1 else ipar(9) = ptrw endif ipar(10) = 4 return c 50 if (lp) then ipar(1) = 3 ipar(8) = ipar(9) ipar(9) = ptrw ipar(10) = 5 return endif c c compute the last column of the Hessenberg matrix c modified Gram-schmidt procedure, orthogonalize against (lb-1) c previous vectors c 60 continue call mgsro(full,n,n,lb,jp1,fpar(11),w(iv+1),w(ihm+1), $ ipar(12)) if (ipar(12).lt.0) then ipar(1) = -3 goto 80 endif beta = w(ihm+jp1) c c incomplete factorization (QR factorization through Givens rotations) c (1) apply previous rotations [(lb-1) of them] c (2) generate a new rotation c if (full) then w(ihm+jp1) = w(ihm+j0) * w(is+jp1) w(ihm+j0) = w(ihm+j0) * w(ic+jp1) endif i = j0 do while (i.ne.j) k = i+1 if (k.gt.lb) k = k - lb c = w(ic+i) s = w(is+i) alpha = w(ihm+i) w(ihm+i) = c * alpha + s * w(ihm+k) w(ihm+k) = c * w(ihm+k) - s * alpha i = k enddo call givens(w(ihm+j), beta, c, s) if (full) then fpar(11) = fpar(11) + 6 * lb else fpar(11) = fpar(11) + 6 * j endif c c detect whether diagonal element of this column is zero c if (abs(w(ihm+j)).lt.deps) then ipar(1) = -3 goto 80 endif w(ihd+j) = one / w(ihm+j) w(ic+j) = c w(is+j) = s c c update the W's (the conjugate directions) -- essentially this is one c step of triangular solve. c ptrw = iw+(j-1)*n + 1 if (full) then do i = j+1, lb alpha = -w(ihm+i)*w(ihd+i) ptr = iw+(i-1)*n+1 do ii = 0, n-1 w(ptrw+ii) = w(ptrw+ii) + alpha * w(ptr+ii) enddo enddo endif do i = 1, j-1 alpha = -w(ihm+i)*w(ihd+i) ptr = iw+(i-1)*n+1 do ii = 0, n-1 w(ptrw+ii) = w(ptrw+ii) + alpha * w(ptr+ii) enddo enddo c c update the solution to the linear system c alpha = psi * c * w(ihd+j) psi = - s * psi do i = 1, n sol(i) = sol(i) + alpha * w(ptrw-1+i) enddo if (full) then fpar(11) = fpar(11) + lb * (n+n) else fpar(11) = fpar(11) + j * (n+n) endif c c determine whether to continue, c compute the desired error/residual norm c ipar(7) = ipar(7) + 1 fpar(5) = abs(psi) if (ipar(3).eq.999) then ipar(1) = 10 ipar(8) = -1 ipar(9) = 1 ipar(10) = 6 return endif if (ipar(3).lt.0) then alpha = abs(alpha) if (ipar(7).eq.2 .and. ipar(3).eq.-1) then fpar(3) = alpha*sqrt(distdot(n, w(ptrw), 1, w(ptrw), 1)) fpar(4) = fpar(1) * fpar(3) + fpar(2) fpar(6) = fpar(3) else fpar(6) = alpha*sqrt(distdot(n, w(ptrw), 1, w(ptrw), 1)) endif fpar(11) = fpar(11) + 2 * n else fpar(6) = fpar(5) endif if (ipar(1).ge.0 .and. fpar(6).gt.fpar(4) .and. (ipar(6).le.0 + .or. ipar(7).lt.ipar(6))) goto 30 70 if (ipar(3).eq.999 .and. ipar(11).eq.0) goto 30 c c clean up the iterative solver c 80 fpar(7) = zero if (fpar(3).ne.zero .and. fpar(6).ne.zero .and. + ipar(7).gt.ipar(13)) + fpar(7) = log10(fpar(3) / fpar(6)) / dble(ipar(7)-ipar(13)) if (ipar(1).gt.0) then if (ipar(3).eq.999 .and. ipar(11).ne.0) then ipar(1) = 0 else if (fpar(6).le.fpar(4)) then ipar(1) = 0 else if (ipar(6).gt.0 .and. ipar(7).ge.ipar(6)) then ipar(1) = -1 else ipar(1) = -10 endif endif return end c-----end-of-dqgmres c----------------------------------------------------------------------- subroutine fgmres(n, rhs, sol, ipar, fpar, w) implicit none integer n, ipar(16) real*8 rhs(n), sol(n), fpar(16), w(*) c----------------------------------------------------------------------- c This a version of FGMRES implemented with reverse communication. c c ipar(5) == the dimension of the Krylov subspace c c the space of the `w' is used as follows: c >> V: the bases for the Krylov subspace, size n*(m+1); c >> W: the above bases after (left-)multiplying with the c right-preconditioner inverse, size m*n; c >> a temporary vector of size n; c >> the Hessenberg matrix, only the upper triangular portion c of the matrix is stored, size (m+1)*m/2 + 1 c >> three vectors, first two are of size m, they are the cosine c and sine of the Givens rotations, the third one holds the c residuals, it is of size m+1. c c TOTAL SIZE REQUIRED == n*(2m+1) + (m+1)*m/2 + 3*m + 2 c Note: m == ipar(5). The default value for this is 15 if c ipar(5) <= 1. c----------------------------------------------------------------------- c external functions used c real*8 distdot external distdot c real*8 one, zero parameter(one=1.0D0, zero=0.0D0) c c local variables, ptr and p2 are temporary pointers, c hess points to the Hessenberg matrix, c vc, vs point to the cosines and sines of the Givens rotations c vrn points to the vectors of residual norms, more precisely c the right hand side of the least square problem solved. c integer i,ii,idx,iz,k,m,ptr,p2,hess,vc,vs,vrn real*8 alpha, c, s logical lp, rp save c c check the status of the call c if (ipar(1).le.0) ipar(10) = 0 goto (10, 20, 30, 40, 50, 60) ipar(10) c c initialization c if (ipar(5).le.1) then m = 15 else m = ipar(5) endif idx = n * (m+1) iz = idx + n hess = iz + n*m vc = hess + (m+1) * m / 2 + 1 vs = vc + m vrn = vs + m i = vrn + m + 1 call bisinit(ipar,fpar,i,1,lp,rp,w) if (ipar(1).lt.0) return c c request for matrix vector multiplication A*x in the initialization c 100 ipar(1) = 1 ipar(8) = n+1 ipar(9) = 1 ipar(10) = 1 k = 0 do ii = 1, n w(ii+n) = sol(ii) enddo return 10 ipar(7) = ipar(7) + 1 ipar(13) = ipar(13) + 1 fpar(11) = fpar(11) + n if (lp) then do i = 1, n w(n+i) = rhs(i) - w(i) enddo ipar(1) = 3 ipar(10) = 2 return else do i = 1, n w(i) = rhs(i) - w(i) enddo endif c 20 alpha = sqrt(distdot(n,w,1,w,1)) fpar(11) = fpar(11) + n + n if (ipar(7).eq.1 .and. ipar(3).ne.999) then if (abs(ipar(3)).eq.2) then fpar(4) = fpar(1) * sqrt(distdot(n,rhs,1,rhs,1)) + fpar(2) fpar(11) = fpar(11) + 2*n else fpar(4) = fpar(1) * alpha + fpar(2) endif fpar(3) = alpha endif fpar(5) = alpha w(vrn+1) = alpha if (alpha.le.fpar(4) .and. ipar(3).ge.0 .and. ipar(3).ne.999) then ipar(1) = 0 fpar(6) = alpha goto 300 endif alpha = one / alpha do ii = 1, n w(ii) = w(ii) * alpha enddo fpar(11) = fpar(11) + n c c request for (1) right preconditioning c (2) matrix vector multiplication c (3) left preconditioning c 110 k = k + 1 if (rp) then ipar(1) = 5 ipar(8) = k*n - n + 1 ipar(9) = iz + ipar(8) ipar(10) = 3 return else do ii = 0, n-1 w(iz+k*n-ii) = w(k*n-ii) enddo endif c 30 ipar(1) = 1 if (rp) then ipar(8) = ipar(9) else ipar(8) = (k-1)*n + 1 endif if (lp) then ipar(9) = idx + 1 else ipar(9) = 1 + k*n endif ipar(10) = 4 return c 40 if (lp) then ipar(1) = 3 ipar(8) = ipar(9) ipar(9) = k*n + 1 ipar(10) = 5 return endif c c Modified Gram-Schmidt orthogonalization procedure c temporary pointer 'ptr' is pointing to the current column of the c Hessenberg matrix. 'p2' points to the new basis vector c 50 ptr = k * (k - 1) / 2 + hess p2 = ipar(9) ipar(7) = ipar(7) + 1 call mgsro(.false.,n,n,k+1,k+1,fpar(11),w,w(ptr+1), $ ipar(12)) if (ipar(12).lt.0) goto 200 c c apply previous Givens rotations and generate a new one to eliminate c the subdiagonal element. c p2 = ptr + 1 do i = 1, k-1 ptr = p2 p2 = p2 + 1 alpha = w(ptr) c = w(vc+i) s = w(vs+i) w(ptr) = c * alpha + s * w(p2) w(p2) = c * w(p2) - s * alpha enddo call givens(w(p2), w(p2+1), c, s) w(vc+k) = c w(vs+k) = s p2 = vrn + k alpha = - s * w(p2) w(p2) = c * w(p2) w(p2+1) = alpha fpar(11) = fpar(11) + 6 * k c c end of one Arnoldi iteration, alpha will store the estimated c residual norm at current stage c alpha = abs(alpha) fpar(5) = alpha if (k.lt.m .and. .not.(ipar(3).ge.0 .and. alpha.le.fpar(4)) + .and. (ipar(6).le.0 .or. ipar(7).lt.ipar(6))) goto 110 c c update the approximate solution, first solve the upper triangular c system, temporary pointer ptr points to the Hessenberg matrix, c p2 points to the right-hand-side (also the solution) of the system. c 200 ptr = hess + k * (k + 1 ) / 2 p2 = vrn + k if (w(ptr).eq.zero) then c c if the diagonal elements of the last column is zero, reduce k by 1 c so that a smaller trianguler system is solved [It should only c happen when the matrix is singular!] c k = k - 1 if (k.gt.0) then goto 200 else ipar(1) = -3 ipar(12) = -4 goto 300 endif endif w(p2) = w(p2) / w(ptr) do i = k-1, 1, -1 ptr = ptr - i - 1 do ii = 1, i w(vrn+ii) = w(vrn+ii) - w(p2) * w(ptr+ii) enddo p2 = p2 - 1 w(p2) = w(p2) / w(ptr) enddo c do i = 0, k-1 ptr = iz+i*n do ii = 1, n sol(ii) = sol(ii) + w(p2)*w(ptr+ii) enddo p2 = p2 + 1 enddo fpar(11) = fpar(11) + 2*k*n + k*(k+1) c c process the complete stopping criteria c if (ipar(3).eq.999) then ipar(1) = 10 ipar(8) = -1 ipar(9) = idx + 1 ipar(10) = 6 return else if (ipar(3).lt.0) then if (ipar(7).le.m+1) then fpar(3) = abs(w(vrn+1)) if (ipar(3).eq.-1) fpar(4) = fpar(1)*fpar(3)+fpar(2) endif fpar(6) = abs(w(vrn+k)) else if (ipar(3).ne.999) then fpar(6) = fpar(5) endif c c do we need to restart ? c 60 if (ipar(12).ne.0) then ipar(1) = -3 goto 300 endif if ((ipar(7).lt.ipar(6) .or. ipar(6).le.0).and. + ((ipar(3).eq.999.and.ipar(11).eq.0) .or. + (ipar(3).ne.999.and.fpar(6).gt.fpar(4)))) goto 100 c c termination, set error code, compute convergence rate c if (ipar(1).gt.0) then if (ipar(3).eq.999 .and. ipar(11).eq.1) then ipar(1) = 0 else if (ipar(3).ne.999 .and. fpar(6).le.fpar(4)) then ipar(1) = 0 else if (ipar(7).ge.ipar(6) .and. ipar(6).gt.0) then ipar(1) = -1 else ipar(1) = -10 endif endif 300 if (fpar(3).ne.zero .and. fpar(6).ne.zero .and. $ ipar(7).gt.ipar(13)) then fpar(7) = log10(fpar(3) / fpar(6)) / dble(ipar(7)-ipar(13)) else fpar(7) = zero endif return end c-----end-of-fgmres c----------------------------------------------------------------------- subroutine dbcg (n,rhs,sol,ipar,fpar,w) implicit none integer n,ipar(16) real*8 rhs(n), sol(n), fpar(16), w(n,*) c----------------------------------------------------------------------- c Quasi GMRES method for solving a linear c system of equations a * sol = y. double precision version. c this version is without restarting and without preconditioning. c parameters : c ----------- c n = dimension of the problem c c y = w(:,1) a temporary storage used for various operations c z = w(:,2) a work vector of length n. c v = w(:,3:4) size n x 2 c w = w(:,5:6) size n x 2 c p = w(:,7:9) work array of dimension n x 3 c del x = w(:,10) accumulation of the changes in solution c tmp = w(:,11) a temporary vector used to hold intermediate result of c preconditioning, etc. c c sol = the solution of the problem . at input sol must contain an c initial guess to the solution. c *** note: y is destroyed on return. c c----------------------------------------------------------------------- c subroutines and functions called: c 1) matrix vector multiplication and preconditioning through reverse c communication c c 2) implu, uppdir, distdot (blas) c----------------------------------------------------------------------- c aug. 1983 version. author youcef saad. yale university computer c science dept. some changes made july 3, 1986. c references: siam j. sci. stat. comp., vol. 5, pp. 203-228 (1984) c----------------------------------------------------------------------- c local variables c real*8 one,zero parameter(one=1.0D0,zero=0.0D0) c real*8 t,sqrt,distdot,ss,res,beta,ss1,delta,x,zeta,umm integer k,j,i,i2,ip2,ju,lb,lbm1,np,indp logical lp,rp,full, perm(3) real*8 ypiv(3),u(3),usav(3) external tidycg save c c where to go c if (ipar(1).le.0) ipar(10) = 0 goto (110, 120, 130, 140, 150, 160, 170, 180, 190, 200) ipar(10) c c initialization, parameter checking, clear the work arrays c call bisinit(ipar,fpar,11*n,1,lp,rp,w) if (ipar(1).lt.0) return perm(1) = .false. perm(2) = .false. perm(3) = .false. usav(1) = zero usav(2) = zero usav(3) = zero ypiv(1) = zero ypiv(2) = zero ypiv(3) = zero c----------------------------------------------------------------------- c initialize constants for outer loop : c----------------------------------------------------------------------- lb = 3 lbm1 = 2 c c get initial residual vector and norm c ipar(1) = 1 ipar(8) = 1 ipar(9) = 1 + n do i = 1, n w(i,1) = sol(i) enddo ipar(10) = 1 return 110 ipar(7) = ipar(7) + 1 ipar(13) = ipar(13) + 1 if (lp) then do i = 1, n w(i,1) = rhs(i) - w(i,2) enddo ipar(1) = 3 ipar(8) = 1 ipar(9) = n+n+1 ipar(10) = 2 return else do i = 1, n w(i,3) = rhs(i) - w(i,2) enddo endif fpar(11) = fpar(11) + n c 120 fpar(3) = sqrt(distdot(n,w(1,3),1,w(1,3),1)) fpar(11) = fpar(11) + n + n fpar(5) = fpar(3) fpar(7) = fpar(3) zeta = fpar(3) if (abs(ipar(3)).eq.2) then fpar(4) = fpar(1) * sqrt(distdot(n,rhs,1,rhs,1)) + fpar(2) fpar(11) = fpar(11) + 2*n else if (ipar(3).ne.999) then fpar(4) = fpar(1) * zeta + fpar(2) endif if (ipar(3).ge.0.and.fpar(5).le.fpar(4)) then fpar(6) = fpar(5) goto 900 endif c c normalize first arnoldi vector c t = one/zeta do 22 k=1,n w(k,3) = w(k,3)*t w(k,5) = w(k,3) 22 continue fpar(11) = fpar(11) + n c c initialize constants for main loop c beta = zero delta = zero i2 = 1 indp = 0 i = 0 c c main loop: i = index of the loop. c c----------------------------------------------------------------------- 30 i = i + 1 c if (rp) then ipar(1) = 5 ipar(8) = (1+i2)*n+1 if (lp) then ipar(9) = 1 else ipar(9) = 10*n + 1 endif ipar(10) = 3 return endif c 130 ipar(1) = 1 if (rp) then ipar(8) = ipar(9) else ipar(8) = (1+i2)*n + 1 endif if (lp) then ipar(9) = 10*n + 1 else ipar(9) = 1 endif ipar(10) = 4 return c 140 if (lp) then ipar(1) = 3 ipar(8) = ipar(9) ipar(9) = 1 ipar(10) = 5 return endif c c A^t * x c 150 ipar(7) = ipar(7) + 1 if (lp) then ipar(1) = 4 ipar(8) = (3+i2)*n + 1 if (rp) then ipar(9) = n + 1 else ipar(9) = 10*n + 1 endif ipar(10) = 6 return endif c 160 ipar(1) = 2 if (lp) then ipar(8) = ipar(9) else ipar(8) = (3+i2)*n + 1 endif if (rp) then ipar(9) = 10*n + 1 else ipar(9) = n + 1 endif ipar(10) = 7 return c 170 if (rp) then ipar(1) = 6 ipar(8) = ipar(9) ipar(9) = n + 1 ipar(10) = 8 return endif c----------------------------------------------------------------------- c orthogonalize current v against previous v's and c determine relevant part of i-th column of u(.,.) the c upper triangular matrix -- c----------------------------------------------------------------------- 180 ipar(7) = ipar(7) + 1 u(1) = zero ju = 1 k = i2 if (i .le. lbm1) ju = 0 if (i .lt. lb) k = 0 31 if (k .eq. lbm1) k=0 k=k+1 c if (k .ne. i2) then ss = delta ss1 = beta ju = ju + 1 u(ju) = ss else ss = distdot(n,w(1,1),1,w(1,4+k),1) fpar(11) = fpar(11) + 2*n ss1= ss ju = ju + 1 u(ju) = ss endif c do 32 j=1,n w(j,1) = w(j,1) - ss*w(j,k+2) w(j,2) = w(j,2) - ss1*w(j,k+4) 32 continue fpar(11) = fpar(11) + 4*n c if (k .ne. i2) goto 31 c c end of Mod. Gram. Schmidt loop c t = distdot(n,w(1,2),1,w(1,1),1) c beta = sqrt(abs(t)) delta = t/beta c ss = one/beta ss1 = one/ delta c c normalize and insert new vectors c ip2 = i2 if (i2 .eq. lbm1) i2=0 i2=i2+1 c do 315 j=1,n w(j,i2+2)=w(j,1)*ss w(j,i2+4)=w(j,2)*ss1 315 continue fpar(11) = fpar(11) + 4*n c----------------------------------------------------------------------- c end of orthogonalization. c now compute the coefficients u(k) of the last c column of the l . u factorization of h . c----------------------------------------------------------------------- np = min0(i,lb) full = (i .ge. lb) call implu(np, umm, beta, ypiv, u, perm, full) c----------------------------------------------------------------------- c update conjugate directions and solution c----------------------------------------------------------------------- do 33 k=1,n w(k,1) = w(k,ip2+2) 33 continue call uppdir(n, w(1,7), np, lb, indp, w, u, usav, fpar(11)) c----------------------------------------------------------------------- if (i .eq. 1) goto 34 j = np - 1 if (full) j = j-1 if (.not.perm(j)) zeta = -zeta*ypiv(j) 34 x = zeta/u(np) if (perm(np))goto 36 do 35 k=1,n w(k,10) = w(k,10) + x*w(k,1) 35 continue fpar(11) = fpar(11) + 2 * n c----------------------------------------------------------------------- 36 if (ipar(3).eq.999) then ipar(1) = 10 ipar(8) = 9*n + 1 ipar(9) = 10*n + 1 ipar(10) = 9 return endif res = abs(beta*zeta/umm) fpar(5) = res * sqrt(distdot(n, w(1,i2+2), 1, w(1,i2+2), 1)) fpar(11) = fpar(11) + 2 * n if (ipar(3).lt.0) then fpar(6) = x * sqrt(distdot(n,w,1,w,1)) fpar(11) = fpar(11) + 2 * n if (ipar(7).le.3) then fpar(3) = fpar(6) if (ipar(3).eq.-1) then fpar(4) = fpar(1) * sqrt(fpar(3)) + fpar(2) endif endif else fpar(6) = fpar(5) endif c---- convergence test ----------------------------------------------- 190 if (ipar(3).eq.999.and.ipar(11).eq.0) then goto 30 else if (fpar(6).gt.fpar(4) .and. (ipar(6).gt.ipar(7) .or. + ipar(6).le.0)) then goto 30 endif c----------------------------------------------------------------------- c here the fact that the last step is different is accounted for. c----------------------------------------------------------------------- if (.not. perm(np)) goto 900 x = zeta/umm do 40 k = 1,n w(k,10) = w(k,10) + x*w(k,1) 40 continue fpar(11) = fpar(11) + 2 * n c c right preconditioning and clean-up jobs c 900 if (rp) then if (ipar(1).lt.0) ipar(12) = ipar(1) ipar(1) = 5 ipar(8) = 9*n + 1 ipar(9) = ipar(8) + n ipar(10) = 10 return endif 200 if (rp) then call tidycg(n,ipar,fpar,sol,w(1,11)) else call tidycg(n,ipar,fpar,sol,w(1,10)) endif return end c-----end-of-dbcg------------------------------------------------------- c----------------------------------------------------------------------- subroutine implu(np,umm,beta,ypiv,u,permut,full) real*8 umm,beta,ypiv(*),u(*),x, xpiv logical full, perm, permut(*) integer np,k,npm1 c----------------------------------------------------------------------- c performs implicitly one step of the lu factorization of a c banded hessenberg matrix. c----------------------------------------------------------------------- if (np .le. 1) goto 12 npm1 = np - 1 c c -- perform previous step of the factorization- c do 6 k=1,npm1 if (.not. permut(k)) goto 5 x=u(k) u(k) = u(k+1) u(k+1) = x 5 u(k+1) = u(k+1) - ypiv(k)*u(k) 6 continue c----------------------------------------------------------------------- c now determine pivotal information to be used in the next call c----------------------------------------------------------------------- 12 umm = u(np) perm = (beta .gt. abs(umm)) if (.not. perm) goto 4 xpiv = umm / beta u(np) = beta goto 8 4 xpiv = beta/umm 8 permut(np) = perm ypiv(np) = xpiv if (.not. full) return c shift everything up if full... do 7 k=1,npm1 ypiv(k) = ypiv(k+1) permut(k) = permut(k+1) 7 continue return c-----end-of-implu end c----------------------------------------------------------------------- subroutine uppdir(n,p,np,lbp,indp,y,u,usav,flops) real*8 p(n,lbp), y(*), u(*), usav(*), x, flops integer k,np,n,npm1,j,ju,indp,lbp c----------------------------------------------------------------------- c updates the conjugate directions p given the upper part of the c banded upper triangular matrix u. u contains the non zero c elements of the column of the triangular matrix.. c----------------------------------------------------------------------- real*8 zero parameter(zero=0.0D0) c npm1=np-1 if (np .le. 1) goto 12 j=indp ju = npm1 10 if (j .le. 0) j=lbp x = u(ju) /usav(j) if (x .eq. zero) goto 115 do 11 k=1,n y(k) = y(k) - x*p(k,j) 11 continue flops = flops + 2*n 115 j = j-1 ju = ju -1 if (ju .ge. 1) goto 10 12 indp = indp + 1 if (indp .gt. lbp) indp = 1 usav(indp) = u(np) do 13 k=1,n p(k,indp) = y(k) 13 continue 208 return c----------------------------------------------------------------------- c-------end-of-uppdir--------------------------------------------------- end subroutine givens(x,y,c,s) real*8 x,y,c,s c----------------------------------------------------------------------- c Given x and y, this subroutine generates a Givens' rotation c, s. c And apply the rotation on (x,y) ==> (sqrt(x**2 + y**2), 0). c (See P 202 of "matrix computation" by Golub and van Loan.) c----------------------------------------------------------------------- real*8 t,one,zero parameter (zero=0.0D0,one=1.0D0) c if (x.eq.zero .and. y.eq.zero) then c = one s = zero else if (abs(y).gt.abs(x)) then t = x / y x = sqrt(one+t*t) s = sign(one / x, y) c = t*s else if (abs(y).le.abs(x)) then t = y / x y = sqrt(one+t*t) c = sign(one / y, x) s = t*c else c c X or Y must be an invalid floating-point number, set both to zero c x = zero y = zero c = one s = zero endif x = abs(x*y) c c end of givens c return end c-----end-of-givens c----------------------------------------------------------------------- logical function stopbis(n,ipar,mvpi,fpar,r,delx,sx) implicit none integer n,mvpi,ipar(16) real*8 fpar(16), r(n), delx(n), sx, distdot external distdot c----------------------------------------------------------------------- c function for determining the stopping criteria. return value of c true if the stopbis criteria is satisfied. c----------------------------------------------------------------------- if (ipar(11) .eq. 1) then stopbis = .true. else stopbis = .false. endif if (ipar(6).gt.0 .and. ipar(7).ge.ipar(6)) then ipar(1) = -1 stopbis = .true. endif if (stopbis) return c c computes errors c fpar(5) = sqrt(distdot(n,r,1,r,1)) fpar(11) = fpar(11) + 2 * n if (ipar(3).lt.0) then c c compute the change in the solution vector c fpar(6) = sx * sqrt(distdot(n,delx,1,delx,1)) fpar(11) = fpar(11) + 2 * n if (ipar(7).lt.mvpi+mvpi+1) then c c if this is the end of the first iteration, set fpar(3:4) c fpar(3) = fpar(6) if (ipar(3).eq.-1) then fpar(4) = fpar(1) * fpar(3) + fpar(2) endif endif else fpar(6) = fpar(5) endif c c .. the test is struct this way so that when the value in fpar(6) c is not a valid number, STOPBIS is set to .true. c if (fpar(6).gt.fpar(4)) then stopbis = .false. ipar(11) = 0 else stopbis = .true. ipar(11) = 1 endif c return end c-----end-of-stopbis c----------------------------------------------------------------------- subroutine tidycg(n,ipar,fpar,sol,delx) implicit none integer i,n,ipar(16) real*8 fpar(16),sol(n),delx(n) c----------------------------------------------------------------------- c Some common operations required before terminating the CG routines c----------------------------------------------------------------------- real*8 zero parameter(zero=0.0D0) c if (ipar(12).ne.0) then ipar(1) = ipar(12) else if (ipar(1).gt.0) then if ((ipar(3).eq.999 .and. ipar(11).eq.1) .or. + fpar(6).le.fpar(4)) then ipar(1) = 0 else if (ipar(7).ge.ipar(6) .and. ipar(6).gt.0) then ipar(1) = -1 else ipar(1) = -10 endif endif if (fpar(3).gt.zero .and. fpar(6).gt.zero .and. + ipar(7).gt.ipar(13)) then fpar(7) = log10(fpar(3) / fpar(6)) / dble(ipar(7)-ipar(13)) else fpar(7) = zero endif do i = 1, n sol(i) = sol(i) + delx(i) enddo return end c-----end-of-tidycg c----------------------------------------------------------------------- logical function brkdn(alpha, ipar) implicit none integer ipar(16) real*8 alpha, beta, zero, one parameter (zero=0.0D0, one=1.0D0) c----------------------------------------------------------------------- c test whether alpha is zero or an abnormal number, if yes, c this routine will return .true. c c If alpha == 0, ipar(1) = -3, c if alpha is an abnormal number, ipar(1) = -9. c----------------------------------------------------------------------- brkdn = .false. if (alpha.gt.zero) then beta = one / alpha if (.not. beta.gt.zero) then brkdn = .true. ipar(1) = -9 endif else if (alpha.lt.zero) then beta = one / alpha if (.not. beta.lt.zero) then brkdn = .true. ipar(1) = -9 endif else if (alpha.eq.zero) then brkdn = .true. ipar(1) = -3 else brkdn = .true. ipar(1) = -9 endif return end c-----end-of-brkdn c----------------------------------------------------------------------- subroutine bisinit(ipar,fpar,wksize,dsc,lp,rp,wk) implicit none integer i,ipar(16),wksize,dsc logical lp,rp real*8 fpar(16),wk(*) c----------------------------------------------------------------------- c some common initializations for the iterative solvers c----------------------------------------------------------------------- real*8 zero, one parameter(zero=0.0D0, one=1.0D0) c c ipar(1) = -2 inidcate that there are not enough space in the work c array c if (ipar(4).lt.wksize) then ipar(1) = -2 ipar(4) = wksize return endif c if (ipar(2).gt.2) then lp = .true. rp = .true. else if (ipar(2).eq.2) then lp = .false. rp = .true. else if (ipar(2).eq.1) then lp = .true. rp = .false. else lp = .false. rp = .false. endif if (ipar(3).eq.0) ipar(3) = dsc c .. clear the ipar elements used ipar(7) = 0 ipar(8) = 0 ipar(9) = 0 ipar(10) = 0 ipar(11) = 0 ipar(12) = 0 ipar(13) = 0 c c fpar(1) must be between (0, 1), fpar(2) must be positive, c fpar(1) and fpar(2) can NOT both be zero c Normally return ipar(1) = -4 to indicate any of above error c if (fpar(1).lt.zero .or. fpar(1).ge.one .or. fpar(2).lt.zero .or. & (fpar(1).eq.zero .and. fpar(2).eq.zero)) then if (ipar(1).eq.0) then ipar(1) = -4 return else fpar(1) = 1.0D-6 fpar(2) = 1.0D-16 endif endif c .. clear the fpar elements do i = 3, 10 fpar(i) = zero enddo if (fpar(11).lt.zero) fpar(11) = zero c .. clear the used portion of the work array to zero do i = 1, wksize wk(i) = zero enddo c return c-----end-of-bisinit end c----------------------------------------------------------------------- subroutine mgsro(full,lda,n,m,ind,ops,vec,hh,ierr) implicit none logical full integer lda,m,n,ind,ierr real*8 ops,hh(m),vec(lda,m) c----------------------------------------------------------------------- c MGSRO -- Modified Gram-Schmidt procedure with Selective Re- c Orthogonalization c The ind'th vector of VEC is orthogonalized against the rest of c the vectors. c c The test for performing re-orthogonalization is performed for c each indivadual vectors. If the cosine between the two vectors c is greater than 0.99 (REORTH = 0.99**2), re-orthogonalization is c performed. The norm of the 'new' vector is kept in variable NRM0, c and updated after operating with each vector. c c full -- .ture. if it is necessary to orthogonalize the ind'th c against all the vectors vec(:,1:ind-1), vec(:,ind+2:m) c .false. only orthogonalize againt vec(:,1:ind-1) c lda -- the leading dimension of VEC c n -- length of the vector in VEC c m -- number of vectors can be stored in VEC c ind -- index to the vector to be changed c ops -- operation counts c vec -- vector of LDA X M storing the vectors c hh -- coefficient of the orthogonalization c ierr -- error code c 0 : successful return c -1: zero input vector c -2: input vector contains abnormal numbers c -3: input vector is a linear combination of others c c External routines used: real*8 distdot c----------------------------------------------------------------------- integer i,k real*8 nrm0, nrm1, fct, thr, distdot, zero, one, reorth parameter (zero=0.0D0, one=1.0D0, reorth=0.98D0) external distdot c c compute the norm of the input vector c nrm0 = distdot(n,vec(1,ind),1,vec(1,ind),1) ops = ops + n + n thr = nrm0 * reorth if (nrm0.le.zero) then ierr = - 1 return else if (nrm0.gt.zero .and. one/nrm0.gt.zero) then ierr = 0 else ierr = -2 return endif c c Modified Gram-Schmidt loop c if (full) then do 40 i = ind+1, m fct = distdot(n,vec(1,ind),1,vec(1,i),1) hh(i) = fct do 20 k = 1, n vec(k,ind) = vec(k,ind) - fct * vec(k,i) 20 continue ops = ops + 4 * n + 2 if (fct*fct.gt.thr) then fct = distdot(n,vec(1,ind),1,vec(1,i),1) hh(i) = hh(i) + fct do 30 k = 1, n vec(k,ind) = vec(k,ind) - fct * vec(k,i) 30 continue ops = ops + 4*n + 1 endif nrm0 = nrm0 - hh(i) * hh(i) if (nrm0.lt.zero) nrm0 = zero thr = nrm0 * reorth 40 continue endif c do 70 i = 1, ind-1 fct = distdot(n,vec(1,ind),1,vec(1,i),1) hh(i) = fct do 50 k = 1, n vec(k,ind) = vec(k,ind) - fct * vec(k,i) 50 continue ops = ops + 4 * n + 2 if (fct*fct.gt.thr) then fct = distdot(n,vec(1,ind),1,vec(1,i),1) hh(i) = hh(i) + fct do 60 k = 1, n vec(k,ind) = vec(k,ind) - fct * vec(k,i) 60 continue ops = ops + 4*n + 1 endif nrm0 = nrm0 - hh(i) * hh(i) if (nrm0.lt.zero) nrm0 = zero thr = nrm0 * reorth 70 continue c c test the resulting vector c nrm1 = sqrt(distdot(n,vec(1,ind),1,vec(1,ind),1)) ops = ops + n + n 75 hh(ind) = nrm1 if (nrm1.le.zero) then ierr = -3 return endif c c scale the resulting vector c fct = one / nrm1 do 80 k = 1, n vec(k,ind) = vec(k,ind) * fct 80 continue ops = ops + n + 1 c c normal return c ierr = 0 return c end surbotine mgsro end getdp-2.4.2-source/contrib/Sparskit/CMakeLists.txt000644 001750 001750 00000000676 12116424200 023601 0ustar00geuzainegeuzaine000000 000000 # GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine # # See the LICENSE.txt file for license information. Please report all # bugs and problems to the public mailing list . set(SRC Sparskit.cpp blas1.f blassm.f cmkreord.f flu.f formats.f inout.f iters.f matvec.f reordering.f unary.f ilut.F ) file(GLOB HDR RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} *.h) append_getdp_src(contrib/Sparskit "${SRC};${HDR}") getdp-2.4.2-source/contrib/Sparskit/blassm.f000644 001750 001750 00000104227 11266605601 022501 0ustar00geuzainegeuzaine000000 000000 c $Id: blassm.f,v 1.1 2008-04-11 06:01:06 geuzaine Exp $ c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c BASIC LINEAR ALGEBRA FOR SPARSE MATRICES. BLASSM MODULE c c----------------------------------------------------------------------c c amub : computes C = A*B c c aplb : computes C = A+B c c aplb1 : computes C = A+B [Sorted version: A, B, C sorted] c c aplsb : computes C = A + s B c c aplsb1 : computes C = A+sB [Sorted version: A, B, C sorted] c c apmbt : Computes C = A +/- transp(B) c c aplsbt : Computes C = A + s * transp(B) c c diamua : Computes C = Diag * A c c amudia : Computes C = A* Diag c c aplsca : Computes A:= A + s I (s = scalar) c c apldia : Computes C = A + Diag. c c----------------------------------------------------------------------c c Note: this module still incomplete. c c----------------------------------------------------------------------c subroutine amub (nrow,ncol,job,a,ja,ia,b,jb,ib, * c,jc,ic,nzmax,iw,ierr) real*8 a(*), b(*), c(*) integer ja(*),jb(*),jc(*),ia(nrow+1),ib(*),ic(*),iw(ncol) c----------------------------------------------------------------------- c performs the matrix by matrix product C = A B c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A = row dimension of C c ncol = integer. The column dimension of B = column dimension of C c job = integer. Job indicator. When job = 0, only the structure c (i.e. the arrays jc, ic) is computed and the c real values are ignored. c c a, c ja, c ia = Matrix A in compressed sparse row format. c c b, c jb, c ib = Matrix B in compressed sparse row format. c c nzmax = integer. The length of the arrays c and jc. c amub will stop if the result matrix C has a number c of elements that exceeds exceeds nzmax. See ierr. c c on return: c---------- c c, c jc, c ic = resulting matrix C in compressed sparse row sparse format. c c ierr = integer. serving as error message. c ierr = 0 means normal return, c ierr .gt. 0 means that amub stopped while computing the c i-th row of C with i=ierr, because the number c of elements in C exceeds nzmax. c c work arrays: c------------ c iw = integer work array of length equal to the number of c columns in A. c Note: c------- c The row dimension of B is not needed. However there is no checking c on the condition that ncol(A) = nrow(B). c c----------------------------------------------------------------------- real*8 scal logical values values = (job .ne. 0) len = 0 ic(1) = 1 ierr = 0 c initialize array iw. do 1 j=1, ncol iw(j) = 0 1 continue c do 500 ii=1, nrow c row i do 200 ka=ia(ii), ia(ii+1)-1 if (values) scal = a(ka) jj = ja(ka) do 100 kb=ib(jj),ib(jj+1)-1 jcol = jb(kb) jpos = iw(jcol) if (jpos .eq. 0) then len = len+1 if (len .gt. nzmax) then ierr = ii return endif jc(len) = jcol iw(jcol)= len if (values) c(len) = scal*b(kb) else if (values) c(jpos) = c(jpos) + scal*b(kb) endif 100 continue 200 continue do 201 k=ic(ii), len iw(jc(k)) = 0 201 continue ic(ii+1) = len+1 500 continue return c-------------end-of-amub----------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine aplb (nrow,ncol,job,a,ja,ia,b,jb,ib, * c,jc,ic,nzmax,iw,ierr) real*8 a(*), b(*), c(*) integer ja(*),jb(*),jc(*),ia(nrow+1),ib(nrow+1),ic(nrow+1), * iw(ncol) c----------------------------------------------------------------------- c performs the matrix sum C = A+B. c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A and B c ncol = integer. The column dimension of A and B. c job = integer. Job indicator. When job = 0, only the structure c (i.e. the arrays jc, ic) is computed and the c real values are ignored. c c a, c ja, c ia = Matrix A in compressed sparse row format. c c b, c jb, c ib = Matrix B in compressed sparse row format. c c nzmax = integer. The length of the arrays c and jc. c amub will stop if the result matrix C has a number c of elements that exceeds exceeds nzmax. See ierr. c c on return: c---------- c c, c jc, c ic = resulting matrix C in compressed sparse row sparse format. c c ierr = integer. serving as error message. c ierr = 0 means normal return, c ierr .gt. 0 means that amub stopped while computing the c i-th row of C with i=ierr, because the number c of elements in C exceeds nzmax. c c work arrays: c------------ c iw = integer work array of length equal to the number of c columns in A. c c----------------------------------------------------------------------- logical values values = (job .ne. 0) ierr = 0 len = 0 ic(1) = 1 do 1 j=1, ncol iw(j) = 0 1 continue c do 500 ii=1, nrow c row i do 200 ka=ia(ii), ia(ii+1)-1 len = len+1 jcol = ja(ka) if (len .gt. nzmax) goto 999 jc(len) = jcol if (values) c(len) = a(ka) iw(jcol)= len 200 continue c do 300 kb=ib(ii),ib(ii+1)-1 jcol = jb(kb) jpos = iw(jcol) if (jpos .eq. 0) then len = len+1 if (len .gt. nzmax) goto 999 jc(len) = jcol if (values) c(len) = b(kb) iw(jcol)= len else if (values) c(jpos) = c(jpos) + b(kb) endif 300 continue do 301 k=ic(ii), len iw(jc(k)) = 0 301 continue ic(ii+1) = len+1 500 continue return 999 ierr = ii return c------------end of aplb ----------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine aplb1(nrow,ncol,job,a,ja,ia,b,jb,ib,c,jc,ic,nzmax,ierr) real*8 a(*), b(*), c(*) integer ja(*),jb(*),jc(*),ia(nrow+1),ib(nrow+1),ic(nrow+1) c----------------------------------------------------------------------- c performs the matrix sum C = A+B for matrices in sorted CSR format. c the difference with aplb is that the resulting matrix is such that c the elements of each row are sorted with increasing column indices in c each row, provided the original matrices are sorted in the same way. c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A and B c ncol = integer. The column dimension of A and B. c job = integer. Job indicator. When job = 0, only the structure c (i.e. the arrays jc, ic) is computed and the c real values are ignored. c c a, c ja, c ia = Matrix A in compressed sparse row format with entries sorted c c b, c jb, c ib = Matrix B in compressed sparse row format with entries sorted c ascendly in each row c c nzmax = integer. The length of the arrays c and jc. c amub will stop if the result matrix C has a number c of elements that exceeds exceeds nzmax. See ierr. c c on return: c---------- c c, c jc, c ic = resulting matrix C in compressed sparse row sparse format c with entries sorted ascendly in each row. c c ierr = integer. serving as error message. c ierr = 0 means normal return, c ierr .gt. 0 means that amub stopped while computing the c i-th row of C with i=ierr, because the number c of elements in C exceeds nzmax. c c Notes: c------- c this will not work if any of the two input matrices is not sorted c----------------------------------------------------------------------- logical values values = (job .ne. 0) ierr = 0 kc = 1 ic(1) = kc c do 6 i=1, nrow ka = ia(i) kb = ib(i) kamax = ia(i+1)-1 kbmax = ib(i+1)-1 5 continue if (ka .le. kamax) then j1 = ja(ka) else j1 = ncol+1 endif if (kb .le. kbmax) then j2 = jb(kb) else j2 = ncol+1 endif c c three cases c if (j1 .eq. j2) then if (values) c(kc) = a(ka)+b(kb) jc(kc) = j1 ka = ka+1 kb = kb+1 kc = kc+1 else if (j1 .lt. j2) then jc(kc) = j1 if (values) c(kc) = a(ka) ka = ka+1 kc = kc+1 else if (j1 .gt. j2) then jc(kc) = j2 if (values) c(kc) = b(kb) kb = kb+1 kc = kc+1 endif if (kc .gt. nzmax) goto 999 if (ka .le. kamax .or. kb .le. kbmax) goto 5 ic(i+1) = kc 6 continue return 999 ierr = i return c------------end-of-aplb1----------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine aplsb (nrow,ncol,a,ja,ia,s,b,jb,ib,c,jc,ic, * nzmax,ierr) real*8 a(*), b(*), c(*), s integer ja(*),jb(*),jc(*),ia(nrow+1),ib(nrow+1),ic(nrow+1) c----------------------------------------------------------------------- c performs the operation C = A+s B for matrices in sorted CSR format. c the difference with aplsb is that the resulting matrix is such that c the elements of each row are sorted with increasing column indices in c each row, provided the original matrices are sorted in the same way. c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A and B c ncol = integer. The column dimension of A and B. c c a, c ja, c ia = Matrix A in compressed sparse row format with entries sorted c c s = real. scalar factor for B. c c b, c jb, c ib = Matrix B in compressed sparse row format with entries sorted c ascendly in each row c c nzmax = integer. The length of the arrays c and jc. c amub will stop if the result matrix C has a number c of elements that exceeds exceeds nzmax. See ierr. c c on return: c---------- c c, c jc, c ic = resulting matrix C in compressed sparse row sparse format c with entries sorted ascendly in each row. c c ierr = integer. serving as error message. c ierr = 0 means normal return, c ierr .gt. 0 means that amub stopped while computing the c i-th row of C with i=ierr, because the number c of elements in C exceeds nzmax. c c Notes: c------- c this will not work if any of the two input matrices is not sorted c----------------------------------------------------------------------- ierr = 0 kc = 1 ic(1) = kc c c the following loop does a merge of two sparse rows + adds them. c do 6 i=1, nrow ka = ia(i) kb = ib(i) kamax = ia(i+1)-1 kbmax = ib(i+1)-1 5 continue c c this is a while -- do loop -- c if (ka .le. kamax .or. kb .le. kbmax) then c if (ka .le. kamax) then j1 = ja(ka) else c take j1 large enough that always j2 .lt. j1 j1 = ncol+1 endif if (kb .le. kbmax) then j2 = jb(kb) else c similarly take j2 large enough that always j1 .lt. j2 j2 = ncol+1 endif c c three cases c if (j1 .eq. j2) then c(kc) = a(ka)+s*b(kb) jc(kc) = j1 ka = ka+1 kb = kb+1 kc = kc+1 else if (j1 .lt. j2) then jc(kc) = j1 c(kc) = a(ka) ka = ka+1 kc = kc+1 else if (j1 .gt. j2) then jc(kc) = j2 c(kc) = s*b(kb) kb = kb+1 kc = kc+1 endif if (kc .gt. nzmax) goto 999 goto 5 c c end while loop c endif ic(i+1) = kc 6 continue return 999 ierr = i return c------------end-of-aplsb --------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine aplsb1 (nrow,ncol,a,ja,ia,s,b,jb,ib,c,jc,ic, * nzmax,ierr) real*8 a(*), b(*), c(*), s integer ja(*),jb(*),jc(*),ia(nrow+1),ib(nrow+1),ic(nrow+1) c----------------------------------------------------------------------- c performs the operation C = A+s B for matrices in sorted CSR format. c the difference with aplsb is that the resulting matrix is such that c the elements of each row are sorted with increasing column indices in c each row, provided the original matrices are sorted in the same way. c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A and B c ncol = integer. The column dimension of A and B. c c a, c ja, c ia = Matrix A in compressed sparse row format with entries sorted c c s = real. scalar factor for B. c c b, c jb, c ib = Matrix B in compressed sparse row format with entries sorted c ascendly in each row c c nzmax = integer. The length of the arrays c and jc. c amub will stop if the result matrix C has a number c of elements that exceeds exceeds nzmax. See ierr. c c on return: c---------- c c, c jc, c ic = resulting matrix C in compressed sparse row sparse format c with entries sorted ascendly in each row. c c ierr = integer. serving as error message. c ierr = 0 means normal return, c ierr .gt. 0 means that amub stopped while computing the c i-th row of C with i=ierr, because the number c of elements in C exceeds nzmax. c c Notes: c------- c this will not work if any of the two input matrices is not sorted c----------------------------------------------------------------------- ierr = 0 kc = 1 ic(1) = kc c c the following loop does a merge of two sparse rows + adds them. c do 6 i=1, nrow ka = ia(i) kb = ib(i) kamax = ia(i+1)-1 kbmax = ib(i+1)-1 5 continue c c this is a while -- do loop -- c if (ka .le. kamax .or. kb .le. kbmax) then c if (ka .le. kamax) then j1 = ja(ka) else c take j1 large enough that always j2 .lt. j1 j1 = ncol+1 endif if (kb .le. kbmax) then j2 = jb(kb) else c similarly take j2 large enough that always j1 .lt. j2 j2 = ncol+1 endif c c three cases c if (j1 .eq. j2) then c(kc) = a(ka)+s*b(kb) jc(kc) = j1 ka = ka+1 kb = kb+1 kc = kc+1 else if (j1 .lt. j2) then jc(kc) = j1 c(kc) = a(ka) ka = ka+1 kc = kc+1 else if (j1 .gt. j2) then jc(kc) = j2 c(kc) = s*b(kb) kb = kb+1 kc = kc+1 endif if (kc .gt. nzmax) goto 999 goto 5 c c end while loop c endif ic(i+1) = kc 6 continue return 999 ierr = i return c------------end-of-aplsb1 --------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine apmbt (nrow,ncol,job,a,ja,ia,b,jb,ib, * c,jc,ic,nzmax,iw,ierr) real*8 a(*), b(*), c(*) integer ja(*),jb(*),jc(*),ia(nrow+1),ib(ncol+1),ic(*),iw(*) c----------------------------------------------------------------------- c performs the matrix sum C = A + transp(B) or C = A - transp(B) c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A and transp(B) c ncol = integer. The column dimension of A. Also the row c dimension of B. c c job = integer. if job = -1, apmbt will compute C= A - transp(B) c (structure + values) c if (job .eq. 1) it will compute C=A+transp(A) c (structure+ values) c if (job .eq. 0) it will compute the structure of c C= A+/-transp(B) only (ignoring all real values). c any other value of job will be treated as job=1 c a, c ja, c ia = Matrix A in compressed sparse row format. c c b, c jb, c ib = Matrix B in compressed sparse row format. c c nzmax = integer. The length of the arrays c, jc, and ic. c amub will stop if the result matrix C has a number c of elements that exceeds exceeds nzmax. See ierr. c c on return: c---------- c c, c jc, c ic = resulting matrix C in compressed sparse row format. c c ierr = integer. serving as error message. c ierr = 0 means normal return. c ierr = -1 means that nzmax was .lt. either the number of c nonzero elements of A or the number of nonzero elements in B. c ierr .gt. 0 means that amub stopped while computing the c i-th row of C with i=ierr, because the number c of elements in C exceeds nzmax. c c work arrays: c------------ c iw = integer work array of length at least max(ncol,nrow) c c Notes: c------- It is important to note that here all of three arrays c, ic, c and jc are assumed to be of length nnz(c). This is because c the matrix is internally converted in coordinate format. c c----------------------------------------------------------------------- logical values values = (job .ne. 0) c ierr = 0 do 1 j=1, ncol iw(j) = 0 1 continue c nnza = ia(nrow+1)-1 nnzb = ib(ncol+1)-1 len = nnzb if (nzmax .lt. nnzb .or. nzmax .lt. nnza) then ierr = -1 return endif c c trasnpose matrix b into c c ljob = 0 if (values) ljob = 1 ipos = 1 call csrcsc (ncol,ljob,ipos,b,jb,ib,c,jc,ic) c----------------------------------------------------------------------- if (job .eq. -1) then do 2 k=1,len c(k) = -c(k) 2 continue endif c c--------------- main loop -------------------------------------------- c do 500 ii=1, nrow do 200 k = ic(ii),ic(ii+1)-1 iw(jc(k)) = k 200 continue c----------------------------------------------------------------------- do 300 ka = ia(ii), ia(ii+1)-1 jcol = ja(ka) jpos = iw(jcol) if (jpos .eq. 0) then c c if fill-in append in coordinate format to matrix. c len = len+1 if (len .gt. nzmax) goto 999 jc(len) = jcol ic(len) = ii if (values) c(len) = a(ka) else c else do addition. if (values) c(jpos) = c(jpos) + a(ka) endif 300 continue do 301 k=ic(ii), ic(ii+1)-1 iw(jc(k)) = 0 301 continue 500 continue c c convert first part of matrix (without fill-ins) into coo format c ljob = 2 if (values) ljob = 3 do 501 i=1, nrow+1 iw(i) = ic(i) 501 continue call csrcoo (nrow,ljob,nnzb,c,jc,iw,nnzb,c,ic,jc,ierr) c c convert the whole thing back to csr format. c ljob = 0 if (values) ljob = 1 call coicsr (nrow,len,ljob,c,jc,ic,iw) return 999 ierr = ii return c--------end-of-apmbt--------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine aplsbt(nrow,ncol,a,ja,ia,s,b,jb,ib, * c,jc,ic,nzmax,iw,ierr) real*8 a(*), b(*), c(*), s integer ja(*),jb(*),jc(*),ia(nrow+1),ib(ncol+1),ic(*),iw(*) c----------------------------------------------------------------------- c performs the matrix sum C = A + transp(B). c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A and transp(B) c ncol = integer. The column dimension of A. Also the row c dimension of B. c c a, c ja, c ia = Matrix A in compressed sparse row format. c c s = real. scalar factor for B. c c c b, c jb, c ib = Matrix B in compressed sparse row format. c c nzmax = integer. The length of the arrays c, jc, and ic. c amub will stop if the result matrix C has a number c of elements that exceeds exceeds nzmax. See ierr. c c on return: c---------- c c, c jc, c ic = resulting matrix C in compressed sparse row format. c c ierr = integer. serving as error message. c ierr = 0 means normal return. c ierr = -1 means that nzmax was .lt. either the number of c nonzero elements of A or the number of nonzero elements in B. c ierr .gt. 0 means that amub stopped while computing the c i-th row of C with i=ierr, because the number c of elements in C exceeds nzmax. c c work arrays: c------------ c iw = integer work array of length at least max(nrow,ncol) c c Notes: c------- It is important to note that here all of three arrays c, ic, c and jc are assumed to be of length nnz(c). This is because c the matrix is internally converted in coordinate format. c c----------------------------------------------------------------------- ierr = 0 do 1 j=1, ncol iw(j) = 0 1 continue c nnza = ia(nrow+1)-1 nnzb = ib(ncol+1)-1 len = nnzb if (nzmax .lt. nnzb .or. nzmax .lt. nnza) then ierr = -1 return endif c c transpose matrix b into c c ljob = 1 ipos = 1 call csrcsc (ncol,ljob,ipos,b,jb,ib,c,jc,ic) do 2 k=1,len 2 c(k) = c(k)*s c c main loop. add rows from ii = 1 to nrow. c do 500 ii=1, nrow c iw is used as a system to recognize whether there c was a nonzero element in c. do 200 k = ic(ii),ic(ii+1)-1 iw(jc(k)) = k 200 continue c do 300 ka = ia(ii), ia(ii+1)-1 jcol = ja(ka) jpos = iw(jcol) if (jpos .eq. 0) then c c if fill-in append in coordinate format to matrix. c len = len+1 if (len .gt. nzmax) goto 999 jc(len) = jcol ic(len) = ii c(len) = a(ka) else c else do addition. c(jpos) = c(jpos) + a(ka) endif 300 continue do 301 k=ic(ii), ic(ii+1)-1 iw(jc(k)) = 0 301 continue 500 continue c c convert first part of matrix (without fill-ins) into coo format c ljob = 3 do 501 i=1, nrow+1 iw(i) = ic(i) 501 continue call csrcoo (nrow,ljob,nnzb,c,jc,iw,nnzb,c,ic,jc,ierr) c c convert the whole thing back to csr format. c ljob = 1 call coicsr (nrow,len,ljob,c,jc,ic,iw) return 999 ierr = ii return c--------end-of-aplsbt-------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine diamua (nrow,job, a, ja, ia, diag, b, jb, ib) real*8 a(*), b(*), diag(nrow), scal integer ja(*),jb(*), ia(nrow+1),ib(nrow+1) c----------------------------------------------------------------------- c performs the matrix by matrix product B = Diag * A (in place) c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A c c job = integer. job indicator. Job=0 means get array b only c job = 1 means get b, and the integer arrays ib, jb. c c a, c ja, c ia = Matrix A in compressed sparse row format. c c diag = diagonal matrix stored as a vector dig(1:n) c c on return: c---------- c c b, c jb, c ib = resulting matrix B in compressed sparse row sparse format. c c Notes: c------- c 1) The column dimension of A is not needed. c 2) algorithm in place (B can take the place of A). c in this case use job=0. c----------------------------------------------------------------- do 1 ii=1,nrow c c normalize each row c k1 = ia(ii) k2 = ia(ii+1)-1 scal = diag(ii) do 2 k=k1, k2 b(k) = a(k)*scal 2 continue 1 continue c if (job .eq. 0) return c do 3 ii=1, nrow+1 ib(ii) = ia(ii) 3 continue do 31 k=ia(1), ia(nrow+1) -1 jb(k) = ja(k) 31 continue return c----------end-of-diamua------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine amudia (nrow,job, a, ja, ia, diag, b, jb, ib) real*8 a(*), b(*), diag(nrow) integer ja(*),jb(*), ia(nrow+1),ib(nrow+1) c----------------------------------------------------------------------- c performs the matrix by matrix product B = A * Diag (in place) c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A c c job = integer. job indicator. Job=0 means get array b only c job = 1 means get b, and the integer arrays ib, jb. c c a, c ja, c ia = Matrix A in compressed sparse row format. c c diag = diagonal matrix stored as a vector dig(1:n) c c on return: c---------- c c b, c jb, c ib = resulting matrix B in compressed sparse row sparse format. c c Notes: c------- c 1) The column dimension of A is not needed. c 2) algorithm in place (B can take the place of A). c----------------------------------------------------------------- do 1 ii=1,nrow c c scale each element c k1 = ia(ii) k2 = ia(ii+1)-1 do 2 k=k1, k2 b(k) = a(k)*diag(ja(k)) 2 continue 1 continue c if (job .eq. 0) return c do 3 ii=1, nrow+1 ib(ii) = ia(ii) 3 continue do 31 k=ia(1), ia(nrow+1) -1 jb(k) = ja(k) 31 continue return c----------------------------------------------------------------------- c-----------end-of-amudiag---------------------------------------------- end c----------------------------------------------------------------------- subroutine aplsca (nrow, a, ja, ia, scal,iw) real*8 a(*), scal integer ja(*), ia(nrow+1),iw(*) c----------------------------------------------------------------------- c Adds a scalar to the diagonal entries of a sparse matrix A :=A + s I c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A c c a, c ja, c ia = Matrix A in compressed sparse row format. c c scal = real. scalar to add to the diagonal entries. c c on return: c---------- c c a, c ja, c ia = matrix A with diagonal elements shifted (or created). c c iw = integer work array of length n. On return iw will c contain the positions of the diagonal entries in the c output matrix. (i.e., a(iw(k)), ja(iw(k)), k=1,...n, c are the values/column indices of the diagonal elements c of the output matrix. ). c c Notes: c------- c The column dimension of A is not needed. c important: the matrix a may be expanded slightly to allow for c additions of nonzero elements to previously nonexisting diagonals. c The is no checking as to whether there is enough space appended c to the arrays a and ja. if not sure allow for n additional c elemnts. c coded by Y. Saad. Latest version July, 19, 1990 c----------------------------------------------------------------------- logical test c call diapos (nrow,ja,ia,iw) icount = 0 do 1 j=1, nrow if (iw(j) .eq. 0) then icount = icount+1 else a(iw(j)) = a(iw(j)) + scal endif 1 continue c c if no diagonal elements to insert in data structure return. c if (icount .eq. 0) return c c shift the nonzero elements if needed, to allow for created c diagonal elements. c ko = ia(nrow+1)+icount c c copy rows backward c do 5 ii=nrow, 1, -1 c c go through row ii c k1 = ia(ii) k2 = ia(ii+1)-1 ia(ii+1) = ko test = (iw(ii) .eq. 0) do 4 k = k2,k1,-1 j = ja(k) if (test .and. (j .lt. ii)) then test = .false. ko = ko - 1 a(ko) = scal ja(ko) = ii iw(ii) = ko endif ko = ko-1 a(ko) = a(k) ja(ko) = j 4 continue c diagonal element has not been added yet. if (test) then ko = ko-1 a(ko) = scal ja(ko) = ii iw(ii) = ko endif 5 continue ia(1) = ko return c----------------------------------------------------------------------- c----------end-of-aplsca------------------------------------------------ end c----------------------------------------------------------------------- subroutine apldia (nrow, job, a, ja, ia, diag, b, jb, ib, iw) real*8 a(*), b(*), diag(nrow) integer ja(*),jb(*), ia(nrow+1),ib(nrow+1), iw(*) c----------------------------------------------------------------------- c Adds a diagonal matrix to a general sparse matrix: B = A + Diag c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A c c job = integer. job indicator. Job=0 means get array b only c (i.e. assume that a has already been copied into array b, c or that algorithm is used in place. ) For all practical c purposes enter job=0 for an in-place call and job=1 otherwise c c Note: in case there are missing diagonal elements in A, c then the option job =0 will be ignored, since the algorithm c must modify the data structure (i.e. jb, ib) in this c situation. c c a, c ja, c ia = Matrix A in compressed sparse row format. c c diag = diagonal matrix stored as a vector dig(1:n) c c on return: c---------- c c b, c jb, c ib = resulting matrix B in compressed sparse row sparse format. c c c iw = integer work array of length n. On return iw will c contain the positions of the diagonal entries in the c output matrix. (i.e., a(iw(k)), ja(iw(k)), k=1,...n, c are the values/column indices of the diagonal elements c of the output matrix. ). c c Notes: c------- c 1) The column dimension of A is not needed. c 2) algorithm in place (b, jb, ib, can be the same as c a, ja, ia, on entry). See comments for parameter job. c c coded by Y. Saad. Latest version July, 19, 1990 c----------------------------------------------------------------- logical test c c copy integer arrays into b's data structure if required c if (job .ne. 0) then nnz = ia(nrow+1)-1 do 2 k=1, nnz jb(k) = ja(k) b(k) = a(k) 2 continue do 3 k=1, nrow+1 ib(k) = ia(k) 3 continue endif c c get positions of diagonal elements in data structure. c call diapos (nrow,ja,ia,iw) c c count number of holes in diagonal and add diag(*) elements to c valid diagonal entries. c icount = 0 do 1 j=1, nrow if (iw(j) .eq. 0) then icount = icount+1 else b(iw(j)) = a(iw(j)) + diag(j) endif 1 continue c c if no diagonal elements to insert return c if (icount .eq. 0) return c c shift the nonzero elements if needed, to allow for created c diagonal elements. c ko = ib(nrow+1)+icount c c copy rows backward c do 5 ii=nrow, 1, -1 c c go through row ii c k1 = ib(ii) k2 = ib(ii+1)-1 ib(ii+1) = ko test = (iw(ii) .eq. 0) do 4 k = k2,k1,-1 j = jb(k) if (test .and. (j .lt. ii)) then test = .false. ko = ko - 1 b(ko) = diag(ii) jb(ko) = ii iw(ii) = ko endif ko = ko-1 b(ko) = a(k) jb(ko) = j 4 continue c diagonal element has not been added yet. if (test) then ko = ko-1 b(ko) = diag(ii) jb(ko) = ii iw(ii) = ko endif 5 continue ib(1) = ko return c----------------------------------------------------------------------- c------------end-of-apldiag--------------------------------------------- end getdp-2.4.2-source/contrib/Sparskit/flu.f000644 001750 001750 00000023267 11266605601 022012 0ustar00geuzainegeuzaine000000 000000 c $Id: flu.f,v 1.1 2008-04-11 06:01:06 geuzaine Exp $ C============================================================================== C C RESOLUTION DE SYSTEMES LINEAIRES PAR METHODE DE GAUSS COMPACTE C C============================================================================== C C\* C----------------------------------------------------------------------------- SUBROUTINE flu(IPARAM,RPARAM,A,LU,NMAX,N,B,X,DX,RES,IPIV) C----------------------------------------------------------------------------- C C +-----------------+------------------------------------------+---------+ C | PROGRAMMEUR | COMMENTAIRES | DATE | C +-----------------+------------------------------------------+---------+ C | UME MARC | | 02/09/91| C +-----------------+------------------------------------------+---------+ C C BUT DE LA ROUTINE C +++++++++++++++++ C C RESOLUTION DU SYSTEME A.X = B C METHODE LU CLASSIQUE C C C DESCRIPTION DES PARAMETRES C ++++++++++++++++++++++++++ C C IPARAM(1) : 0 = IMPOSE LE CALCUL DE LA DECOMPOSITION LU C 1 = PAS DE CALCUL DE LA DECOMPOSITION LU C C A(NMAX,NMAX) = MATRICE A C LU(NMAX,NMAX) = MATRICE LU C NMAX = DIMENSION DES TABLEAUX C N = NOMBRE D'EQUATIONS C B(N) = VECTEUR INDEPENDANT C X(N) = VECTEUR SOLUTION C DX(N) = VECTEUR CORRECTION DE LA SOLUTION C RES(N) = VECTEUR RESIDU C IPIV(N) = VECTEUR DE PIVOTAGE DES LIGNES DE A C C INTEGER IPARAM(*) REAL*8 RPARAM(*) INTEGER NMAX,N,IPIV(N) REAL*8 X(N),A(NMAX,NMAX),LU(NMAX,NMAX),DX(N),RES(N) REAL*8 B(N) INTEGER CONV 10 CONTINUE IF (IPARAM(1).EQ.0) THEN C write(*,'(A)')'= factorisation L.U =' IF (IPARAM(3).EQ.1) THEN DO J = 1,N DO I = 1,N WRITE(77,*) I,J,A(I,J) ENDDO ENDDO DO I = 1,N WRITE(78,*) I,B(I) ENDDO ENDIF CALL GAUFLU(NMAX,N,A,LU,IPIV) ENDIF CALL GAUFBA(NMAX,N,LU,IPIV,B,X) IF (IPARAM(2).EQ.1) THEN CALL GSFITE(IPARAM,RPARAM, & NMAX,N,A,B,X,LU,RES,DX,IPIV,CONV) ENDIF IF (IPARAM(1).EQ.0) THEN IPARAM(1) = 1 RETURN ENDIF IF (CONV.EQ.1) RETURN IPARAM(1) = 0 GOTO 10 END C C\* C------------------------------------------------------------------------------ SUBROUTINE GAUFLU(NMAX,N,A,LU,PIV) C------------------------------------------------------------------------------ C C +-----------------+-------------------------------------------+---------+ C | PROGRAMMEUR | COMMENTAIRES | DATE | C +-----------------+-------------------------------------------+---------+ C | UME MARC | | 02/09/91| C +-----------------+-------------------------------------------+---------+ C C BUT DE LA ROUTINE C +++++++++++++++++ C C CALCUL LA DECOMPOSITION COMPLETE L U DE A C C C DESCRIPTION DES PARAMETRES C ++++++++++++++++++++++++++ C C C NMAX = DIMENSION DES TABLEAUX C N = NOMBRE D'EQUATIONS C A(NMAX,NMAX) = MATRICE A C LU(NMAX,NMAX) = MATRICE LU C PIV(N) = VECTEUR DE PIVOTAGE DES LIGNES DE A C C INTEGER NMAX,N,PIV(N) REAL*8 A(NMAX,NMAX) REAL*8 LU(NMAX,NMAX) INTEGER K,I,J REAL*8 RPIV,VAL DO I = 1,N PIV(I) = I ENDDO DO J = 1,N DO I = 1,N LU(I,J) = A(I,J) ENDDO ENDDO DO K=1,N-1 CALL PIFMAX(NMAX,N,K,LU,PIV) RPIV = LU(PIV(K),K) DO I=K+1,N if(abs(rpiv).lt.(1.D-10*abs(lu(piv(i),k)))) then write(6,*)'PIVOT TROP PETIT' write(6,*)'DENOM/NUM =',abs(rpiv/lu(piv(i),k)) endif LU(PIV(I),K) = LU(PIV(I),K)/RPIV ENDDO DO J=K+1,N VAL = LU(PIV(K),J) IF (VAL.NE.0.0D0) THEN DO I=K+1,N LU(PIV(I),J) = LU(PIV(I),J) & - LU(PIV(I),K) * VAL ENDDO ENDIF ENDDO ENDDO END C C\* C------------------------------------------------------------------------------ SUBROUTINE GAUFBA(NMAX,N,LU,PIV,B,X) C------------------------------------------------------------------------------ C C +-----------------+-------------------------------------------+---------+ C | PROGRAMMEUR | COMMENTAIRES | DATE | C +-----------------+-------------------------------------------+---------+ C | UME MARC | | 02/09/91| C +-----------------+-------------------------------------------+---------+ C C BUT DE LA ROUTINE C +++++++++++++++++ C C -1 C CALCUL DE X = LU .B C C C DESCRIPTION DES PARAMETRES C ++++++++++++++++++++++++++ C C NMAX = DIMENSION DES TABLEAUX C N = NOMBRE D'EQUATIONS C LU(NMAX,NMAX) = MATRICE LU C PIV(N) = VECTEUR DE PIVOTAGE DES LIGNES DE A C B(N) = VECTEUR INDEPENDANT C X(N) = VECTEUR SOLUTION C C INTEGER NMAX,N,PIV(N) REAL*8 LU(NMAX,NMAX),B(N),X(N) INTEGER I,J REAL*8 VAL DO I=1,N VAL = 0.0D0 DO J=1,I-1 VAL = VAL + LU(PIV(I),J) * X(J) ENDDO X(I) = B(PIV(I)) - VAL ENDDO DO I=N,1,-1 VAL = 0.0D0 DO J=I+1,N VAL = VAL + LU(PIV(I),J) * X(J) ENDDO X(I) = (X(I) - VAL) / LU(PIV(I),I) ENDDO END C C\* C------------------------------------------------------------------------------ SUBROUTINE PIFMAX(NMAX,N,K,LU,PIV) C------------------------------------------------------------------------------ C C +-----------------+------------------------------------------+----------+ C | PROGRAMMEUR | COMMENTAIRES | DATE | C +-----------------+------------------------------------------+----------+ C | UME MARC | | 02/09/91 | C +-----------------+------------------------------------------+----------+ C C BUT DE LA ROUTINE C +++++++++++++++++ C C RECHERCHE LE PIVOT MAX SUR LA COLONNE (K,K) -> (N,K) C MODIFIE LE VECTEUR DE PIVOTAGE EN CONSEQUENCE C C C DESCRIPTION DES PARAMETRES C ++++++++++++++++++++++++++ C C NMAX = DIMENSION DES TABLEAUX C N = NOMBRE D'EQUATIONS C K = NUMERO DE L'ETAPE C LU(NMAX,NMAX) = MATRICE LU C PIV(N) = VECTEUR DE PIVOTAGE DES LIGNES DE A C C INTEGER NMAX,N,K,PIV(N) REAL*8 LU(NMAX,NMAX) INTEGER I,JMAX REAL*8 VA,VMAX VMAX = ABS(LU(PIV(K),K)) JMAX = K DO I=K+1,N VA=ABS(LU(PIV(I),K)) IF (VA.GT.VMAX) THEN VMAX = VA JMAX = I ENDIF ENDDO I = PIV(K) PIV(K) = PIV(JMAX) PIV(JMAX) = I END C C\* C------------------------------------------------------------------------------ SUBROUTINE GSFITE(IPARAM,RPARAM, & NMAX,N,A,B,X,LU,RES,DX,PIV,CONV) C------------------------------------------------------------------------------ C C +-----------------+------------------------------------------+----------+ C | PROGRAMMEUR | COMMENTAIRES | DATE | C +-----------------+------------------------------------------+----------+ C | UME MARC | | 02/09/91 | C +-----------------+------------------------------------------+----------+ C C BUT DE LA ROUTINE C +++++++++++++++++ C C AMELIORATION ITERATIVE DE LA SOLUTION X C C C DESCRIPTION DES PARAMETRES C ++++++++++++++++++++++++++ C C NMAX = DIMENSION DES TABLEAUX C N = NOMBRE D'EQUATIONS C A(NMAX,NMAX) = MATRICE A C B(N) = VECTEUR INDEPENDANT C X(N) = VECTEUR SOLUTION C LU(NMAX,NMAX) = MATRICE LU C RESN) = VECTEUR RESIDU C DX(N) = VECTEUR CORRECTION DE LA SOLUTION C PIV(N) = VECTEUR DE PIVOTAGE DES LIGNES DE A C CONV : 0 = PAS DE CONVERGENCE EN N/10 ITERATIONS C 1 = CONVERGENCE (PRECISION = 1.E-5) C C INTEGER IPARAM(*) REAL*8 RPARAM(*) INTEGER CONV INTEGER NMAX,N,PIV(N) REAL*8 A(NMAX,NMAX),B(N),X(N) REAL*8 LU(NMAX,NMAX),RES(N),DX(N) INTEGER I,J,ITE REAL*8 PREC,DXMAX,DERR,DAV REAL*8 VAL PREC = RPARAM(1) DO ITE=1,IPARAM(4) DO I = 1,N VAL = 0.0D0 DO J = 1,N VAL = VAL + DBLE(A(I,J)) * DBLE(X(J)) ENDDO RES(I) = DBLE(B(I)) - VAL ENDDO CALL GAUFBA(NMAX,N,LU,PIV,RES,DX) DO I=1,N X(I) = X(I) + DX(I) ENDDO DXMAX = 0.0D0 DO I=1,N IF (X(I).EQ.0.0D0) THEN DERR = ABS(DX(I)) ELSE DERR = ABS(DX(I)/X(I)) ENDIF IF (DERR.GT.DXMAX) DXMAX = DERR ENDDO WRITE(*,'(A,E12.5,$)')'= ERREUR REL. MAX. ',DXMAX WRITE(*,'(A,$)')' =' WRITE(*,'(A,$)')13 IF (DXMAX.LT.PREC) THEN CONV = 1 WRITE(*,*) RETURN ENDIF IF (IPARAM(3).EQ.1) THEN IF ((ITE.GT.2).AND.(DXMAX.GT.DAV)) THEN CONV = 0 WRITE(*,*) RETURN ENDIF ENDIF DAV = DXMAX ENDDO WRITE(*,*) CONV = 0 END getdp-2.4.2-source/contrib/Arpack/dsconv.f000644 001750 001750 00000006602 11266605602 022114 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dsconv c c\Description: c Convergence testing for the symmetric Arnoldi eigenvalue routine. c c\Usage: c call dsconv c ( N, RITZ, BOUNDS, TOL, NCONV ) c c\Arguments c N Integer. (INPUT) c Number of Ritz values to check for convergence. c c RITZ Double precision array of length N. (INPUT) c The Ritz values to be checked for convergence. c c BOUNDS Double precision array of length N. (INPUT) c Ritz estimates associated with the Ritz values in RITZ. c c TOL Double precision scalar. (INPUT) c Desired relative accuracy for a Ritz value to be considered c "converged". c c NCONV Integer scalar. (OUTPUT) c Number of "converged" Ritz values. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Routines called: c second ARPACK utility routine for timing. c dlamch LAPACK routine that determines machine constants. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sconv.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 c c\Remarks c 1. Starting with version 2.4, this routine no longer uses the c Parlett strategy using the gap conditions. c c\EndLib c c----------------------------------------------------------------------- c subroutine dsconv (n, ritz, bounds, tol, nconv) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer n, nconv Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & ritz(n), bounds(n) c c %---------------% c | Local Scalars | c %---------------% c integer i Double precision & temp, eps23 c c %-------------------% c | External routines | c %-------------------% c Double precision & dlamch external dlamch c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c call second (t0) c eps23 = dlamch('Epsilon-Machine') eps23 = eps23**(2.0D+0 / 3.0D+0) c nconv = 0 do 10 i = 1, n c c %-----------------------------------------------------% c | The i-th Ritz value is considered "converged" | c | when: bounds(i) .le. TOL*max(eps23, abs(ritz(i))) | c %-----------------------------------------------------% c temp = max( eps23, abs(ritz(i)) ) if ( bounds(i) .le. tol*temp ) then nconv = nconv + 1 end if c 10 continue c call second (t1) tsconv = tsconv + (t1 - t0) c return c c %---------------% c | End of dsconv | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/ssconv.f000644 001750 001750 00000006456 11266605602 022142 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: ssconv c c\Description: c Convergence testing for the symmetric Arnoldi eigenvalue routine. c c\Usage: c call ssconv c ( N, RITZ, BOUNDS, TOL, NCONV ) c c\Arguments c N Integer. (INPUT) c Number of Ritz values to check for convergence. c c RITZ Real array of length N. (INPUT) c The Ritz values to be checked for convergence. c c BOUNDS Real array of length N. (INPUT) c Ritz estimates associated with the Ritz values in RITZ. c c TOL Real scalar. (INPUT) c Desired relative accuracy for a Ritz value to be considered c "converged". c c NCONV Integer scalar. (OUTPUT) c Number of "converged" Ritz values. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Routines called: c second ARPACK utility routine for timing. c slamch LAPACK routine that determines machine constants. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sconv.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 c c\Remarks c 1. Starting with version 2.4, this routine no longer uses the c Parlett strategy using the gap conditions. c c\EndLib c c----------------------------------------------------------------------- c subroutine ssconv (n, ritz, bounds, tol, nconv) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer n, nconv Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c Real & ritz(n), bounds(n) c c %---------------% c | Local Scalars | c %---------------% c integer i Real & temp, eps23 c c %-------------------% c | External routines | c %-------------------% c Real & slamch external slamch c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c call second (t0) c eps23 = slamch('Epsilon-Machine') eps23 = eps23**(2.0E+0 / 3.0E+0) c nconv = 0 do 10 i = 1, n c c %-----------------------------------------------------% c | The i-th Ritz value is considered "converged" | c | when: bounds(i) .le. TOL*max(eps23, abs(ritz(i))) | c %-----------------------------------------------------% c temp = max( eps23, abs(ritz(i)) ) if ( bounds(i) .le. tol*temp ) then nconv = nconv + 1 end if c 10 continue c call second (t1) tsconv = tsconv + (t1 - t0) c return c c %---------------% c | End of ssconv | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dgetv0.f000644 001750 001750 00000031642 11266605602 022013 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dgetv0 c c\Description: c Generate a random initial residual vector for the Arnoldi process. c Force the residual vector to be in the range of the operator OP. c c\Usage: c call dgetv0 c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, c IPNTR, WORKD, IERR ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to dgetv0. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 99: done c ------------------------------------------------------------- c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B in the (generalized) c eigenvalue problem A*x = lambda*B*x. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x c c ITRY Integer. (INPUT) c ITRY counts the number of times that dgetv0 is called. c It should be set to 1 on the initial call to dgetv0. c c INITV Logical variable. (INPUT) c .TRUE. => the initial residual vector is given in RESID. c .FALSE. => generate a random initial residual vector. c c N Integer. (INPUT) c Dimension of the problem. c c J Integer. (INPUT) c Index of the residual vector to be generated, with respect to c the Arnoldi process. J > 1 in case of a "restart". c c V Double precision N by J array. (INPUT) c The first J-1 columns of V contain the current Arnoldi basis c if this is a "restart". c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c RESID Double precision array of length N. (INPUT/OUTPUT) c Initial residual vector to be generated. If RESID is c provided, force RESID into the range of the operator OP. c c RNORM Double precision scalar. (OUTPUT) c B-norm of the generated residual. c c IPNTR Integer array of length 3. (OUTPUT) c c WORKD Double precision work array of length 2*N. (REVERSE COMMUNICATION). c On exit, WORK(1:N) = B*RESID to be used in SSAITR. c c IERR Integer. (OUTPUT) c = 0: Normal exit. c = -1: Cannot generate a nontrivial restarted residual vector c in the range of the operator OP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c second ARPACK utility routine for timing. c dvout ARPACK utility routine for vector output. c dlarnv LAPACK routine for generating a random vector. c dgemv Level 2 BLAS routine for matrix vector multiplication. c dcopy Level 1 BLAS that copies one vector to another. c ddot Level 1 BLAS that computes the scalar product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: getv0.F SID: 2.7 DATE OF SID: 04/07/99 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine dgetv0 & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, & ipntr, workd, ierr ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 logical initv integer ido, ierr, itry, j, ldv, n Double precision & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Double precision & resid(n), v(ldv,j), workd(2*n) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c logical first, inits, orth integer idist, iseed(4), iter, msglvl, jj Double precision & rnorm0 save first, iseed, inits, iter, msglvl, orth, rnorm0 c c %----------------------% c | External Subroutines | c %----------------------% c external dlarnv, dvout, dcopy, dgemv, second c c %--------------------% c | External Functions | c %--------------------% c Double precision & ddot, dnrm2 external ddot, dnrm2 c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs, sqrt c c %-----------------% c | Data Statements | c %-----------------% c data inits /.true./ c c %-----------------------% c | Executable Statements | c %-----------------------% c c c %-----------------------------------% c | Initialize the seed of the LAPACK | c | random number generator | c %-----------------------------------% c if (inits) then iseed(1) = 1 iseed(2) = 3 iseed(3) = 5 iseed(4) = 7 inits = .false. end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mgetv0 c ierr = 0 iter = 0 first = .FALSE. orth = .FALSE. c c %-----------------------------------------------------% c | Possibly generate a random starting vector in RESID | c | Use a LAPACK random number generator used by the | c | matrix generation routines. | c | idist = 1: uniform (0,1) distribution; | c | idist = 2: uniform (-1,1) distribution; | c | idist = 3: normal (0,1) distribution; | c %-----------------------------------------------------% c if (.not.initv) then idist = 2 call dlarnv (idist, iseed, n, resid) end if c c %----------------------------------------------------------% c | Force the starting vector into the range of OP to handle | c | the generalized problem when B is possibly (singular). | c %----------------------------------------------------------% c call second (t2) if (bmat .eq. 'G') then nopx = nopx + 1 ipntr(1) = 1 ipntr(2) = n + 1 call dcopy (n, resid, 1, workd, 1) ido = -1 go to 9000 end if end if c c %-----------------------------------------% c | Back from computing OP*(initial-vector) | c %-----------------------------------------% c if (first) go to 20 c c %-----------------------------------------------% c | Back from computing B*(orthogonalized-vector) | c %-----------------------------------------------% c if (orth) go to 40 c if (bmat .eq. 'G') then call second (t3) tmvopx = tmvopx + (t3 - t2) end if c c %------------------------------------------------------% c | Starting vector is now in the range of OP; r = OP*r; | c | Compute B-norm of starting vector. | c %------------------------------------------------------% c call second (t2) first = .TRUE. if (bmat .eq. 'G') then nbx = nbx + 1 call dcopy (n, workd(n+1), 1, resid, 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd, 1) end if c 20 continue c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c first = .FALSE. if (bmat .eq. 'G') then rnorm0 = ddot (n, resid, 1, workd, 1) rnorm0 = sqrt(abs(rnorm0)) else if (bmat .eq. 'I') then rnorm0 = dnrm2(n, resid, 1) end if rnorm = rnorm0 c c %---------------------------------------------% c | Exit if this is the very first Arnoldi step | c %---------------------------------------------% c if (j .eq. 1) go to 50 c c %---------------------------------------------------------------- c | Otherwise need to B-orthogonalize the starting vector against | c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | c | This is the case where an invariant subspace is encountered | c | in the middle of the Arnoldi factorization. | c | | c | s = V^{T}*B*r; r = r - V*s; | c | | c | Stopping criteria used for iter. ref. is discussed in | c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | c %---------------------------------------------------------------% c orth = .TRUE. 30 continue c call dgemv ('T', n, j-1, one, v, ldv, workd, 1, & zero, workd(n+1), 1) call dgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, & one, resid, 1) c c %----------------------------------------------------------% c | Compute the B-norm of the orthogonalized starting vector | c %----------------------------------------------------------% c call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call dcopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd, 1) end if c 40 continue c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then rnorm = ddot (n, resid, 1, workd, 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = dnrm2(n, resid, 1) end if c c %--------------------------------------% c | Check for further orthogonalization. | c %--------------------------------------% c if (msglvl .gt. 2) then call dvout (logfil, 1, rnorm0, ndigit, & '_getv0: re-orthonalization ; rnorm0 is') call dvout (logfil, 1, rnorm, ndigit, & '_getv0: re-orthonalization ; rnorm is') end if c if (rnorm .gt. 0.717*rnorm0) go to 50 c iter = iter + 1 if (iter .le. 5) then c c %-----------------------------------% c | Perform iterative refinement step | c %-----------------------------------% c rnorm0 = rnorm go to 30 else c c %------------------------------------% c | Iterative refinement step "failed" | c %------------------------------------% c do 45 jj = 1, n resid(jj) = zero 45 continue rnorm = zero ierr = -1 end if c 50 continue c if (msglvl .gt. 0) then call dvout (logfil, 1, rnorm, ndigit, & '_getv0: B-norm of initial / restarted starting vector') end if if (msglvl .gt. 3) then call dvout (logfil, n, resid, ndigit, & '_getv0: initial / restarted starting vector') end if ido = 99 c call second (t1) tgetv0 = tgetv0 + (t1 - t0) c 9000 continue return c c %---------------% c | End of dgetv0 | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dsesrt.f000644 001750 001750 00000012370 11266605602 022123 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dsesrt c c\Description: c Sort the array X in the order specified by WHICH and optionally c apply the permutation to the columns of the matrix A. c c\Usage: c call dsesrt c ( WHICH, APPLY, N, X, NA, A, LDA) c c\Arguments c WHICH Character*2. (Input) c 'LM' -> X is sorted into increasing order of magnitude. c 'SM' -> X is sorted into decreasing order of magnitude. c 'LA' -> X is sorted into increasing order of algebraic. c 'SA' -> X is sorted into decreasing order of algebraic. c c APPLY Logical. (Input) c APPLY = .TRUE. -> apply the sorted order to A. c APPLY = .FALSE. -> do not apply the sorted order to A. c c N Integer. (INPUT) c Dimension of the array X. c c X Double precision array of length N. (INPUT/OUTPUT) c The array to be sorted. c c NA Integer. (INPUT) c Number of rows of the matrix A. c c A Double precision array of length NA by N. (INPUT/OUTPUT) c c LDA Integer. (INPUT) c Leading dimension of A. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Routines c dswap Level 1 BLAS that swaps the contents of two vectors. c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/15/93: Version ' 2.1'. c Adapted from the sort routine in LANSO and c the ARPACK code dsortr c c\SCCS Information: @(#) c FILE: sesrt.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine dsesrt (which, apply, n, x, na, a, lda) c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which logical apply integer lda, n, na c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & x(0:n-1), a(lda, 0:n-1) c c %---------------% c | Local Scalars | c %---------------% c integer i, igap, j Double precision & temp c c %----------------------% c | External Subroutines | c %----------------------% c external dswap c c %-----------------------% c | Executable Statements | c %-----------------------% c igap = n / 2 c if (which .eq. 'SA') then c c X is sorted into decreasing order of algebraic. c 10 continue if (igap .eq. 0) go to 9000 do 30 i = igap, n-1 j = i-igap 20 continue c if (j.lt.0) go to 30 c if (x(j).lt.x(j+igap)) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) else go to 30 endif j = j-igap go to 20 30 continue igap = igap / 2 go to 10 c else if (which .eq. 'SM') then c c X is sorted into decreasing order of magnitude. c 40 continue if (igap .eq. 0) go to 9000 do 60 i = igap, n-1 j = i-igap 50 continue c if (j.lt.0) go to 60 c if (abs(x(j)).lt.abs(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) else go to 60 endif j = j-igap go to 50 60 continue igap = igap / 2 go to 40 c else if (which .eq. 'LA') then c c X is sorted into increasing order of algebraic. c 70 continue if (igap .eq. 0) go to 9000 do 90 i = igap, n-1 j = i-igap 80 continue c if (j.lt.0) go to 90 c if (x(j).gt.x(j+igap)) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) else go to 90 endif j = j-igap go to 80 90 continue igap = igap / 2 go to 70 c else if (which .eq. 'LM') then c c X is sorted into increasing order of magnitude. c 100 continue if (igap .eq. 0) go to 9000 do 120 i = igap, n-1 j = i-igap 110 continue c if (j.lt.0) go to 120 c if (abs(x(j)).gt.abs(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) else go to 120 endif j = j-igap go to 110 120 continue igap = igap / 2 go to 100 end if c 9000 continue return c c %---------------% c | End of dsesrt | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/iswap.f000644 001750 001750 00000002313 11266605602 021736 0ustar00geuzainegeuzaine000000 000000 subroutine iswap (n,sx,incx,sy,incy) c c interchanges two vectors. c uses unrolled loops for increments equal to 1. c jack dongarra, linpack, 3/11/78. c integer sx(1),sy(1),stemp integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments not equal c to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n stemp = sx(ix) sx(ix) = sy(iy) sy(iy) = stemp ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,3) if( m .eq. 0 ) go to 40 do 30 i = 1,m stemp = sx(i) sx(i) = sy(i) sy(i) = stemp 30 continue if( n .lt. 3 ) return 40 mp1 = m + 1 do 50 i = mp1,n,3 stemp = sx(i) sx(i) = sy(i) sy(i) = stemp stemp = sx(i + 1) sx(i + 1) = sy(i + 1) sy(i + 1) = stemp stemp = sx(i + 2) sx(i + 2) = sy(i + 2) sy(i + 2) = stemp 50 continue return end getdp-2.4.2-source/contrib/Arpack/icnteq.f000644 001750 001750 00000000604 11266605602 022077 0ustar00geuzainegeuzaine000000 000000 c c----------------------------------------------------------------------- c c Count the number of elements equal to a specified integer value. c integer function icnteq (n, array, value) c integer n, value integer array(*) c k = 0 do 10 i = 1, n if (array(i) .eq. value) k = k + 1 10 continue icnteq = k c return end getdp-2.4.2-source/contrib/Arpack/dneupd.f000644 001750 001750 00000126444 11266605602 022106 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: dneupd c c\Description: c c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) The corresponding approximate eigenvectors; c c (2) An orthonormal basis for the associated approximate c invariant subspace; c c (3) Both. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c basis is always computed. There is an additional storage cost of n*nev c if both are requested (in this case a separate array Z must be supplied). c c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z c are derived from approximate eigenvalues and eigenvectors of c of the linear operator OP prescribed by the MODE selection in the c call to DNAUPD . DNAUPD must be called before this routine is called. c These approximate eigenvalues and vectors are commonly called Ritz c values and Ritz vectors respectively. They are referred to as such c in the comments that follow. The computed orthonormal basis for the c invariant subspace corresponding to these Ritz values is referred to as a c Schur basis. c c See documentation in the header of the subroutine DNAUPD for c definition of OP as well as other terms and the relation of computed c Ritz values and Ritz vectors of OP with respect to the given problem c A*z = lambda*B*z. For a brief description, see definitions of c IPARAM(7), MODE and WHICH in the documentation of DNAUPD . c c\Usage: c call dneupd c ( RVEC, HOWMNY, SELECT, DR, DI, Z, LDZ, SIGMAR, SIGMAI, WORKEV, BMAT, c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, c LWORKL, INFO ) c c\Arguments: c RVEC LOGICAL (INPUT) c Specifies whether a basis for the invariant subspace corresponding c to the converged Ritz value approximations for the eigenproblem c A*z = lambda*B*z is computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute the Ritz vectors or Schur vectors. c See Remarks below. c c HOWMNY Character*1 (INPUT) c Specifies the form of the basis for the invariant subspace c corresponding to the converged Ritz values that is to be computed. c c = 'A': Compute NEV Ritz vectors; c = 'P': Compute NEV Schur vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the Ritz vector corresponding to a c Ritz value (DR(j), DI(j)), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' or 'P', SELECT is used as internal workspace. c c DR Double precision array of dimension NEV+1. (OUTPUT) c If IPARAM(7) = 1,2 or 3 and SIGMAI=0.0 then on exit: DR contains c the real part of the Ritz approximations to the eigenvalues of c A*z = lambda*B*z. c If IPARAM(7) = 3, 4 and SIGMAI is not equal to zero, then on exit: c DR contains the real part of the Ritz values of OP computed by c DNAUPD . A further computation must be performed by the user c to transform the Ritz values computed for OP by DNAUPD to those c of the original system A*z = lambda*B*z. See remark 3 below. c c DI Double precision array of dimension NEV+1. (OUTPUT) c On exit, DI contains the imaginary part of the Ritz value c approximations to the eigenvalues of A*z = lambda*B*z associated c with DR. c c NOTE: When Ritz values are complex, they will come in complex c conjugate pairs. If eigenvectors are requested, the c corresponding Ritz vectors will also come in conjugate c pairs and the real and imaginary parts of these are c represented in two consecutive columns of the array Z c (see below). c c Z Double precision N by NEV+1 array if RVEC = .TRUE. and HOWMNY = 'A'. (OUTPUT) c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of c Z represent approximate eigenvectors (Ritz vectors) corresponding c to the NCONV=IPARAM(5) Ritz values for eigensystem c A*z = lambda*B*z. c c The complex Ritz vector associated with the Ritz value c with positive imaginary part is stored in two consecutive c columns. The first column holds the real part of the Ritz c vector and the second column holds the imaginary part. The c Ritz vector associated with the Ritz value with negative c imaginary part is simply the complex conjugate of the Ritz vector c associated with the positive imaginary part. c c If RVEC = .FALSE. or HOWMNY = 'P', then Z is not referenced. c c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, c the array Z may be set equal to first NEV+1 columns of the Arnoldi c basis array V computed by DNAUPD . In this case the Arnoldi basis c will be destroyed and overwritten with the eigenvector basis. c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ >= max( 1, N ). In any case, LDZ >= 1. c c SIGMAR Double precision (INPUT) c If IPARAM(7) = 3 or 4, represents the real part of the shift. c Not referenced if IPARAM(7) = 1 or 2. c c SIGMAI Double precision (INPUT) c If IPARAM(7) = 3 or 4, represents the imaginary part of the shift. c Not referenced if IPARAM(7) = 1 or 2. See remark 3 below. c c WORKEV Double precision work array of dimension 3*NCV. (WORKSPACE) c c **** The remaining arguments MUST be the same as for the **** c **** call to DNAUPD that was just completed. **** c c NOTE: The remaining arguments c c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, c WORKD, WORKL, LWORKL, INFO c c must be passed directly to DNEUPD following the last call c to DNAUPD . These arguments MUST NOT BE MODIFIED between c the the last call to DNAUPD and the call to DNEUPD . c c Three of these parameters (V, WORKL, INFO) are also output parameters: c c V Double precision N by NCV array. (INPUT/OUTPUT) c c Upon INPUT: the NCV columns of V contain the Arnoldi basis c vectors for OP as constructed by DNAUPD . c c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns c contain approximate Schur vectors that span the c desired invariant subspace. See Remark 2 below. c c NOTE: If the array Z has been set equal to first NEV+1 columns c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the c Arnoldi basis held by V has been overwritten by the desired c Ritz vectors. If a separate array Z has been passed then c the first NCONV=IPARAM(5) columns of V will contain approximate c Schur vectors that span the desired invariant subspace. c c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) c WORKL(1:ncv*ncv+3*ncv) contains information obtained in c dnaupd . They are not changed by dneupd . c WORKL(ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) holds the c real and imaginary part of the untransformed Ritz values, c the upper quasi-triangular matrix for H, and the c associated matrix representation of the invariant subspace for H. c c Note: IPNTR(9:13) contains the pointer into WORKL for addresses c of the above information computed by dneupd . c ------------------------------------------------------------- c IPNTR(9): pointer to the real part of the NCV RITZ values of the c original system. c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of c the original system. c IPNTR(11): pointer to the NCV corresponding error bounds. c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular c Schur matrix for H. c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors c of the upper Hessenberg matrix H. Only referenced by c dneupd if RVEC = .TRUE. See Remark 2 below. c ------------------------------------------------------------- c c INFO Integer. (OUTPUT) c Error flag on output. c c = 0: Normal exit. c c = 1: The Schur form computed by LAPACK routine dlahqr c could not be reordered by LAPACK routine dtrsen . c Re-enter subroutine dneupd with IPARAM(5)=NCV and c increase the size of the arrays DR and DI to have c dimension at least dimension NCV and allocate at least NCV c columns for Z. NOTE: Not necessary if Z and V share c the same space. Please notify the authors if this error c occurs. c c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 2 and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from calculation of a real Schur form. c Informational error from LAPACK routine dlahqr . c = -9: Error return from calculation of eigenvectors. c Informational error from LAPACK routine dtrevc . c = -10: IPARAM(7) must be 1,2,3,4. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: HOWMNY = 'S' not yet implemented c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. c = -14: DNAUPD did not find any eigenvalues to sufficient c accuracy. c = -15: DNEUPD got a different count of the number of converged c Ritz values than DNAUPD got. This indicates the user c probably made an error in passing data from DNAUPD to c DNEUPD or that the data was modified before entering c DNEUPD c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for c Real Matrices", Linear Algebra and its Applications, vol 88/89, c pp 575-595, (1987). c c\Routines called: c ivout ARPACK utility routine that prints integers. c dmout ARPACK utility routine that prints matrices c dvout ARPACK utility routine that prints vectors. c dgeqr2 LAPACK routine that computes the QR factorization of c a matrix. c dlacpy LAPACK matrix copy routine. c dlahqr LAPACK routine to compute the real Schur form of an c upper Hessenberg matrix. c dlamch LAPACK routine that determines machine constants. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlaset LAPACK matrix initialization routine. c dorm2r LAPACK routine that applies an orthogonal matrix in c factored form. c dtrevc LAPACK routine to compute the eigenvectors of a matrix c in upper quasi-triangular form. c dtrsen LAPACK routine that re-orders the Schur form. c dtrmm Level 3 BLAS matrix times an upper triangular matrix. c dger Level 2 BLAS rank one update to a matrix. c dcopy Level 1 BLAS that copies one vector to another . c ddot Level 1 BLAS that computes the scalar product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dscal Level 1 BLAS that scales a vector. c c\Remarks c c 1. Currently only HOWMNY = 'A' and 'P' are implemented. c c Let trans(X) denote the transpose of X. c c 2. Schur vectors are an orthogonal representation for the basis of c Ritz vectors. Thus, their numerical properties are often superior. c If RVEC = .TRUE. then the relationship c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and c trans(V(:,1:IPARAM(5))) * V(:,1:IPARAM(5)) = I are approximately c satisfied. Here T is the leading submatrix of order IPARAM(5) of the c real upper quasi-triangular matrix stored workl(ipntr(12)). That is, c T is block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; c each 2-by-2 diagonal block has its diagonal elements equal and its c off-diagonal elements of opposite sign. Corresponding to each 2-by-2 c diagonal block is a complex conjugate pair of Ritz values. The real c Ritz values are stored on the diagonal of T. c c 3. If IPARAM(7) = 3 or 4 and SIGMAI is not equal zero, then the user must c form the IPARAM(5) Rayleigh quotients in order to transform the Ritz c values computed by DNAUPD for OP to those of A*z = lambda*B*z. c Set RVEC = .true. and HOWMNY = 'A', and c compute c trans(Z(:,I)) * A * Z(:,I) if DI(I) = 0. c If DI(I) is not equal to zero and DI(I+1) = - D(I), c then the desired real and imaginary parts of the Ritz value are c trans(Z(:,I)) * A * Z(:,I) + trans(Z(:,I+1)) * A * Z(:,I+1), c trans(Z(:,I)) * A * Z(:,I+1) - trans(Z(:,I+1)) * A * Z(:,I), c respectively. c Another possibility is to set RVEC = .true. and HOWMNY = 'P' and c compute trans(V(:,1:IPARAM(5))) * A * V(:,1:IPARAM(5)) and then an upper c quasi-triangular matrix of order IPARAM(5) is computed. See remark c 2 above. c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Chao Yang Houston, Texas c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: neupd.F SID: 2.7 DATE OF SID: 09/20/00 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- subroutine dneupd (rvec , howmny, select, dr , di, & z , ldz , sigmar, sigmai, workev, & bmat , n , which , nev , tol, & resid, ncv , v , ldv , iparam, & ipntr, workd , workl , lworkl, info) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat, howmny, which*2 logical rvec integer info, ldz, ldv, lworkl, n, ncv, nev Double precision & sigmar, sigmai, tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(14) logical select(ncv) Double precision & dr(nev+1) , di(nev+1), resid(n) , & v(ldv,ncv) , z(ldz,*) , workd(3*n), & workl(lworkl), workev(3*ncv) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0 , zero = 0.0D+0 ) c c %---------------% c | Local Scalars | c %---------------% c character type*6 integer bounds, ierr , ih , ihbds , & iheigr, iheigi, iconj , nconv , & invsub, iuptri, iwev , iwork(1), & j , k , ldh , ldq , & mode , msglvl, outncv, ritzr , & ritzi , wri , wrr , irr , & iri , ibd , ishift, numcnv , & np , jj logical reord Double precision & conds , rnorm, sep , temp, & vl(1,1), temp1, eps23 c c %----------------------% c | External Subroutines | c %----------------------% c external dcopy , dger , dgeqr2 , dlacpy , & dlahqr , dlaset , dmout , dorm2r , & dtrevc , dtrmm , dtrsen , dscal , & dvout , ivout c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlapy2 , dnrm2 , dlamch , ddot external dlapy2 , dnrm2 , dlamch , ddot c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs, min, sqrt c c %-----------------------% c | Executable Statements | c %-----------------------% c c %------------------------% c | Set default parameters | c %------------------------% c msglvl = mneupd mode = iparam(7) nconv = iparam(5) info = 0 c c %---------------------------------% c | Get machine dependent constant. | c %---------------------------------% c eps23 = dlamch ('Epsilon-Machine') eps23 = eps23**(2.0D+0 / 3.0D+0 ) c c %--------------% c | Quick return | c %--------------% c ierr = 0 c if (nconv .le. 0) then ierr = -14 else if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev+1 .or. ncv .gt. n) then ierr = -3 else if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LR' .and. & which .ne. 'SR' .and. & which .ne. 'LI' .and. & which .ne. 'SI') then ierr = -5 else if (bmat .ne. 'I' .and. bmat .ne. 'G') then ierr = -6 else if (lworkl .lt. 3*ncv**2 + 6*ncv) then ierr = -7 else if ( (howmny .ne. 'A' .and. & howmny .ne. 'P' .and. & howmny .ne. 'S') .and. rvec ) then ierr = -13 else if (howmny .eq. 'S' ) then ierr = -12 end if c if (mode .eq. 1 .or. mode .eq. 2) then type = 'REGULR' else if (mode .eq. 3 .and. sigmai .eq. zero) then type = 'SHIFTI' else if (mode .eq. 3 ) then type = 'REALPT' else if (mode .eq. 4 ) then type = 'IMAGPT' else ierr = -10 end if if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr go to 9000 end if c c %--------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:ncv*ncv) := generated Hessenberg matrix | c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | c | parts of ritz values | c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | c %--------------------------------------------------------% c c %-----------------------------------------------------------% c | The following is used and set by DNEUPD . | c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | c | real part of the Ritz values. | c | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | c | imaginary part of the Ritz values. | c | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | c | error bounds of the Ritz values | c | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | c | quasi-triangular matrix for H | c | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | c | associated matrix representation of the invariant | c | subspace for H. | c | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | c %-----------------------------------------------------------% c ih = ipntr(5) ritzr = ipntr(6) ritzi = ipntr(7) bounds = ipntr(8) ldh = ncv ldq = ncv iheigr = bounds + ldh iheigi = iheigr + ldh ihbds = iheigi + ldh iuptri = ihbds + ldh invsub = iuptri + ldh*ncv ipntr(9) = iheigr ipntr(10) = iheigi ipntr(11) = ihbds ipntr(12) = iuptri ipntr(13) = invsub wrr = 1 wri = ncv + 1 iwev = wri + ncv c c %-----------------------------------------% c | irr points to the REAL part of the Ritz | c | values computed by _neigh before | c | exiting _naup2. | c | iri points to the IMAGINARY part of the | c | Ritz values computed by _neigh | c | before exiting _naup2. | c | ibd points to the Ritz estimates | c | computed by _neigh before exiting | c | _naup2. | c %-----------------------------------------% c irr = ipntr(14)+ncv*ncv iri = irr+ncv ibd = iri+ncv c c %------------------------------------% c | RNORM is B-norm of the RESID(1:N). | c %------------------------------------% c rnorm = workl(ih+2) workl(ih+2) = zero c if (msglvl .gt. 2) then call dvout (logfil, ncv, workl(irr), ndigit, & '_neupd: Real part of Ritz values passed in from _NAUPD.') call dvout (logfil, ncv, workl(iri), ndigit, & '_neupd: Imag part of Ritz values passed in from _NAUPD.') call dvout (logfil, ncv, workl(ibd), ndigit, & '_neupd: Ritz estimates passed in from _NAUPD.') end if c if (rvec) then c reord = .false. c c %---------------------------------------------------% c | Use the temporary bounds array to store indices | c | These will be used to mark the select array later | c %---------------------------------------------------% c do 10 j = 1,ncv workl(bounds+j-1) = j select(j) = .false. 10 continue c c %-------------------------------------% c | Select the wanted Ritz values. | c | Sort the Ritz values so that the | c | wanted ones appear at the tailing | c | NEV positions of workl(irr) and | c | workl(iri). Move the corresponding | c | error estimates in workl(bound) | c | accordingly. | c %-------------------------------------% c np = ncv - nev ishift = 0 call dngets (ishift , which , nev , & np , workl(irr), workl(iri), & workl(bounds), workl , workl(np+1)) c if (msglvl .gt. 2) then call dvout (logfil, ncv, workl(irr), ndigit, & '_neupd: Real part of Ritz values after calling _NGETS.') call dvout (logfil, ncv, workl(iri), ndigit, & '_neupd: Imag part of Ritz values after calling _NGETS.') call dvout (logfil, ncv, workl(bounds), ndigit, & '_neupd: Ritz value indices after calling _NGETS.') end if c c %-----------------------------------------------------% c | Record indices of the converged wanted Ritz values | c | Mark the select array for possible reordering | c %-----------------------------------------------------% c numcnv = 0 do 11 j = 1,ncv temp1 = max(eps23, & dlapy2 ( workl(irr+ncv-j), workl(iri+ncv-j) )) jj = workl(bounds + ncv - j) if (numcnv .lt. nconv .and. & workl(ibd+jj-1) .le. tol*temp1) then select(jj) = .true. numcnv = numcnv + 1 if (jj .gt. nev) reord = .true. endif 11 continue c c %-----------------------------------------------------------% c | Check the count (numcnv) of converged Ritz values with | c | the number (nconv) reported by dnaupd. If these two | c | are different then there has probably been an error | c | caused by incorrect passing of the dnaupd data. | c %-----------------------------------------------------------% c if (msglvl .gt. 2) then call ivout(logfil, 1, numcnv, ndigit, & '_neupd: Number of specified eigenvalues') call ivout(logfil, 1, nconv, ndigit, & '_neupd: Number of "converged" eigenvalues') end if c if (numcnv .ne. nconv) then info = -15 go to 9000 end if c c %-----------------------------------------------------------% c | Call LAPACK routine dlahqr to compute the real Schur form | c | of the upper Hessenberg matrix returned by DNAUPD . | c | Make a copy of the upper Hessenberg matrix. | c | Initialize the Schur vector matrix Q to the identity. | c %-----------------------------------------------------------% c call dcopy (ldh*ncv, workl(ih), 1, workl(iuptri), 1) call dlaset ('All', ncv, ncv, & zero , one, workl(invsub), & ldq) call dlahqr (.true., .true. , ncv, & 1 , ncv , workl(iuptri), & ldh , workl(iheigr), workl(iheigi), & 1 , ncv , workl(invsub), & ldq , ierr) call dcopy (ncv , workl(invsub+ncv-1), ldq, & workl(ihbds), 1) c if (ierr .ne. 0) then info = -8 go to 9000 end if c if (msglvl .gt. 1) then call dvout (logfil, ncv, workl(iheigr), ndigit, & '_neupd: Real part of the eigenvalues of H') call dvout (logfil, ncv, workl(iheigi), ndigit, & '_neupd: Imaginary part of the Eigenvalues of H') call dvout (logfil, ncv, workl(ihbds), ndigit, & '_neupd: Last row of the Schur vector matrix') if (msglvl .gt. 3) then call dmout (logfil , ncv, ncv , & workl(iuptri), ldh, ndigit, & '_neupd: The upper quasi-triangular matrix ') end if end if c if (reord) then c c %-----------------------------------------------------% c | Reorder the computed upper quasi-triangular matrix. | c %-----------------------------------------------------% c call dtrsen ('None' , 'V' , & select , ncv , & workl(iuptri), ldh , & workl(invsub), ldq , & workl(iheigr), workl(iheigi), & nconv , conds , & sep , workl(ihbds) , & ncv , iwork , & 1 , ierr) c if (ierr .eq. 1) then info = 1 go to 9000 end if c if (msglvl .gt. 2) then call dvout (logfil, ncv, workl(iheigr), ndigit, & '_neupd: Real part of the eigenvalues of H--reordered') call dvout (logfil, ncv, workl(iheigi), ndigit, & '_neupd: Imag part of the eigenvalues of H--reordered') if (msglvl .gt. 3) then call dmout (logfil , ncv, ncv , & workl(iuptri), ldq, ndigit, & '_neupd: Quasi-triangular matrix after re-ordering') end if end if c end if c c %---------------------------------------% c | Copy the last row of the Schur vector | c | into workl(ihbds). This will be used | c | to compute the Ritz estimates of | c | converged Ritz values. | c %---------------------------------------% c call dcopy (ncv, workl(invsub+ncv-1), ldq, workl(ihbds), 1) c c %----------------------------------------------------% c | Place the computed eigenvalues of H into DR and DI | c | if a spectral transformation was not used. | c %----------------------------------------------------% c if (type .eq. 'REGULR') then call dcopy (nconv, workl(iheigr), 1, dr, 1) call dcopy (nconv, workl(iheigi), 1, di, 1) end if c c %----------------------------------------------------------% c | Compute the QR factorization of the matrix representing | c | the wanted invariant subspace located in the first NCONV | c | columns of workl(invsub,ldq). | c %----------------------------------------------------------% c call dgeqr2 (ncv, nconv , workl(invsub), & ldq, workev, workev(ncv+1), & ierr) c c %---------------------------------------------------------% c | * Postmultiply V by Q using dorm2r . | c | * Copy the first NCONV columns of VQ into Z. | c | * Postmultiply Z by R. | c | The N by NCONV matrix Z is now a matrix representation | c | of the approximate invariant subspace associated with | c | the Ritz values in workl(iheigr) and workl(iheigi) | c | The first NCONV columns of V are now approximate Schur | c | vectors associated with the real upper quasi-triangular | c | matrix of order NCONV in workl(iuptri) | c %---------------------------------------------------------% c call dorm2r ('Right', 'Notranspose', n , & ncv , nconv , workl(invsub), & ldq , workev , v , & ldv , workd(n+1) , ierr) call dlacpy ('All', n, nconv, v, ldv, z, ldz) c do 20 j=1, nconv c c %---------------------------------------------------% c | Perform both a column and row scaling if the | c | diagonal element of workl(invsub,ldq) is negative | c | I'm lazy and don't take advantage of the upper | c | quasi-triangular form of workl(iuptri,ldq) | c | Note that since Q is orthogonal, R is a diagonal | c | matrix consisting of plus or minus ones | c %---------------------------------------------------% c if (workl(invsub+(j-1)*ldq+j-1) .lt. zero) then call dscal (nconv, -one, workl(iuptri+j-1), ldq) call dscal (nconv, -one, workl(iuptri+(j-1)*ldq), 1) end if c 20 continue c if (howmny .eq. 'A') then c c %--------------------------------------------% c | Compute the NCONV wanted eigenvectors of T | c | located in workl(iuptri,ldq). | c %--------------------------------------------% c do 30 j=1, ncv if (j .le. nconv) then select(j) = .true. else select(j) = .false. end if 30 continue c call dtrevc ('Right', 'Select' , select , & ncv , workl(iuptri), ldq , & vl , 1 , workl(invsub), & ldq , ncv , outncv , & workev , ierr) c if (ierr .ne. 0) then info = -9 go to 9000 end if c c %------------------------------------------------% c | Scale the returning eigenvectors so that their | c | Euclidean norms are all one. LAPACK subroutine | c | dtrevc returns each eigenvector normalized so | c | that the element of largest magnitude has | c | magnitude 1; | c %------------------------------------------------% c iconj = 0 do 40 j=1, nconv c if ( workl(iheigi+j-1) .eq. zero ) then c c %----------------------% c | real eigenvalue case | c %----------------------% c temp = dnrm2 ( ncv, workl(invsub+(j-1)*ldq), 1 ) call dscal ( ncv, one / temp, & workl(invsub+(j-1)*ldq), 1 ) c else c c %-------------------------------------------% c | Complex conjugate pair case. Note that | c | since the real and imaginary part of | c | the eigenvector are stored in consecutive | c | columns, we further normalize by the | c | square root of two. | c %-------------------------------------------% c if (iconj .eq. 0) then temp = dlapy2 (dnrm2 (ncv, & workl(invsub+(j-1)*ldq), & 1), & dnrm2 (ncv, & workl(invsub+j*ldq), & 1)) call dscal (ncv, one/temp, & workl(invsub+(j-1)*ldq), 1 ) call dscal (ncv, one/temp, & workl(invsub+j*ldq), 1 ) iconj = 1 else iconj = 0 end if c end if c 40 continue c call dgemv ('T', ncv, nconv, one, workl(invsub), & ldq, workl(ihbds), 1, zero, workev, 1) c iconj = 0 do 45 j=1, nconv if (workl(iheigi+j-1) .ne. zero) then c c %-------------------------------------------% c | Complex conjugate pair case. Note that | c | since the real and imaginary part of | c | the eigenvector are stored in consecutive | c %-------------------------------------------% c if (iconj .eq. 0) then workev(j) = dlapy2 (workev(j), workev(j+1)) workev(j+1) = workev(j) iconj = 1 else iconj = 0 end if end if 45 continue c if (msglvl .gt. 2) then call dcopy (ncv, workl(invsub+ncv-1), ldq, & workl(ihbds), 1) call dvout (logfil, ncv, workl(ihbds), ndigit, & '_neupd: Last row of the eigenvector matrix for T') if (msglvl .gt. 3) then call dmout (logfil, ncv, ncv, workl(invsub), ldq, & ndigit, '_neupd: The eigenvector matrix for T') end if end if c c %---------------------------------------% c | Copy Ritz estimates into workl(ihbds) | c %---------------------------------------% c call dcopy (nconv, workev, 1, workl(ihbds), 1) c c %---------------------------------------------------------% c | Compute the QR factorization of the eigenvector matrix | c | associated with leading portion of T in the first NCONV | c | columns of workl(invsub,ldq). | c %---------------------------------------------------------% c call dgeqr2 (ncv, nconv , workl(invsub), & ldq, workev, workev(ncv+1), & ierr) c c %----------------------------------------------% c | * Postmultiply Z by Q. | c | * Postmultiply Z by R. | c | The N by NCONV matrix Z is now contains the | c | Ritz vectors associated with the Ritz values | c | in workl(iheigr) and workl(iheigi). | c %----------------------------------------------% c call dorm2r ('Right', 'Notranspose', n , & ncv , nconv , workl(invsub), & ldq , workev , z , & ldz , workd(n+1) , ierr) c call dtrmm ('Right' , 'Upper' , 'No transpose', & 'Non-unit', n , nconv , & one , workl(invsub), ldq , & z , ldz) c end if c else c c %------------------------------------------------------% c | An approximate invariant subspace is not needed. | c | Place the Ritz values computed DNAUPD into DR and DI | c %------------------------------------------------------% c call dcopy (nconv, workl(ritzr), 1, dr, 1) call dcopy (nconv, workl(ritzi), 1, di, 1) call dcopy (nconv, workl(ritzr), 1, workl(iheigr), 1) call dcopy (nconv, workl(ritzi), 1, workl(iheigi), 1) call dcopy (nconv, workl(bounds), 1, workl(ihbds), 1) end if c c %------------------------------------------------% c | Transform the Ritz values and possibly vectors | c | and corresponding error bounds of OP to those | c | of A*x = lambda*B*x. | c %------------------------------------------------% c if (type .eq. 'REGULR') then c if (rvec) & call dscal (ncv, rnorm, workl(ihbds), 1) c else c c %---------------------------------------% c | A spectral transformation was used. | c | * Determine the Ritz estimates of the | c | Ritz values in the original system. | c %---------------------------------------% c if (type .eq. 'SHIFTI') then c if (rvec) & call dscal (ncv, rnorm, workl(ihbds), 1) c do 50 k=1, ncv temp = dlapy2 ( workl(iheigr+k-1), & workl(iheigi+k-1) ) workl(ihbds+k-1) = abs( workl(ihbds+k-1) ) & / temp / temp 50 continue c else if (type .eq. 'REALPT') then c do 60 k=1, ncv 60 continue c else if (type .eq. 'IMAGPT') then c do 70 k=1, ncv 70 continue c end if c c %-----------------------------------------------------------% c | * Transform the Ritz values back to the original system. | c | For TYPE = 'SHIFTI' the transformation is | c | lambda = 1/theta + sigma | c | For TYPE = 'REALPT' or 'IMAGPT' the user must from | c | Rayleigh quotients or a projection. See remark 3 above.| c | NOTES: | c | *The Ritz vectors are not affected by the transformation. | c %-----------------------------------------------------------% c if (type .eq. 'SHIFTI') then c do 80 k=1, ncv temp = dlapy2 ( workl(iheigr+k-1), & workl(iheigi+k-1) ) workl(iheigr+k-1) = workl(iheigr+k-1)/temp/temp & + sigmar workl(iheigi+k-1) = -workl(iheigi+k-1)/temp/temp & + sigmai 80 continue c call dcopy (nconv, workl(iheigr), 1, dr, 1) call dcopy (nconv, workl(iheigi), 1, di, 1) c else if (type .eq. 'REALPT' .or. type .eq. 'IMAGPT') then c call dcopy (nconv, workl(iheigr), 1, dr, 1) call dcopy (nconv, workl(iheigi), 1, di, 1) c end if c end if c if (type .eq. 'SHIFTI' .and. msglvl .gt. 1) then call dvout (logfil, nconv, dr, ndigit, & '_neupd: Untransformed real part of the Ritz valuess.') call dvout (logfil, nconv, di, ndigit, & '_neupd: Untransformed imag part of the Ritz valuess.') call dvout (logfil, nconv, workl(ihbds), ndigit, & '_neupd: Ritz estimates of untransformed Ritz values.') else if (type .eq. 'REGULR' .and. msglvl .gt. 1) then call dvout (logfil, nconv, dr, ndigit, & '_neupd: Real parts of converged Ritz values.') call dvout (logfil, nconv, di, ndigit, & '_neupd: Imag parts of converged Ritz values.') call dvout (logfil, nconv, workl(ihbds), ndigit, & '_neupd: Associated Ritz estimates.') end if c c %-------------------------------------------------% c | Eigenvector Purification step. Formally perform | c | one of inverse subspace iteration. Only used | c | for MODE = 2. | c %-------------------------------------------------% c if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then c c %------------------------------------------------% c | Purify the computed Ritz vectors by adding a | c | little bit of the residual vector: | c | T | c | resid(:)*( e s ) / theta | c | NCV | c | where H s = s theta. Remember that when theta | c | has nonzero imaginary part, the corresponding | c | Ritz vector is stored across two columns of Z. | c %------------------------------------------------% c iconj = 0 do 110 j=1, nconv if (workl(iheigi+j-1) .eq. zero) then workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / & workl(iheigr+j-1) else if (iconj .eq. 0) then temp = dlapy2 ( workl(iheigr+j-1), workl(iheigi+j-1) ) workev(j) = ( workl(invsub+(j-1)*ldq+ncv-1) * & workl(iheigr+j-1) + & workl(invsub+j*ldq+ncv-1) * & workl(iheigi+j-1) ) / temp / temp workev(j+1) = ( workl(invsub+j*ldq+ncv-1) * & workl(iheigr+j-1) - & workl(invsub+(j-1)*ldq+ncv-1) * & workl(iheigi+j-1) ) / temp / temp iconj = 1 else iconj = 0 end if 110 continue c c %---------------------------------------% c | Perform a rank one update to Z and | c | purify all the Ritz vectors together. | c %---------------------------------------% c call dger (n, nconv, one, resid, 1, workev, 1, z, ldz) c end if c 9000 continue c return c c %---------------% c | End of DNEUPD | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/ssaupd.f000644 001750 001750 00000070372 11266605602 022124 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: ssaupd c c\Description: c c Reverse communication interface for the Implicitly Restarted Arnoldi c Iteration. For symmetric problems this reduces to a variant of the Lanczos c method. This method has been designed to compute approximations to a c few eigenpairs of a linear operator OP that is real and symmetric c with respect to a real positive semi-definite symmetric matrix B, c i.e. c c B*OP = (OP`)*B. c c Another way to express this condition is c c < x,OPy > = < OPx,y > where < z,w > = z`Bw . c c In the standard eigenproblem B is the identity matrix. c ( A` denotes transpose of A) c c The computed approximate eigenvalues are called Ritz values and c the corresponding approximate eigenvectors are called Ritz vectors. c c ssaupd is usually called iteratively to solve one of the c following problems: c c Mode 1: A*x = lambda*x, A symmetric c ===> OP = A and B = I. c c Mode 2: A*x = lambda*M*x, A symmetric, M symmetric positive definite c ===> OP = inv[M]*A and B = M. c ===> (If M can be factored see remark 3 below) c c Mode 3: K*x = lambda*M*x, K symmetric, M symmetric positive semi-definite c ===> OP = (inv[K - sigma*M])*M and B = M. c ===> Shift-and-Invert mode c c Mode 4: K*x = lambda*KG*x, K symmetric positive semi-definite, c KG symmetric indefinite c ===> OP = (inv[K - sigma*KG])*K and B = K. c ===> Buckling mode c c Mode 5: A*x = lambda*M*x, A symmetric, M symmetric positive semi-definite c ===> OP = inv[A - sigma*M]*[A + sigma*M] and B = M. c ===> Cayley transformed mode c c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v c should be accomplished either by a direct method c using a sparse matrix factorization and solving c c [A - sigma*M]*w = v or M*w = v, c c or through an iterative method for solving these c systems. If an iterative method is used, the c convergence test must be more stringent than c the accuracy requirements for the eigenvalue c approximations. c c\Usage: c call ssaupd c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, c IPNTR, WORKD, WORKL, LWORKL, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to ssaupd. IDO will be set internally to c indicate the type of operation to be performed. Control is c then given back to the calling routine which has the c responsibility to carry out the requested operation and call c ssaupd with the result. The operand is given in c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). c (If Mode = 2 see remark 5 below) c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c In mode 3,4 and 5, the vector B * X is already c available in WORKD(ipntr(3)). It does not c need to be recomputed in forming OP * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 3: compute the IPARAM(8) shifts where c IPNTR(11) is the pointer into WORKL for c placing the shifts. See remark 6 below. c IDO = 99: done c ------------------------------------------------------------- c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c WHICH Character*2. (INPUT) c Specify which of the Ritz values of OP to compute. c c 'LA' - compute the NEV largest (algebraic) eigenvalues. c 'SA' - compute the NEV smallest (algebraic) eigenvalues. c 'LM' - compute the NEV largest (in magnitude) eigenvalues. c 'SM' - compute the NEV smallest (in magnitude) eigenvalues. c 'BE' - compute NEV eigenvalues, half from each end of the c spectrum. When NEV is odd, compute one more from the c high end than from the low end. c (see remark 1 below) c c NEV Integer. (INPUT) c Number of eigenvalues of OP to be computed. 0 < NEV < N. c c TOL Real scalar. (INPUT) c Stopping criterion: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)). c If TOL .LE. 0. is passed a default is set: c DEFAULT = SLAMCH('EPS') (machine precision as computed c by the LAPACK auxiliary subroutine SLAMCH). c c RESID Real array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V (less than or equal to N). c This will indicate how many Lanczos vectors are generated c at each iteration. After the startup phase in which NEV c Lanczos vectors are generated, the algorithm generates c NCV-NEV Lanczos vectors at each subsequent update iteration. c Most of the cost in generating each Lanczos vector is in the c matrix-vector product OP*x. (See remark 4 below). c c V Real N by NCV array. (OUTPUT) c The NCV columns of V contain the Lanczos basis vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. c The shifts selected at each iteration are used to restart c the Arnoldi iteration in an implicit fashion. c ------------------------------------------------------------- c ISHIFT = 0: the shifts are provided by the user via c reverse communication. The NCV eigenvalues of c the current tridiagonal matrix T are returned in c the part of WORKL array corresponding to RITZ. c See remark 6 below. c ISHIFT = 1: exact shifts with respect to the reduced c tridiagonal matrix T. This is equivalent to c restarting the iteration with a starting vector c that is a linear combination of Ritz vectors c associated with the "wanted" Ritz values. c ------------------------------------------------------------- c c IPARAM(2) = LEVEC c No longer referenced. See remark 2 below. c c IPARAM(3) = MXITER c On INPUT: maximum number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" Ritz values. c This represents the number of Ritz values that satisfy c the convergence criterion. c c IPARAM(6) = IUPD c No longer referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = MODE c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2,3,4,5; See under \Description of ssaupd for the c five modes available. c c IPARAM(8) = NP c When ido = 3 and the user provides shifts through reverse c communication (IPARAM(1)=0), ssaupd returns NP, the number c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark c 6 below. c c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, c OUTPUT: NUMOP = total number of OP*x operations, c NUMOPB = total number of B*x operations if BMAT='G', c NUMREO = total number of steps of re-orthogonalization. c c IPNTR Integer array of length 11. (OUTPUT) c Pointer to mark the starting locations in the WORKD and WORKL c arrays for matrices/vectors used by the Lanczos iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X in WORKD. c IPNTR(2): pointer to the current result vector Y in WORKD. c IPNTR(3): pointer to the vector B * X in WORKD when used in c the shift-and-invert mode. c IPNTR(4): pointer to the next available location in WORKL c that is untouched by the program. c IPNTR(5): pointer to the NCV by 2 tridiagonal matrix T in WORKL. c IPNTR(6): pointer to the NCV RITZ values array in WORKL. c IPNTR(7): pointer to the Ritz estimates in array WORKL associated c with the Ritz values located in RITZ in WORKL. c IPNTR(11): pointer to the NP shifts in WORKL. See Remark 6 below. c c Note: IPNTR(8:10) is only referenced by sseupd. See Remark 2. c IPNTR(8): pointer to the NCV RITZ values of the original system. c IPNTR(9): pointer to the NCV corresponding error bounds. c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors c of the tridiagonal matrix T. Only referenced by c sseupd if RVEC = .TRUE. See Remarks. c ------------------------------------------------------------- c c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration. Upon termination c WORKD(1:N) contains B*RESID(1:N). If the Ritz vectors are desired c subroutine sseupd uses this output. c See Data Distribution Note below. c c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. See Data Distribution Note below. c c LWORKL Integer. (INPUT) c LWORKL must be at least NCV**2 + 8*NCV . c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal exit. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. IPARAM(5) c returns the number of wanted converged Ritz values. c = 2: No longer an informational error. Deprecated starting c with release 2 of ARPACK. c = 3: No shifts could be applied during a cycle of the c Implicitly restarted Arnoldi iteration. One possibility c is to increase the size of NCV relative to NEV. c See remark 4 below. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV must be greater than NEV and less than or equal to N. c = -4: The maximum number of Arnoldi update iterations allowed c must be greater than zero. c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work array WORKL is not sufficient. c = -8: Error return from trid. eigenvalue calculation; c Informatinal error from LAPACK routine ssteqr. c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3,4,5. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable. c = -12: IPARAM(1) must be equal to 0 or 1. c = -13: NEV and WHICH = 'BE' are incompatable. c = -9999: Could not build an Arnoldi factorization. c IPARAM(5) returns the size of the current Arnoldi c factorization. The user is advised to check that c enough workspace and array storage has been allocated. c c c\Remarks c 1. The converged Ritz values are always returned in ascending c algebraic order. The computed Ritz values are approximate c eigenvalues of OP. The selection of WHICH should be made c with this in mind when Mode = 3,4,5. After convergence, c approximate eigenvalues of the original problem may be obtained c with the ARPACK subroutine sseupd. c c 2. If the Ritz vectors corresponding to the converged Ritz values c are needed, the user must call sseupd immediately following completion c of ssaupd. This is new starting with version 2.1 of ARPACK. c c 3. If M can be factored into a Cholesky factorization M = LL` c then Mode = 2 should not be selected. Instead one should use c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular c linear systems should be solved with L and L` rather c than computing inverses. After convergence, an approximate c eigenvector z of the original problem is recovered by solving c L`z = x where x is a Ritz vector of OP. c c 4. At present there is no a-priori analysis to guide the selection c of NCV relative to NEV. The only formal requrement is that NCV > NEV. c However, it is recommended that NCV .ge. 2*NEV. If many problems of c the same type are to be solved, one should experiment with increasing c NCV while keeping NEV fixed for a given test problem. This will c usually decrease the required number of OP*x operations but it c also increases the work and storage required to maintain the orthogonal c basis vectors. The optimal "cross-over" with respect to CPU time c is problem dependent and must be determined empirically. c c 5. If IPARAM(7) = 2 then in the Reverse commuication interface the user c must do the following. When IDO = 1, Y = OP * X is to be computed. c When IPARAM(7) = 2 OP = inv(B)*A. After computing A*X the user c must overwrite X with A*X. Y is then the solution to the linear set c of equations B*Y = A*X. c c 6. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the c NP = IPARAM(8) shifts in locations: c 1 WORKL(IPNTR(11)) c 2 WORKL(IPNTR(11)+1) c . c . c . c NP WORKL(IPNTR(11)+NP-1). c c The eigenvalues of the current tridiagonal matrix are located in c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are in the c order defined by WHICH. The associated Ritz estimates are located in c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). c c----------------------------------------------------------------------- c c\Data Distribution Note: c c Fortran-D syntax: c ================ c REAL RESID(N), V(LDV,NCV), WORKD(3*N), WORKL(LWORKL) c DECOMPOSE D1(N), D2(N,NCV) c ALIGN RESID(I) with D1(I) c ALIGN V(I,J) with D2(I,J) c ALIGN WORKD(I) with D1(I) range (1:N) c ALIGN WORKD(I) with D1(I-N) range (N+1:2*N) c ALIGN WORKD(I) with D1(I-2*N) range (2*N+1:3*N) c DISTRIBUTE D1(BLOCK), D2(BLOCK,:) c REPLICATED WORKL(LWORKL) c c Cray MPP syntax: c =============== c REAL RESID(N), V(LDV,NCV), WORKD(N,3), WORKL(LWORKL) c SHARED RESID(BLOCK), V(BLOCK,:), WORKD(BLOCK,:) c REPLICATED WORKL(LWORKL) c c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, c 1980. c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", c Computer Physics Communications, 53 (1989), pp 169-179. c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to c Implement the Spectral Transformation", Math. Comp., 48 (1987), c pp 663-673. c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", c SIAM J. Matr. Anal. Apps., January (1993). c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines c for Updating the QR decomposition", ACM TOMS, December 1990, c Volume 16 Number 4, pp 369-377. c 8. R.B. Lehoucq, D.C. Sorensen, "Implementation of Some Spectral c Transformations in a k-Step Arnoldi Method". In Preparation. c c\Routines called: c ssaup2 ARPACK routine that implements the Implicitly Restarted c Arnoldi Iteration. c sstats ARPACK routine that initialize timing and other statistics c variables. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c svout ARPACK utility routine that prints vectors. c slamch LAPACK routine that determines machine constants. c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/15/93: Version ' 2.4' c c\SCCS Information: @(#) c FILE: saupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c subroutine ssaupd & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, & ipntr, workd, workl, lworkl, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ldv, lworkl, n, ncv, nev Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(11) Real & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0 , zero = 0.0E+0 ) c c %---------------% c | Local Scalars | c %---------------% c integer bounds, ierr, ih, iq, ishift, iupd, iw, & ldh, ldq, msglvl, mxiter, mode, nb, & nev0, next, np, ritz, j save bounds, ierr, ih, iq, ishift, iupd, iw, & ldh, ldq, msglvl, mxiter, mode, nb, & nev0, next, np, ritz c c %----------------------% c | External Subroutines | c %----------------------% c external ssaup2, svout, ivout, second, sstats c c %--------------------% c | External Functions | c %--------------------% c Real & slamch external slamch c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call sstats call second (t0) msglvl = msaupd c ierr = 0 ishift = iparam(1) mxiter = iparam(3) c nb = iparam(4) nb = 1 c c %--------------------------------------------% c | Revision 2 performs only implicit restart. | c %--------------------------------------------% c iupd = 1 mode = iparam(7) c c %----------------% c | Error checking | c %----------------% c if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev .or. ncv .gt. n) then ierr = -3 end if c c %----------------------------------------------% c | NP is the number of additional steps to | c | extend the length NEV Lanczos factorization. | c %----------------------------------------------% c np = ncv - nev c if (mxiter .le. 0) ierr = -4 if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LA' .and. & which .ne. 'SA' .and. & which .ne. 'BE') ierr = -5 if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 c if (lworkl .lt. ncv**2 + 8*ncv) ierr = -7 if (mode .lt. 1 .or. mode .gt. 5) then ierr = -10 else if (mode .eq. 1 .and. bmat .eq. 'G') then ierr = -11 else if (ishift .lt. 0 .or. ishift .gt. 1) then ierr = -12 else if (nev .eq. 1 .and. which .eq. 'BE') then ierr = -13 end if c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr ido = 99 go to 9000 end if c c %------------------------% c | Set default parameters | c %------------------------% c if (nb .le. 0) nb = 1 if (tol .le. zero) tol = slamch('EpsMach') c c %----------------------------------------------% c | NP is the number of additional steps to | c | extend the length NEV Lanczos factorization. | c | NEV0 is the local variable designating the | c | size of the invariant subspace desired. | c %----------------------------------------------% c np = ncv - nev nev0 = nev c c %-----------------------------% c | Zero out internal workspace | c %-----------------------------% c do 10 j = 1, ncv**2 + 8*ncv workl(j) = zero 10 continue c c %-------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:2*ncv) := generated tridiagonal matrix | c | workl(2*ncv+1:2*ncv+ncv) := ritz values | c | workl(3*ncv+1:3*ncv+ncv) := computed error bounds | c | workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q | c | workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace | c %-------------------------------------------------------% c ldh = ncv ldq = ncv ih = 1 ritz = ih + 2*ldh bounds = ritz + ncv iq = bounds + ncv iw = iq + ncv**2 next = iw + 3*ncv c ipntr(4) = next ipntr(5) = ih ipntr(6) = ritz ipntr(7) = bounds ipntr(11) = iw end if c c %-------------------------------------------------------% c | Carry out the Implicitly restarted Lanczos Iteration. | c %-------------------------------------------------------% c call ssaup2 & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), & workl(bounds), workl(iq), ldq, workl(iw), ipntr, workd, & info ) c c %--------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP or shifts. | c %--------------------------------------------------% c if (ido .eq. 3) iparam(8) = np if (ido .ne. 99) go to 9000 c iparam(3) = mxiter iparam(5) = np iparam(9) = nopx iparam(10) = nbx iparam(11) = nrorth c c %------------------------------------% c | Exit if there was an informational | c | error within ssaup2. | c %------------------------------------% c if (info .lt. 0) go to 9000 if (info .eq. 2) info = 3 c if (msglvl .gt. 0) then call ivout (logfil, 1, mxiter, ndigit, & '_saupd: number of update iterations taken') call ivout (logfil, 1, np, ndigit, & '_saupd: number of "converged" Ritz values') call svout (logfil, np, workl(Ritz), ndigit, & '_saupd: final Ritz values') call svout (logfil, np, workl(Bounds), ndigit, & '_saupd: corresponding error bounds') end if c call second (t1) tsaupd = t1 - t0 c if (msglvl .gt. 0) then c c %--------------------------------------------------------% c | Version Number & Version Date are defined in version.h | c %--------------------------------------------------------% c write (6,1000) write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, & tmvopx, tmvbx, tsaupd, tsaup2, tsaitr, titref, & tgetv0, tseigt, tsgets, tsapps, tsconv 1000 format (//, & 5x, '==========================================',/ & 5x, '= Symmetric implicit Arnoldi update code =',/ & 5x, '= Version Number:', ' 2.4' , 19x, ' =',/ & 5x, '= Version Date: ', ' 07/31/96' , 14x, ' =',/ & 5x, '==========================================',/ & 5x, '= Summary of timing statistics =',/ & 5x, '==========================================',//) 1100 format ( & 5x, 'Total number update iterations = ', i5,/ & 5x, 'Total number of OP*x operations = ', i5,/ & 5x, 'Total number of B*x operations = ', i5,/ & 5x, 'Total number of reorthogonalization steps = ', i5,/ & 5x, 'Total number of iterative refinement steps = ', i5,/ & 5x, 'Total number of restart steps = ', i5,/ & 5x, 'Total time in user OP*x operation = ', f12.6,/ & 5x, 'Total time in user B*x operation = ', f12.6,/ & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ & 5x, 'Total time in saup2 routine = ', f12.6,/ & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ & 5x, 'Total time in (re)start vector generation = ', f12.6,/ & 5x, 'Total time in trid eigenvalue subproblem = ', f12.6,/ & 5x, 'Total time in getting the shifts = ', f12.6,/ & 5x, 'Total time in applying the shifts = ', f12.6,/ & 5x, 'Total time in convergence testing = ', f12.6) end if c 9000 continue c return c c %---------------% c | End of ssaupd | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/sstatn.f000644 001750 001750 00000002710 11266605602 022130 0ustar00geuzainegeuzaine000000 000000 c c %---------------------------------------------% c | Initialize statistic and timing information | c | for nonsymmetric Arnoldi code. | c %---------------------------------------------% c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: statn.F SID: 2.4 DATE OF SID: 4/20/96 RELEASE: 2 c subroutine sstatn c c %--------------------------------% c | See stat.doc for documentation | c %--------------------------------% c include 'stat.h' c c %-----------------------% c | Executable Statements | c %-----------------------% c nopx = 0 nbx = 0 nrorth = 0 nitref = 0 nrstrt = 0 c tnaupd = 0.0E+0 tnaup2 = 0.0E+0 tnaitr = 0.0E+0 tneigh = 0.0E+0 tngets = 0.0E+0 tnapps = 0.0E+0 tnconv = 0.0E+0 titref = 0.0E+0 tgetv0 = 0.0E+0 trvec = 0.0E+0 c c %----------------------------------------------------% c | User time including reverse communication overhead | c %----------------------------------------------------% c tmvopx = 0.0E+0 tmvbx = 0.0E+0 c return c c c %---------------% c | End of sstatn | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dsortr.f000644 001750 001750 00000012354 11266605602 022136 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dsortr c c\Description: c Sort the array X1 in the order specified by WHICH and optionally c applies the permutation to the array X2. c c\Usage: c call dsortr c ( WHICH, APPLY, N, X1, X2 ) c c\Arguments c WHICH Character*2. (Input) c 'LM' -> X1 is sorted into increasing order of magnitude. c 'SM' -> X1 is sorted into decreasing order of magnitude. c 'LA' -> X1 is sorted into increasing order of algebraic. c 'SA' -> X1 is sorted into decreasing order of algebraic. c c APPLY Logical. (Input) c APPLY = .TRUE. -> apply the sorted order to X2. c APPLY = .FALSE. -> do not apply the sorted order to X2. c c N Integer. (INPUT) c Size of the arrays. c c X1 Double precision array of length N. (INPUT/OUTPUT) c The array to be sorted. c c X2 Double precision array of length N. (INPUT/OUTPUT) c Only referenced if APPLY = .TRUE. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/16/93: Version ' 2.1'. c Adapted from the sort routine in LANSO. c c\SCCS Information: @(#) c FILE: sortr.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine dsortr (which, apply, n, x1, x2) c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which logical apply integer n c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & x1(0:n-1), x2(0:n-1) c c %---------------% c | Local Scalars | c %---------------% c integer i, igap, j Double precision & temp c c %-----------------------% c | Executable Statements | c %-----------------------% c igap = n / 2 c if (which .eq. 'SA') then c c X1 is sorted into decreasing order of algebraic. c 10 continue if (igap .eq. 0) go to 9000 do 30 i = igap, n-1 j = i-igap 20 continue c if (j.lt.0) go to 30 c if (x1(j).lt.x1(j+igap)) then temp = x1(j) x1(j) = x1(j+igap) x1(j+igap) = temp if (apply) then temp = x2(j) x2(j) = x2(j+igap) x2(j+igap) = temp end if else go to 30 endif j = j-igap go to 20 30 continue igap = igap / 2 go to 10 c else if (which .eq. 'SM') then c c X1 is sorted into decreasing order of magnitude. c 40 continue if (igap .eq. 0) go to 9000 do 60 i = igap, n-1 j = i-igap 50 continue c if (j.lt.0) go to 60 c if (abs(x1(j)).lt.abs(x1(j+igap))) then temp = x1(j) x1(j) = x1(j+igap) x1(j+igap) = temp if (apply) then temp = x2(j) x2(j) = x2(j+igap) x2(j+igap) = temp end if else go to 60 endif j = j-igap go to 50 60 continue igap = igap / 2 go to 40 c else if (which .eq. 'LA') then c c X1 is sorted into increasing order of algebraic. c 70 continue if (igap .eq. 0) go to 9000 do 90 i = igap, n-1 j = i-igap 80 continue c if (j.lt.0) go to 90 c if (x1(j).gt.x1(j+igap)) then temp = x1(j) x1(j) = x1(j+igap) x1(j+igap) = temp if (apply) then temp = x2(j) x2(j) = x2(j+igap) x2(j+igap) = temp end if else go to 90 endif j = j-igap go to 80 90 continue igap = igap / 2 go to 70 c else if (which .eq. 'LM') then c c X1 is sorted into increasing order of magnitude. c 100 continue if (igap .eq. 0) go to 9000 do 120 i = igap, n-1 j = i-igap 110 continue c if (j.lt.0) go to 120 c if (abs(x1(j)).gt.abs(x1(j+igap))) then temp = x1(j) x1(j) = x1(j+igap) x1(j+igap) = temp if (apply) then temp = x2(j) x2(j) = x2(j+igap) x2(j+igap) = temp end if else go to 120 endif j = j-igap go to 110 120 continue igap = igap / 2 go to 100 end if c 9000 continue return c c %---------------% c | End of dsortr | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/svout.f000644 001750 001750 00000007144 11266605602 022002 0ustar00geuzainegeuzaine000000 000000 *----------------------------------------------------------------------- * Routine: SVOUT * * Purpose: Real vector output routine. * * Usage: CALL SVOUT (LOUT, N, SX, IDIGIT, IFMT) * * Arguments * N - Length of array SX. (Input) * SX - Real array to be printed. (Input) * IFMT - Format to be used in printing array SX. (Input) * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) * If IDIGIT .LT. 0, printing is done with 72 columns. * If IDIGIT .GT. 0, printing is done with 132 columns. * *----------------------------------------------------------------------- * SUBROUTINE SVOUT( LOUT, N, SX, IDIGIT, IFMT ) * ... * ... SPECIFICATIONS FOR ARGUMENTS INTEGER N, IDIGIT, LOUT REAL SX( * ) CHARACTER IFMT*( * ) * ... * ... SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I, NDIGIT, K1, K2, LLL CHARACTER*80 LINE * ... * ... FIRST EXECUTABLE STATEMENT * * LLL = MIN( LEN( IFMT ), 80 ) DO 10 I = 1, LLL LINE( I: I ) = '-' 10 CONTINUE * DO 20 I = LLL + 1, 80 LINE( I: I ) = ' ' 20 CONTINUE * WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) 9999 FORMAT( / 1X, A / 1X, A ) * IF( N.LE.0 ) $ RETURN NDIGIT = IDIGIT IF( IDIGIT.EQ.0 ) $ NDIGIT = 4 * *======================================================================= * CODE FOR OUTPUT USING 72 COLUMNS FORMAT *======================================================================= * IF( IDIGIT.LT.0 ) THEN NDIGIT = -IDIGIT IF( NDIGIT.LE.4 ) THEN DO 30 K1 = 1, N, 5 K2 = MIN0( N, K1+4 ) WRITE( LOUT, 9998 )K1, K2, ( SX( I ), I = K1, K2 ) 30 CONTINUE ELSE IF( NDIGIT.LE.6 ) THEN DO 40 K1 = 1, N, 4 K2 = MIN0( N, K1+3 ) WRITE( LOUT, 9997 )K1, K2, ( SX( I ), I = K1, K2 ) 40 CONTINUE ELSE IF( NDIGIT.LE.10 ) THEN DO 50 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) WRITE( LOUT, 9996 )K1, K2, ( SX( I ), I = K1, K2 ) 50 CONTINUE ELSE DO 60 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9995 )K1, K2, ( SX( I ), I = K1, K2 ) 60 CONTINUE END IF * *======================================================================= * CODE FOR OUTPUT USING 132 COLUMNS FORMAT *======================================================================= * ELSE IF( NDIGIT.LE.4 ) THEN DO 70 K1 = 1, N, 10 K2 = MIN0( N, K1+9 ) WRITE( LOUT, 9998 )K1, K2, ( SX( I ), I = K1, K2 ) 70 CONTINUE ELSE IF( NDIGIT.LE.6 ) THEN DO 80 K1 = 1, N, 8 K2 = MIN0( N, K1+7 ) WRITE( LOUT, 9997 )K1, K2, ( SX( I ), I = K1, K2 ) 80 CONTINUE ELSE IF( NDIGIT.LE.10 ) THEN DO 90 K1 = 1, N, 6 K2 = MIN0( N, K1+5 ) WRITE( LOUT, 9996 )K1, K2, ( SX( I ), I = K1, K2 ) 90 CONTINUE ELSE DO 100 K1 = 1, N, 5 K2 = MIN0( N, K1+4 ) WRITE( LOUT, 9995 )K1, K2, ( SX( I ), I = K1, K2 ) 100 CONTINUE END IF END IF WRITE( LOUT, 9994 ) RETURN 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1P10E12.3 ) 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P8E14.5 ) 9996 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P6E18.9 ) 9995 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P5E24.13 ) 9994 FORMAT( 1X, ' ' ) END getdp-2.4.2-source/contrib/Arpack/cnaitr.f000644 001750 001750 00000074467 11266605602 022116 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: cnaitr c c\Description: c Reverse communication interface for applying NP additional steps to c a K step nonsymmetric Arnoldi factorization. c c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T c c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. c c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T c c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. c c where OP and B are as in cnaupd. The B-norm of r_{k+p} is also c computed and returned. c c\Usage: c call cnaitr c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, c IPNTR, WORKD, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c This is for the restart phase to force the new c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y, c IPNTR(3) is the pointer into WORK for B * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c IDO = 99: done c ------------------------------------------------------------- c When the routine is used in the "shift-and-invert" mode, the c vector B * Q is already available and do not need to be c recomputed in forming OP * Q. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. See cnaupd. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c K Integer. (INPUT) c Current size of V and H. c c NP Integer. (INPUT) c Number of additional Arnoldi steps to take. c c NB Integer. (INPUT) c Blocksize to be used in the recurrence. c Only work for NB = 1 right now. The goal is to have a c program that implement both the block and non-block method. c c RESID Complex array of length N. (INPUT/OUTPUT) c On INPUT: RESID contains the residual vector r_{k}. c On OUTPUT: RESID contains the residual vector r_{k+p}. c c RNORM Real scalar. (INPUT/OUTPUT) c B-norm of the starting residual on input. c B-norm of the updated residual r_{k+p} on output. c c V Complex N by K+NP array. (INPUT/OUTPUT) c On INPUT: V contains the Arnoldi vectors in the first K c columns. c On OUTPUT: V contains the new NP Arnoldi vectors in the next c NP columns. The first K columns are unchanged. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Complex (K+NP) by (K+NP) array. (INPUT/OUTPUT) c H is used to store the generated upper Hessenberg matrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORK for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Complex work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The calling program should not c use WORKD as temporary workspace during the iteration !!!!!! c On input, WORKD(1:N) = B*RESID and is used to save some c computation at the first step. c c INFO Integer. (OUTPUT) c = 0: Normal exit. c > 0: Size of the spanning invariant subspace of OP found. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c cgetv0 ARPACK routine to generate the initial vector. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c cmout ARPACK utility routine that prints matrices c cvout ARPACK utility routine that prints vectors. c clanhs LAPACK routine that computes various norms of a matrix. c clascl LAPACK routine for careful scaling of a matrix. c slabad LAPACK routine for defining the underflow and overflow c limits. c slamch LAPACK routine that determines machine constants. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c cgemv Level 2 BLAS routine for matrix vector multiplication. c caxpy Level 1 BLAS that computes a vector triad. c ccopy Level 1 BLAS that copies one vector to another . c cdotc Level 1 BLAS that computes the scalar product of two vectors. c cscal Level 1 BLAS that scales a vector. c csscal Level 1 BLAS that scales a complex vector by a real number. c scnrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: naitr.F SID: 2.3 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c The algorithm implemented is: c c restart = .false. c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; c r_{k} contains the initial residual vector even for k = 0; c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already c computed by the calling program. c c betaj = rnorm ; p_{k+1} = B*r_{k} ; c For j = k+1, ..., k+np Do c 1) if ( betaj < tol ) stop or restart depending on j. c ( At present tol is zero ) c if ( restart ) generate a new starting vector. c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; c p_{j} = p_{j}/betaj c 3) r_{j} = OP*v_{j} where OP is defined as in cnaupd c For shift-invert mode p_{j} = B*v_{j} is already available. c wnorm = || OP*v_{j} || c 4) Compute the j-th step residual vector. c w_{j} = V_{j}^T * B * OP * v_{j} c r_{j} = OP*v_{j} - V_{j} * w_{j} c H(:,j) = w_{j}; c H(j,j-1) = rnorm c rnorm = || r_(j) || c If (rnorm > 0.717*wnorm) accept step and go back to 1) c 5) Re-orthogonalization step: c s = V_{j}'*B*r_{j} c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || c alphaj = alphaj + s_{j}; c 6) Iterative refinement step: c If (rnorm1 > 0.717*rnorm) then c rnorm = rnorm1 c accept step and go back to 1) c Else c rnorm = rnorm1 c If this is the first time in step 6), go to 5) c Else r_{j} lies in the span of V_{j} numerically. c Set r_{j} = 0 and rnorm = 0; go to 1) c EndIf c End Do c c\EndLib c c----------------------------------------------------------------------- c subroutine cnaitr & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, & ipntr, workd, info) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 integer ido, info, k, ldh, ldv, n, nb, np Real & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Complex & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) c c %------------% c | Parameters | c %------------% c Complex & one, zero Real & rone, rzero parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0), & rone = 1.0E+0, rzero = 0.0E+0) c c %--------------% c | Local Arrays | c %--------------% c Real & rtemp(2) c c %---------------% c | Local Scalars | c %---------------% c logical first, orth1, orth2, rstart, step3, step4 integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, & jj Real & ovfl, smlnum, tst1, ulp, unfl, betaj, & temp1, rnorm1, wnorm Complex & cnorm c save first, orth1, orth2, rstart, step3, step4, & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, & betaj, rnorm1, smlnum, ulp, unfl, wnorm c c %----------------------% c | External Subroutines | c %----------------------% c external caxpy, ccopy, cscal, csscal, cgemv, cgetv0, & slabad, cvout, cmout, ivout, second c c %--------------------% c | External Functions | c %--------------------% c Complex & cdotc Real & slamch, scnrm2, clanhs, slapy2 external cdotc, scnrm2, clanhs, slamch, slapy2 c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic aimag, real, max, sqrt c c %-----------------% c | Data statements | c %-----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then c c %-----------------------------------------% c | Set machine-dependent constants for the | c | the splitting and deflation criterion. | c | If norm(H) <= sqrt(OVFL), | c | overflow should not occur. | c | REFERENCE: LAPACK subroutine clahqr | c %-----------------------------------------% c unfl = slamch( 'safe minimum' ) ovfl = real(one / unfl) call slabad( unfl, ovfl ) ulp = slamch( 'precision' ) smlnum = unfl*( n / ulp ) first = .false. end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mcaitr c c %------------------------------% c | Initial call to this routine | c %------------------------------% c info = 0 step3 = .false. step4 = .false. rstart = .false. orth1 = .false. orth2 = .false. j = k + 1 ipj = 1 irj = ipj + n ivj = irj + n end if c c %-------------------------------------------------% c | When in reverse communication mode one of: | c | STEP3, STEP4, ORTH1, ORTH2, RSTART | c | will be .true. when .... | c | STEP3: return from computing OP*v_{j}. | c | STEP4: return from computing B-norm of OP*v_{j} | c | ORTH1: return from computing B-norm of r_{j+1} | c | ORTH2: return from computing B-norm of | c | correction to the residual vector. | c | RSTART: return from OP computations needed by | c | cgetv0. | c %-------------------------------------------------% c if (step3) go to 50 if (step4) go to 60 if (orth1) go to 70 if (orth2) go to 90 if (rstart) go to 30 c c %-----------------------------% c | Else this is the first step | c %-----------------------------% c c %--------------------------------------------------------------% c | | c | A R N O L D I I T E R A T I O N L O O P | c | | c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | c %--------------------------------------------------------------% 1000 continue c if (msglvl .gt. 1) then call ivout (logfil, 1, j, ndigit, & '_naitr: generating Arnoldi vector number') call svout (logfil, 1, rnorm, ndigit, & '_naitr: B-norm of the current residual is') end if c c %---------------------------------------------------% c | STEP 1: Check if the B norm of j-th residual | c | vector is zero. Equivalent to determine whether | c | an exact j-step Arnoldi factorization is present. | c %---------------------------------------------------% c betaj = rnorm if (rnorm .gt. rzero) go to 40 c c %---------------------------------------------------% c | Invariant subspace found, generate a new starting | c | vector which is orthogonal to the current Arnoldi | c | basis and continue the iteration. | c %---------------------------------------------------% c if (msglvl .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_naitr: ****** RESTART AT STEP ******') end if c c %---------------------------------------------% c | ITRY is the loop variable that controls the | c | maximum amount of times that a restart is | c | attempted. NRSTRT is used by stat.h | c %---------------------------------------------% c betaj = rzero nrstrt = nrstrt + 1 itry = 1 20 continue rstart = .true. ido = 0 30 continue c c %--------------------------------------% c | If in reverse communication mode and | c | RSTART = .true. flow returns here. | c %--------------------------------------% c call cgetv0 (ido, bmat, itry, .false., n, j, v, ldv, & resid, rnorm, ipntr, workd, ierr) if (ido .ne. 99) go to 9000 if (ierr .lt. 0) then itry = itry + 1 if (itry .le. 3) go to 20 c c %------------------------------------------------% c | Give up after several restart attempts. | c | Set INFO to the size of the invariant subspace | c | which spans OP and exit. | c %------------------------------------------------% c info = j - 1 call second (t1) tcaitr = tcaitr + (t1 - t0) ido = 99 go to 9000 end if c 40 continue c c %---------------------------------------------------------% c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | c | when reciprocating a small RNORM, test against lower | c | machine bound. | c %---------------------------------------------------------% c call ccopy (n, resid, 1, v(1,j), 1) if ( rnorm .ge. unfl) then temp1 = rone / rnorm call csscal (n, temp1, v(1,j), 1) call csscal (n, temp1, workd(ipj), 1) else c c %-----------------------------------------% c | To scale both v_{j} and p_{j} carefully | c | use LAPACK routine clascl | c %-----------------------------------------% c call clascl ('General', i, i, rnorm, rone, & n, 1, v(1,j), n, infol) call clascl ('General', i, i, rnorm, rone, & n, 1, workd(ipj), n, infol) end if c c %------------------------------------------------------% c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | c | Note that this is not quite yet r_{j}. See STEP 4 | c %------------------------------------------------------% c step3 = .true. nopx = nopx + 1 call second (t2) call ccopy (n, v(1,j), 1, workd(ivj), 1) ipntr(1) = ivj ipntr(2) = irj ipntr(3) = ipj ido = 1 c c %-----------------------------------% c | Exit in order to compute OP*v_{j} | c %-----------------------------------% c go to 9000 50 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | c | if step3 = .true. | c %----------------------------------% c call second (t3) tmvopx = tmvopx + (t3 - t2) step3 = .false. c c %------------------------------------------% c | Put another copy of OP*v_{j} into RESID. | c %------------------------------------------% c call ccopy (n, workd(irj), 1, resid, 1) c c %---------------------------------------% c | STEP 4: Finish extending the Arnoldi | c | factorization to length j. | c %---------------------------------------% c call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 step4 = .true. ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-------------------------------------% c | Exit in order to compute B*OP*v_{j} | c %-------------------------------------% c go to 9000 else if (bmat .eq. 'I') then call ccopy (n, resid, 1, workd(ipj), 1) end if 60 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | c | if step4 = .true. | c %----------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c step4 = .false. c c %-------------------------------------% c | The following is needed for STEP 5. | c | Compute the B-norm of OP*v_{j}. | c %-------------------------------------% c if (bmat .eq. 'G') then cnorm = cdotc (n, resid, 1, workd(ipj), 1) wnorm = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then wnorm = scnrm2(n, resid, 1) end if c c %-----------------------------------------% c | Compute the j-th residual corresponding | c | to the j step factorization. | c | Use Classical Gram Schmidt and compute: | c | w_{j} <- V_{j}^T * B * OP * v_{j} | c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | c %-----------------------------------------% c c c %------------------------------------------% c | Compute the j Fourier coefficients w_{j} | c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | c %------------------------------------------% c call cgemv ('C', n, j, one, v, ldv, workd(ipj), 1, & zero, h(1,j), 1) c c %--------------------------------------% c | Orthogonalize r_{j} against V_{j}. | c | RESID contains OP*v_{j}. See STEP 3. | c %--------------------------------------% c call cgemv ('N', n, j, -one, v, ldv, h(1,j), 1, & one, resid, 1) c if (j .gt. 1) h(j,j-1) = cmplx(betaj, rzero) c call second (t4) c orth1 = .true. c call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call ccopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %----------------------------------% c | Exit in order to compute B*r_{j} | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call ccopy (n, resid, 1, workd(ipj), 1) end if 70 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH1 = .true. | c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c orth1 = .false. c c %------------------------------% c | Compute the B-norm of r_{j}. | c %------------------------------% c if (bmat .eq. 'G') then cnorm = cdotc (n, resid, 1, workd(ipj), 1) rnorm = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then rnorm = scnrm2(n, resid, 1) end if c c %-----------------------------------------------------------% c | STEP 5: Re-orthogonalization / Iterative refinement phase | c | Maximum NITER_ITREF tries. | c | | c | s = V_{j}^T * B * r_{j} | c | r_{j} = r_{j} - V_{j}*s | c | alphaj = alphaj + s_{j} | c | | c | The stopping criteria used for iterative refinement is | c | discussed in Parlett's book SEP, page 107 and in Gragg & | c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | c | Determine if we need to correct the residual. The goal is | c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | c | The following test determines whether the sine of the | c | angle between OP*x and the computed residual is less | c | than or equal to 0.717. | c %-----------------------------------------------------------% c if ( rnorm .gt. 0.717*wnorm ) go to 100 c iter = 0 nrorth = nrorth + 1 c c %---------------------------------------------------% c | Enter the Iterative refinement phase. If further | c | refinement is necessary, loop back here. The loop | c | variable is ITER. Perform a step of Classical | c | Gram-Schmidt using all the Arnoldi vectors V_{j} | c %---------------------------------------------------% c 80 continue c if (msglvl .gt. 2) then rtemp(1) = wnorm rtemp(2) = rnorm call svout (logfil, 2, rtemp, ndigit, & '_naitr: re-orthogonalization; wnorm and rnorm are') call cvout (logfil, j, h(1,j), ndigit, & '_naitr: j-th column of H') end if c c %----------------------------------------------------% c | Compute V_{j}^T * B * r_{j}. | c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | c %----------------------------------------------------% c call cgemv ('C', n, j, one, v, ldv, workd(ipj), 1, & zero, workd(irj), 1) c c %---------------------------------------------% c | Compute the correction to the residual: | c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | c | The correction to H is v(:,1:J)*H(1:J,1:J) | c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | c %---------------------------------------------% c call cgemv ('N', n, j, -one, v, ldv, workd(irj), 1, & one, resid, 1) call caxpy (j, one, workd(irj), 1, h(1,j), 1) c orth2 = .true. call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call ccopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-----------------------------------% c | Exit in order to compute B*r_{j}. | c | r_{j} is the corrected residual. | c %-----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call ccopy (n, resid, 1, workd(ipj), 1) end if 90 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH2 = .true. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c c %-----------------------------------------------------% c | Compute the B-norm of the corrected residual r_{j}. | c %-----------------------------------------------------% c if (bmat .eq. 'G') then cnorm = cdotc (n, resid, 1, workd(ipj), 1) rnorm1 = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then rnorm1 = scnrm2(n, resid, 1) end if c if (msglvl .gt. 0 .and. iter .gt. 0 ) then call ivout (logfil, 1, j, ndigit, & '_naitr: Iterative refinement for Arnoldi residual') if (msglvl .gt. 2) then rtemp(1) = rnorm rtemp(2) = rnorm1 call svout (logfil, 2, rtemp, ndigit, & '_naitr: iterative refinement ; rnorm and rnorm1 are') end if end if c c %-----------------------------------------% c | Determine if we need to perform another | c | step of re-orthogonalization. | c %-----------------------------------------% c if ( rnorm1 .gt. 0.717*rnorm ) then c c %---------------------------------------% c | No need for further refinement. | c | The cosine of the angle between the | c | corrected residual vector and the old | c | residual vector is greater than 0.717 | c | In other words the corrected residual | c | and the old residual vector share an | c | angle of less than arcCOS(0.717) | c %---------------------------------------% c rnorm = rnorm1 c else c c %-------------------------------------------% c | Another step of iterative refinement step | c | is required. NITREF is used by stat.h | c %-------------------------------------------% c nitref = nitref + 1 rnorm = rnorm1 iter = iter + 1 if (iter .le. 1) go to 80 c c %-------------------------------------------------% c | Otherwise RESID is numerically in the span of V | c %-------------------------------------------------% c do 95 jj = 1, n resid(jj) = zero 95 continue rnorm = rzero end if c c %----------------------------------------------% c | Branch here directly if iterative refinement | c | wasn't necessary or after at most NITER_REF | c | steps of iterative refinement. | c %----------------------------------------------% c 100 continue c rstart = .false. orth2 = .false. c call second (t5) titref = titref + (t5 - t4) c c %------------------------------------% c | STEP 6: Update j = j+1; Continue | c %------------------------------------% c j = j + 1 if (j .gt. k+np) then call second (t1) tcaitr = tcaitr + (t1 - t0) ido = 99 do 110 i = max(1,k), k+np-1 c c %--------------------------------------------% c | Check for splitting and deflation. | c | Use a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine clahqr | c %--------------------------------------------% c tst1 = slapy2(real(h(i,i)),aimag(h(i,i))) & + slapy2(real(h(i+1,i+1)), aimag(h(i+1,i+1))) if( tst1.eq.real(zero) ) & tst1 = clanhs( '1', k+np, h, ldh, workd(n+1) ) if( slapy2(real(h(i+1,i)),aimag(h(i+1,i))) .le. & max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 110 continue c if (msglvl .gt. 2) then call cmout (logfil, k+np, k+np, h, ldh, ndigit, & '_naitr: Final upper Hessenberg matrix H of order K+NP') end if c go to 9000 end if c c %--------------------------------------------------------% c | Loop back to extend the factorization by another step. | c %--------------------------------------------------------% c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 9000 continue return c c %---------------% c | End of cnaitr | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/sseupd.f000644 001750 001750 00000102654 11266605602 022127 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: sseupd c c\Description: c c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) the corresponding approximate eigenvectors, c c (2) an orthonormal (Lanczos) basis for the associated approximate c invariant subspace, c c (3) Both. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c (Lanczos) basis is always computed. There is an additional storage cost c of n*nev if both are requested (in this case a separate array Z must be c supplied). c c These quantities are obtained from the Lanczos factorization computed c by SSAUPD for the linear operator OP prescribed by the MODE selection c (see IPARAM(7) in SSAUPD documentation.) SSAUPD must be called before c this routine is called. These approximate eigenvalues and vectors are c commonly called Ritz values and Ritz vectors respectively. They are c referred to as such in the comments that follow. The computed orthonormal c basis for the invariant subspace corresponding to these Ritz values is c referred to as a Lanczos basis. c c See documentation in the header of the subroutine SSAUPD for a definition c of OP as well as other terms and the relation of computed Ritz values c and vectors of OP with respect to the given problem A*z = lambda*B*z. c c The approximate eigenvalues of the original problem are returned in c ascending algebraic order. The user may elect to call this routine c once for each desired Ritz vector and store it peripherally if desired. c There is also the option of computing a selected set of these vectors c with a single call. c c\Usage: c call sseupd c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, BMAT, N, WHICH, NEV, TOL, c RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, LWORKL, INFO ) c c RVEC LOGICAL (INPUT) c Specifies whether Ritz vectors corresponding to the Ritz value c approximations to the eigenproblem A*z = lambda*B*z are computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute Ritz vectors. c c HOWMNY Character*1 (INPUT) c Specifies how many Ritz vectors are wanted and the form of Z c the matrix of Ritz vectors. See remark 1 below. c = 'A': compute NEV Ritz vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT/WORKSPACE) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the Ritz vector corresponding to a c Ritz value D(j), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' , SELECT is used as a workspace for c reordering the Ritz values. c c D Real array of dimension NEV. (OUTPUT) c On exit, D contains the Ritz value approximations to the c eigenvalues of A*z = lambda*B*z. The values are returned c in ascending order. If IPARAM(7) = 3,4,5 then D represents c the Ritz values of OP computed by ssaupd transformed to c those of the original eigensystem A*z = lambda*B*z. If c IPARAM(7) = 1,2 then the Ritz values of OP are the same c as the those of A*z = lambda*B*z. c c Z Real N by NEV array if HOWMNY = 'A'. (OUTPUT) c On exit, Z contains the B-orthonormal Ritz vectors of the c eigensystem A*z = lambda*B*z corresponding to the Ritz c value approximations. c If RVEC = .FALSE. then Z is not referenced. c NOTE: The array Z may be set equal to first NEV columns of the c Arnoldi/Lanczos basis array V computed by SSAUPD. c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ .ge. max( 1, N ). In any case, LDZ .ge. 1. c c SIGMA Real (INPUT) c If IPARAM(7) = 3,4,5 represents the shift. Not referenced if c IPARAM(7) = 1 or 2. c c c **** The remaining arguments MUST be the same as for the **** c **** call to SSAUPD that was just completed. **** c c NOTE: The remaining arguments c c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, c WORKD, WORKL, LWORKL, INFO c c must be passed directly to SSEUPD following the last call c to SSAUPD. These arguments MUST NOT BE MODIFIED between c the the last call to SSAUPD and the call to SSEUPD. c c Two of these parameters (WORKL, INFO) are also output parameters: c c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) c WORKL(1:4*ncv) contains information obtained in c ssaupd. They are not changed by sseupd. c WORKL(4*ncv+1:ncv*ncv+8*ncv) holds the c untransformed Ritz values, the computed error estimates, c and the associated eigenvector matrix of H. c c Note: IPNTR(8:10) contains the pointer into WORKL for addresses c of the above information computed by sseupd. c ------------------------------------------------------------- c IPNTR(8): pointer to the NCV RITZ values of the original system. c IPNTR(9): pointer to the NCV corresponding error bounds. c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors c of the tridiagonal matrix T. Only referenced by c sseupd if RVEC = .TRUE. See Remarks. c ------------------------------------------------------------- c c INFO Integer. (OUTPUT) c Error flag on output. c = 0: Normal exit. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV must be greater than NEV and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from trid. eigenvalue calculation; c Information error from LAPACK routine ssteqr. c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3,4,5. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: NEV and WHICH = 'BE' are incompatible. c = -14: SSAUPD did not find any eigenvalues to sufficient c accuracy. c = -15: HOWMNY must be one of 'A' or 'S' if RVEC = .true. c = -16: HOWMNY = 'S' not yet implemented c = -17: SSEUPD got a different count of the number of converged c Ritz values than SSAUPD got. This indicates the user c probably made an error in passing data from SSAUPD to c SSEUPD or that the data was modified before entering c SSEUPD. c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, c 1980. c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", c Computer Physics Communications, 53 (1989), pp 169-179. c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to c Implement the Spectral Transformation", Math. Comp., 48 (1987), c pp 663-673. c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", c SIAM J. Matr. Anal. Apps., January (1993). c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines c for Updating the QR decomposition", ACM TOMS, December 1990, c Volume 16 Number 4, pp 369-377. c c\Remarks c 1. The converged Ritz values are always returned in increasing c (algebraic) order. c c 2. Currently only HOWMNY = 'A' is implemented. It is included at this c stage for the user who wants to incorporate it. c c\Routines called: c ssesrt ARPACK routine that sorts an array X, and applies the c corresponding permutation to a matrix A. c ssortr ssortr ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c svout ARPACK utility routine that prints vectors. c sgeqr2 LAPACK routine that computes the QR factorization of c a matrix. c slacpy LAPACK matrix copy routine. c slamch LAPACK routine that determines machine constants. c sorm2r LAPACK routine that applies an orthogonal matrix in c factored form. c ssteqr LAPACK routine that computes eigenvalues and eigenvectors c of a tridiagonal matrix. c sger Level 2 BLAS rank one update to a matrix. c scopy Level 1 BLAS that copies one vector to another . c snrm2 Level 1 BLAS that computes the norm of a vector. c sscal Level 1 BLAS that scales a vector. c sswap Level 1 BLAS that swaps the contents of two vectors. c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Chao Yang Houston, Texas c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/15/93: Version ' 2.1' c c\SCCS Information: @(#) c FILE: seupd.F SID: 2.11 DATE OF SID: 04/10/01 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- subroutine sseupd(rvec , howmny, select, d , & z , ldz , sigma , bmat , & n , which , nev , tol , & resid , ncv , v , ldv , & iparam, ipntr , workd , workl, & lworkl, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat, howmny, which*2 logical rvec integer info, ldz, ldv, lworkl, n, ncv, nev Real & sigma, tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(7), ipntr(11) logical select(ncv) Real & d(nev) , resid(n) , v(ldv,ncv), & z(ldz, nev), workd(2*n), workl(lworkl) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0 , zero = 0.0E+0 ) c c %---------------% c | Local Scalars | c %---------------% c character type*6 integer bounds , ierr , ih , ihb , ihd , & iq , iw , j , k , ldh , & ldq , mode , msglvl, nconv , next , & ritz , irz , ibd , np , ishift, & leftptr, rghtptr, numcnv, jj Real & bnorm2 , rnorm, temp, temp1, eps23 logical reord c c %----------------------% c | External Subroutines | c %----------------------% c external scopy , sger , sgeqr2, slacpy, sorm2r, sscal, & ssesrt, ssteqr, sswap , svout , ivout , ssortr c c %--------------------% c | External Functions | c %--------------------% c Real & snrm2, slamch external snrm2, slamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic min c c %-----------------------% c | Executable Statements | c %-----------------------% c c %------------------------% c | Set default parameters | c %------------------------% c msglvl = mseupd mode = iparam(7) nconv = iparam(5) info = 0 c c %--------------% c | Quick return | c %--------------% c if (nconv .eq. 0) go to 9000 ierr = 0 c if (nconv .le. 0) ierr = -14 if (n .le. 0) ierr = -1 if (nev .le. 0) ierr = -2 if (ncv .le. nev .or. ncv .gt. n) ierr = -3 if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LA' .and. & which .ne. 'SA' .and. & which .ne. 'BE') ierr = -5 if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 if ( (howmny .ne. 'A' .and. & howmny .ne. 'P' .and. & howmny .ne. 'S') .and. rvec ) & ierr = -15 if (rvec .and. howmny .eq. 'S') ierr = -16 c if (rvec .and. lworkl .lt. ncv**2+8*ncv) ierr = -7 c if (mode .eq. 1 .or. mode .eq. 2) then type = 'REGULR' else if (mode .eq. 3 ) then type = 'SHIFTI' else if (mode .eq. 4 ) then type = 'BUCKLE' else if (mode .eq. 5 ) then type = 'CAYLEY' else ierr = -10 end if if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 if (nev .eq. 1 .and. which .eq. 'BE') ierr = -12 c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr go to 9000 end if c c %-------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:2*ncv) := generated tridiagonal matrix H | c | The subdiagonal is stored in workl(2:ncv). | c | The dead spot is workl(1) but upon exiting | c | ssaupd stores the B-norm of the last residual | c | vector in workl(1). We use this !!! | c | workl(2*ncv+1:2*ncv+ncv) := ritz values | c | The wanted values are in the first NCONV spots. | c | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates | c | The wanted values are in the first NCONV spots. | c | NOTE: workl(1:4*ncv) is set by ssaupd and is not | c | modified by sseupd. | c %-------------------------------------------------------% c c %-------------------------------------------------------% c | The following is used and set by sseupd. | c | workl(4*ncv+1:4*ncv+ncv) := used as workspace during | c | computation of the eigenvectors of H. Stores | c | the diagonal of H. Upon EXIT contains the NCV | c | Ritz values of the original system. The first | c | NCONV spots have the wanted values. If MODE = | c | 1 or 2 then will equal workl(2*ncv+1:3*ncv). | c | workl(5*ncv+1:5*ncv+ncv) := used as workspace during | c | computation of the eigenvectors of H. Stores | c | the subdiagonal of H. Upon EXIT contains the | c | NCV corresponding Ritz estimates of the | c | original system. The first NCONV spots have the | c | wanted values. If MODE = 1,2 then will equal | c | workl(3*ncv+1:4*ncv). | c | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is | c | the eigenvector matrix for H as returned by | c | ssteqr. Not referenced if RVEC = .False. | c | Ordering follows that of workl(4*ncv+1:5*ncv) | c | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := | c | Workspace. Needed by ssteqr and by sseupd. | c | GRAND total of NCV*(NCV+8) locations. | c %-------------------------------------------------------% c c ih = ipntr(5) ritz = ipntr(6) bounds = ipntr(7) ldh = ncv ldq = ncv ihd = bounds + ldh ihb = ihd + ldh iq = ihb + ldh iw = iq + ldh*ncv next = iw + 2*ncv ipntr(4) = next ipntr(8) = ihd ipntr(9) = ihb ipntr(10) = iq c c %----------------------------------------% c | irz points to the Ritz values computed | c | by _seigt before exiting _saup2. | c | ibd points to the Ritz estimates | c | computed by _seigt before exiting | c | _saup2. | c %----------------------------------------% c irz = ipntr(11)+ncv ibd = irz+ncv c c c %---------------------------------% c | Set machine dependent constant. | c %---------------------------------% c eps23 = slamch('Epsilon-Machine') eps23 = eps23**(2.0E+0 / 3.0E+0 ) c c %---------------------------------------% c | RNORM is B-norm of the RESID(1:N). | c | BNORM2 is the 2 norm of B*RESID(1:N). | c | Upon exit of ssaupd WORKD(1:N) has | c | B*RESID(1:N). | c %---------------------------------------% c rnorm = workl(ih) if (bmat .eq. 'I') then bnorm2 = rnorm else if (bmat .eq. 'G') then bnorm2 = snrm2(n, workd, 1) end if c if (msglvl .gt. 2) then call svout(logfil, ncv, workl(irz), ndigit, & '_seupd: Ritz values passed in from _SAUPD.') call svout(logfil, ncv, workl(ibd), ndigit, & '_seupd: Ritz estimates passed in from _SAUPD.') end if c if (rvec) then c reord = .false. c c %---------------------------------------------------% c | Use the temporary bounds array to store indices | c | These will be used to mark the select array later | c %---------------------------------------------------% c do 10 j = 1,ncv workl(bounds+j-1) = j select(j) = .false. 10 continue c c %-------------------------------------% c | Select the wanted Ritz values. | c | Sort the Ritz values so that the | c | wanted ones appear at the tailing | c | NEV positions of workl(irr) and | c | workl(iri). Move the corresponding | c | error estimates in workl(bound) | c | accordingly. | c %-------------------------------------% c np = ncv - nev ishift = 0 call ssgets(ishift, which , nev , & np , workl(irz) , workl(bounds), & workl) c if (msglvl .gt. 2) then call svout(logfil, ncv, workl(irz), ndigit, & '_seupd: Ritz values after calling _SGETS.') call svout(logfil, ncv, workl(bounds), ndigit, & '_seupd: Ritz value indices after calling _SGETS.') end if c c %-----------------------------------------------------% c | Record indices of the converged wanted Ritz values | c | Mark the select array for possible reordering | c %-----------------------------------------------------% c numcnv = 0 do 11 j = 1,ncv temp1 = max(eps23, abs(workl(irz+ncv-j)) ) jj = workl(bounds + ncv - j) if (numcnv .lt. nconv .and. & workl(ibd+jj-1) .le. tol*temp1) then select(jj) = .true. numcnv = numcnv + 1 if (jj .gt. nev) reord = .true. endif 11 continue c c %-----------------------------------------------------------% c | Check the count (numcnv) of converged Ritz values with | c | the number (nconv) reported by _saupd. If these two | c | are different then there has probably been an error | c | caused by incorrect passing of the _saupd data. | c %-----------------------------------------------------------% c if (msglvl .gt. 2) then call ivout(logfil, 1, numcnv, ndigit, & '_seupd: Number of specified eigenvalues') call ivout(logfil, 1, nconv, ndigit, & '_seupd: Number of "converged" eigenvalues') end if c if (numcnv .ne. nconv) then info = -17 go to 9000 end if c c %-----------------------------------------------------------% c | Call LAPACK routine _steqr to compute the eigenvalues and | c | eigenvectors of the final symmetric tridiagonal matrix H. | c | Initialize the eigenvector matrix Q to the identity. | c %-----------------------------------------------------------% c call scopy(ncv-1, workl(ih+1), 1, workl(ihb), 1) call scopy(ncv, workl(ih+ldh), 1, workl(ihd), 1) c call ssteqr('Identity', ncv, workl(ihd), workl(ihb), & workl(iq) , ldq, workl(iw), ierr) c if (ierr .ne. 0) then info = -8 go to 9000 end if c if (msglvl .gt. 1) then call scopy(ncv, workl(iq+ncv-1), ldq, workl(iw), 1) call svout(logfil, ncv, workl(ihd), ndigit, & '_seupd: NCV Ritz values of the final H matrix') call svout(logfil, ncv, workl(iw), ndigit, & '_seupd: last row of the eigenvector matrix for H') end if c if (reord) then c c %---------------------------------------------% c | Reordered the eigenvalues and eigenvectors | c | computed by _steqr so that the "converged" | c | eigenvalues appear in the first NCONV | c | positions of workl(ihd), and the associated | c | eigenvectors appear in the first NCONV | c | columns. | c %---------------------------------------------% c leftptr = 1 rghtptr = ncv c if (ncv .eq. 1) go to 30 c 20 if (select(leftptr)) then c c %-------------------------------------------% c | Search, from the left, for the first Ritz | c | value that has not converged. | c %-------------------------------------------% c leftptr = leftptr + 1 c else if ( .not. select(rghtptr)) then c c %----------------------------------------------% c | Search, from the right, the first Ritz value | c | that has converged. | c %----------------------------------------------% c rghtptr = rghtptr - 1 c else c c %----------------------------------------------% c | Swap the Ritz value on the left that has not | c | converged with the Ritz value on the right | c | that has converged. Swap the associated | c | eigenvector of the tridiagonal matrix H as | c | well. | c %----------------------------------------------% c temp = workl(ihd+leftptr-1) workl(ihd+leftptr-1) = workl(ihd+rghtptr-1) workl(ihd+rghtptr-1) = temp call scopy(ncv, workl(iq+ncv*(leftptr-1)), 1, & workl(iw), 1) call scopy(ncv, workl(iq+ncv*(rghtptr-1)), 1, & workl(iq+ncv*(leftptr-1)), 1) call scopy(ncv, workl(iw), 1, & workl(iq+ncv*(rghtptr-1)), 1) leftptr = leftptr + 1 rghtptr = rghtptr - 1 c end if c if (leftptr .lt. rghtptr) go to 20 c 30 end if c if (msglvl .gt. 2) then call svout (logfil, ncv, workl(ihd), ndigit, & '_seupd: The eigenvalues of H--reordered') end if c c %----------------------------------------% c | Load the converged Ritz values into D. | c %----------------------------------------% c call scopy(nconv, workl(ihd), 1, d, 1) c else c c %-----------------------------------------------------% c | Ritz vectors not required. Load Ritz values into D. | c %-----------------------------------------------------% c call scopy(nconv, workl(ritz), 1, d, 1) call scopy(ncv, workl(ritz), 1, workl(ihd), 1) c end if c c %------------------------------------------------------------------% c | Transform the Ritz values and possibly vectors and corresponding | c | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values | c | (and corresponding data) are returned in ascending order. | c %------------------------------------------------------------------% c if (type .eq. 'REGULR') then c c %---------------------------------------------------------% c | Ascending sort of wanted Ritz values, vectors and error | c | bounds. Not necessary if only Ritz values are desired. | c %---------------------------------------------------------% c if (rvec) then call ssesrt('LA', rvec , nconv, d, ncv, workl(iq), ldq) else call scopy(ncv, workl(bounds), 1, workl(ihb), 1) end if c else c c %-------------------------------------------------------------% c | * Make a copy of all the Ritz values. | c | * Transform the Ritz values back to the original system. | c | For TYPE = 'SHIFTI' the transformation is | c | lambda = 1/theta + sigma | c | For TYPE = 'BUCKLE' the transformation is | c | lambda = sigma * theta / ( theta - 1 ) | c | For TYPE = 'CAYLEY' the transformation is | c | lambda = sigma * (theta + 1) / (theta - 1 ) | c | where the theta are the Ritz values returned by ssaupd. | c | NOTES: | c | *The Ritz vectors are not affected by the transformation. | c | They are only reordered. | c %-------------------------------------------------------------% c call scopy (ncv, workl(ihd), 1, workl(iw), 1) if (type .eq. 'SHIFTI') then do 40 k=1, ncv workl(ihd+k-1) = one / workl(ihd+k-1) + sigma 40 continue else if (type .eq. 'BUCKLE') then do 50 k=1, ncv workl(ihd+k-1) = sigma * workl(ihd+k-1) / & (workl(ihd+k-1) - one) 50 continue else if (type .eq. 'CAYLEY') then do 60 k=1, ncv workl(ihd+k-1) = sigma * (workl(ihd+k-1) + one) / & (workl(ihd+k-1) - one) 60 continue end if c c %-------------------------------------------------------------% c | * Store the wanted NCONV lambda values into D. | c | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) | c | into ascending order and apply sort to the NCONV theta | c | values in the transformed system. We will need this to | c | compute Ritz estimates in the original system. | c | * Finally sort the lambda`s into ascending order and apply | c | to Ritz vectors if wanted. Else just sort lambda`s into | c | ascending order. | c | NOTES: | c | *workl(iw:iw+ncv-1) contain the theta ordered so that they | c | match the ordering of the lambda. We`ll use them again for | c | Ritz vector purification. | c %-------------------------------------------------------------% c call scopy(nconv, workl(ihd), 1, d, 1) call ssortr('LA', .true., nconv, workl(ihd), workl(iw)) if (rvec) then call ssesrt('LA', rvec , nconv, d, ncv, workl(iq), ldq) else call scopy(ncv, workl(bounds), 1, workl(ihb), 1) call sscal(ncv, bnorm2/rnorm, workl(ihb), 1) call ssortr('LA', .true., nconv, d, workl(ihb)) end if c end if c c %------------------------------------------------% c | Compute the Ritz vectors. Transform the wanted | c | eigenvectors of the symmetric tridiagonal H by | c | the Lanczos basis matrix V. | c %------------------------------------------------% c if (rvec .and. howmny .eq. 'A') then c c %----------------------------------------------------------% c | Compute the QR factorization of the matrix representing | c | the wanted invariant subspace located in the first NCONV | c | columns of workl(iq,ldq). | c %----------------------------------------------------------% c call sgeqr2(ncv, nconv , workl(iq) , & ldq, workl(iw+ncv), workl(ihb), & ierr) c c %--------------------------------------------------------% c | * Postmultiply V by Q. | c | * Copy the first NCONV columns of VQ into Z. | c | The N by NCONV matrix Z is now a matrix representation | c | of the approximate invariant subspace associated with | c | the Ritz values in workl(ihd). | c %--------------------------------------------------------% c call sorm2r('Right', 'Notranspose', n , & ncv , nconv , workl(iq), & ldq , workl(iw+ncv), v , & ldv , workd(n+1) , ierr) call slacpy('All', n, nconv, v, ldv, z, ldz) c c %-----------------------------------------------------% c | In order to compute the Ritz estimates for the Ritz | c | values in both systems, need the last row of the | c | eigenvector matrix. Remember, it`s in factored form | c %-----------------------------------------------------% c do 65 j = 1, ncv-1 workl(ihb+j-1) = zero 65 continue workl(ihb+ncv-1) = one call sorm2r('Left', 'Transpose' , ncv , & 1 , nconv , workl(iq) , & ldq , workl(iw+ncv), workl(ihb), & ncv , temp , ierr) c else if (rvec .and. howmny .eq. 'S') then c c Not yet implemented. See remark 2 above. c end if c if (type .eq. 'REGULR' .and. rvec) then c do 70 j=1, ncv workl(ihb+j-1) = rnorm * abs( workl(ihb+j-1) ) 70 continue c else if (type .ne. 'REGULR' .and. rvec) then c c %-------------------------------------------------% c | * Determine Ritz estimates of the theta. | c | If RVEC = .true. then compute Ritz estimates | c | of the theta. | c | If RVEC = .false. then copy Ritz estimates | c | as computed by ssaupd. | c | * Determine Ritz estimates of the lambda. | c %-------------------------------------------------% c call sscal (ncv, bnorm2, workl(ihb), 1) if (type .eq. 'SHIFTI') then c do 80 k=1, ncv workl(ihb+k-1) = abs( workl(ihb+k-1) ) & / workl(iw+k-1)**2 80 continue c else if (type .eq. 'BUCKLE') then c do 90 k=1, ncv workl(ihb+k-1) = sigma * abs( workl(ihb+k-1) ) & / (workl(iw+k-1)-one )**2 90 continue c else if (type .eq. 'CAYLEY') then c do 100 k=1, ncv workl(ihb+k-1) = abs( workl(ihb+k-1) & / workl(iw+k-1)*(workl(iw+k-1)-one) ) 100 continue c end if c end if c if (type .ne. 'REGULR' .and. msglvl .gt. 1) then call svout(logfil, nconv, d, ndigit, & '_seupd: Untransformed converged Ritz values') call svout(logfil, nconv, workl(ihb), ndigit, & '_seupd: Ritz estimates of the untransformed Ritz values') else if (msglvl .gt. 1) then call svout(logfil, nconv, d, ndigit, & '_seupd: Converged Ritz values') call svout(logfil, nconv, workl(ihb), ndigit, & '_seupd: Associated Ritz estimates') end if c c %-------------------------------------------------% c | Ritz vector purification step. Formally perform | c | one of inverse subspace iteration. Only used | c | for MODE = 3,4,5. See reference 7 | c %-------------------------------------------------% c if (rvec .and. (type .eq. 'SHIFTI' .or. type .eq. 'CAYLEY')) then c do 110 k=0, nconv-1 workl(iw+k) = workl(iq+k*ldq+ncv-1) & / workl(iw+k) 110 continue c else if (rvec .and. type .eq. 'BUCKLE') then c do 120 k=0, nconv-1 workl(iw+k) = workl(iq+k*ldq+ncv-1) & / (workl(iw+k)-one) 120 continue c end if c if (type .ne. 'REGULR') & call sger (n, nconv, one, resid, 1, workl(iw), 1, z, ldz) c 9000 continue c return c c %---------------% c | End of sseupd| c %---------------% c end getdp-2.4.2-source/contrib/Arpack/icopy.f000644 001750 001750 00000003635 11266605602 021746 0ustar00geuzainegeuzaine000000 000000 *-------------------------------------------------------------------- *\Documentation * *\Name: ICOPY * *\Description: * ICOPY copies an integer vector lx to an integer vector ly. * *\Usage: * call icopy ( n, lx, inc, ly, incy ) * *\Arguments: * n integer (input) * On entry, n is the number of elements of lx to be c copied to ly. * * lx integer array (input) * On entry, lx is the integer vector to be copied. * * incx integer (input) * On entry, incx is the increment between elements of lx. * * ly integer array (input) * On exit, ly is the integer vector that contains the * copy of lx. * * incy integer (input) * On entry, incy is the increment between elements of ly. * *\Enddoc * *-------------------------------------------------------------------- * subroutine icopy( n, lx, incx, ly, incy ) * * ---------------------------- * Specifications for arguments * ---------------------------- integer incx, incy, n integer lx( 1 ), ly( 1 ) * * ---------------------------------- * Specifications for local variables * ---------------------------------- integer i, ix, iy * * -------------------------- * First executable statement * -------------------------- if( n.le.0 ) $ return if( incx.eq.1 .and. incy.eq.1 ) $ go to 20 c c.....code for unequal increments or equal increments c not equal to 1 ix = 1 iy = 1 if( incx.lt.0 ) $ ix = ( -n+1 )*incx + 1 if( incy.lt.0 ) $ iy = ( -n+1 )*incy + 1 do 10 i = 1, n ly( iy ) = lx( ix ) ix = ix + incx iy = iy + incy 10 continue return c c.....code for both increments equal to 1 c 20 continue do 30 i = 1, n ly( i ) = lx( i ) 30 continue return end getdp-2.4.2-source/contrib/Arpack/zneupd.f000644 001750 001750 00000104544 11266605602 022131 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: zneupd c c\Description: c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) The corresponding approximate eigenvectors; c c (2) An orthonormal basis for the associated approximate c invariant subspace; c c (3) Both. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c basis is always computed. There is an additional storage cost of n*nev c if both are requested (in this case a separate array Z must be supplied). c c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z c are derived from approximate eigenvalues and eigenvectors of c of the linear operator OP prescribed by the MODE selection in the c call to ZNAUPD. ZNAUPD must be called before this routine is called. c These approximate eigenvalues and vectors are commonly called Ritz c values and Ritz vectors respectively. They are referred to as such c in the comments that follow. The computed orthonormal basis for the c invariant subspace corresponding to these Ritz values is referred to as a c Schur basis. c c The definition of OP as well as other terms and the relation of computed c Ritz values and vectors of OP with respect to the given problem c A*z = lambda*B*z may be found in the header of ZNAUPD. For a brief c description, see definitions of IPARAM(7), MODE and WHICH in the c documentation of ZNAUPD. c c\Usage: c call zneupd c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, WORKEV, BMAT, c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, c WORKL, LWORKL, RWORK, INFO ) c c\Arguments: c RVEC LOGICAL (INPUT) c Specifies whether a basis for the invariant subspace corresponding c to the converged Ritz value approximations for the eigenproblem c A*z = lambda*B*z is computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute Ritz vectors or Schur vectors. c See Remarks below. c c HOWMNY Character*1 (INPUT) c Specifies the form of the basis for the invariant subspace c corresponding to the converged Ritz values that is to be computed. c c = 'A': Compute NEV Ritz vectors; c = 'P': Compute NEV Schur vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the Ritz vector corresponding to a c Ritz value D(j), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' or 'P', SELECT need not be initialized c but it is used as internal workspace. c c D Complex*16 array of dimension NEV+1. (OUTPUT) c On exit, D contains the Ritz approximations c to the eigenvalues lambda for A*z = lambda*B*z. c c Z Complex*16 N by NEV array (OUTPUT) c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of c Z represents approximate eigenvectors (Ritz vectors) corresponding c to the NCONV=IPARAM(5) Ritz values for eigensystem c A*z = lambda*B*z. c c If RVEC = .FALSE. or HOWMNY = 'P', then Z is NOT REFERENCED. c c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, c the array Z may be set equal to first NEV+1 columns of the Arnoldi c basis array V computed by ZNAUPD. In this case the Arnoldi basis c will be destroyed and overwritten with the eigenvector basis. c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ .ge. max( 1, N ) is required. c In any case, LDZ .ge. 1 is required. c c SIGMA Complex*16 (INPUT) c If IPARAM(7) = 3 then SIGMA represents the shift. c Not referenced if IPARAM(7) = 1 or 2. c c WORKEV Complex*16 work array of dimension 2*NCV. (WORKSPACE) c c **** The remaining arguments MUST be the same as for the **** c **** call to ZNAUPD that was just completed. **** c c NOTE: The remaining arguments c c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, c WORKD, WORKL, LWORKL, RWORK, INFO c c must be passed directly to ZNEUPD following the last call c to ZNAUPD. These arguments MUST NOT BE MODIFIED between c the the last call to ZNAUPD and the call to ZNEUPD. c c Three of these parameters (V, WORKL and INFO) are also output parameters: c c V Complex*16 N by NCV array. (INPUT/OUTPUT) c c Upon INPUT: the NCV columns of V contain the Arnoldi basis c vectors for OP as constructed by ZNAUPD . c c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns c contain approximate Schur vectors that span the c desired invariant subspace. c c NOTE: If the array Z has been set equal to first NEV+1 columns c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the c Arnoldi basis held by V has been overwritten by the desired c Ritz vectors. If a separate array Z has been passed then c the first NCONV=IPARAM(5) columns of V will contain approximate c Schur vectors that span the desired invariant subspace. c c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) c WORKL(1:ncv*ncv+2*ncv) contains information obtained in c znaupd. They are not changed by zneupd. c WORKL(ncv*ncv+2*ncv+1:3*ncv*ncv+4*ncv) holds the c untransformed Ritz values, the untransformed error estimates of c the Ritz values, the upper triangular matrix for H, and the c associated matrix representation of the invariant subspace for H. c c Note: IPNTR(9:13) contains the pointer into WORKL for addresses c of the above information computed by zneupd. c ------------------------------------------------------------- c IPNTR(9): pointer to the NCV RITZ values of the c original system. c IPNTR(10): Not used c IPNTR(11): pointer to the NCV corresponding error estimates. c IPNTR(12): pointer to the NCV by NCV upper triangular c Schur matrix for H. c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors c of the upper Hessenberg matrix H. Only referenced by c zneupd if RVEC = .TRUE. See Remark 2 below. c ------------------------------------------------------------- c c INFO Integer. (OUTPUT) c Error flag on output. c = 0: Normal exit. c c = 1: The Schur form computed by LAPACK routine csheqr c could not be reordered by LAPACK routine ztrsen. c Re-enter subroutine zneupd with IPARAM(5)=NCV and c increase the size of the array D to have c dimension at least dimension NCV and allocate at least NCV c columns for Z. NOTE: Not necessary if Z and V share c the same space. Please notify the authors if this error c occurs. c c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 1 and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from LAPACK eigenvalue calculation. c This should never happened. c = -9: Error return from calculation of eigenvectors. c Informational error from LAPACK routine ztrevc. c = -10: IPARAM(7) must be 1,2,3 c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: HOWMNY = 'S' not yet implemented c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. c = -14: ZNAUPD did not find any eigenvalues to sufficient c accuracy. c = -15: ZNEUPD got a different count of the number of converged c Ritz values than ZNAUPD got. This indicates the user c probably made an error in passing data from ZNAUPD to c ZNEUPD or that the data was modified before entering c ZNEUPD c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B. Nour-Omid, B. N. Parlett, T. Ericsson and P. S. Jensen, c "How to Implement the Spectral Transformation", Math Comp., c Vol. 48, No. 178, April, 1987 pp. 664-673. c c\Routines called: c ivout ARPACK utility routine that prints integers. c zmout ARPACK utility routine that prints matrices c zvout ARPACK utility routine that prints vectors. c zgeqr2 LAPACK routine that computes the QR factorization of c a matrix. c zlacpy LAPACK matrix copy routine. c zlahqr LAPACK routine that computes the Schur form of a c upper Hessenberg matrix. c zlaset LAPACK matrix initialization routine. c ztrevc LAPACK routine to compute the eigenvectors of a matrix c in upper triangular form. c ztrsen LAPACK routine that re-orders the Schur form. c zunm2r LAPACK routine that applies an orthogonal matrix in c factored form. c dlamch LAPACK routine that determines machine constants. c ztrmm Level 3 BLAS matrix times an upper triangular matrix. c zgeru Level 2 BLAS rank one update to a matrix. c zcopy Level 1 BLAS that copies one vector to another . c zscal Level 1 BLAS that scales a vector. c zdscal Level 1 BLAS that scales a complex vector by a real number. c dznrm2 Level 1 BLAS that computes the norm of a complex vector. c c\Remarks c c 1. Currently only HOWMNY = 'A' and 'P' are implemented. c c 2. Schur vectors are an orthogonal representation for the basis of c Ritz vectors. Thus, their numerical properties are often superior. c If RVEC = .true. then the relationship c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and c transpose( V(:,1:IPARAM(5)) ) * V(:,1:IPARAM(5)) = I c are approximately satisfied. c Here T is the leading submatrix of order IPARAM(5) of the c upper triangular matrix stored workl(ipntr(12)). c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Chao Yang Houston, Texas c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: neupd.F SID: 2.8 DATE OF SID: 07/21/02 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- subroutine zneupd(rvec , howmny, select, d , & z , ldz , sigma , workev, & bmat , n , which , nev , & tol , resid , ncv , v , & ldv , iparam, ipntr , workd , & workl, lworkl, rwork , info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat, howmny, which*2 logical rvec integer info, ldz, ldv, lworkl, n, ncv, nev Complex*16 & sigma Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(14) logical select(ncv) Double precision & rwork(ncv) Complex*16 & d(nev) , resid(n) , v(ldv,ncv), & z(ldz, nev), & workd(3*n) , workl(lworkl), workev(2*ncv) c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0)) c c %---------------% c | Local Scalars | c %---------------% c character type*6 integer bounds, ierr , ih , ihbds, iheig , nconv , & invsub, iuptri, iwev , j , ldh , ldq , & mode , msglvl, ritz , wr , k , irz , & ibd , outncv, iq , np , numcnv, jj , & ishift Complex*16 & rnorm, temp, vl(1) Double precision & conds, sep, rtemp, eps23 logical reord c c %----------------------% c | External Subroutines | c %----------------------% c external zcopy , zgeru, zgeqr2, zlacpy, zmout, & zunm2r, ztrmm, zvout, ivout, & zlahqr c c %--------------------% c | External Functions | c %--------------------% c Double precision & dznrm2, dlamch, dlapy2 external dznrm2, dlamch, dlapy2 c Complex*16 & zdotc external zdotc c c %-----------------------% c | Executable Statements | c %-----------------------% c c %------------------------% c | Set default parameters | c %------------------------% c msglvl = mceupd mode = iparam(7) nconv = iparam(5) info = 0 c c c %---------------------------------% c | Get machine dependent constant. | c %---------------------------------% c eps23 = dlamch('Epsilon-Machine') eps23 = eps23**(2.0D+0 / 3.0D+0) c c %-------------------------------% c | Quick return | c | Check for incompatible input | c %-------------------------------% c ierr = 0 c if (nconv .le. 0) then ierr = -14 else if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev .or. ncv .gt. n) then ierr = -3 else if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LR' .and. & which .ne. 'SR' .and. & which .ne. 'LI' .and. & which .ne. 'SI') then ierr = -5 else if (bmat .ne. 'I' .and. bmat .ne. 'G') then ierr = -6 else if (lworkl .lt. 3*ncv**2 + 4*ncv) then ierr = -7 else if ( (howmny .ne. 'A' .and. & howmny .ne. 'P' .and. & howmny .ne. 'S') .and. rvec ) then ierr = -13 else if (howmny .eq. 'S' ) then ierr = -12 end if c if (mode .eq. 1 .or. mode .eq. 2) then type = 'REGULR' else if (mode .eq. 3 ) then type = 'SHIFTI' else ierr = -10 end if if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr go to 9000 end if c c %--------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, WORKEV, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:ncv*ncv) := generated Hessenberg matrix | c | workl(ncv*ncv+1:ncv*ncv+ncv) := ritz values | c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | c %--------------------------------------------------------% c c %-----------------------------------------------------------% c | The following is used and set by ZNEUPD. | c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed | c | Ritz values. | c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | c | error bounds of | c | the Ritz values | c | workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper | c | triangular matrix | c | for H. | c | workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the | c | associated matrix | c | representation of | c | the invariant | c | subspace for H. | c | GRAND total of NCV * ( 3 * NCV + 4 ) locations. | c %-----------------------------------------------------------% c ih = ipntr(5) ritz = ipntr(6) iq = ipntr(7) bounds = ipntr(8) ldh = ncv ldq = ncv iheig = bounds + ldh ihbds = iheig + ldh iuptri = ihbds + ldh invsub = iuptri + ldh*ncv ipntr(9) = iheig ipntr(11) = ihbds ipntr(12) = iuptri ipntr(13) = invsub wr = 1 iwev = wr + ncv c c %-----------------------------------------% c | irz points to the Ritz values computed | c | by _neigh before exiting _naup2. | c | ibd points to the Ritz estimates | c | computed by _neigh before exiting | c | _naup2. | c %-----------------------------------------% c irz = ipntr(14) + ncv*ncv ibd = irz + ncv c c %------------------------------------% c | RNORM is B-norm of the RESID(1:N). | c %------------------------------------% c rnorm = workl(ih+2) workl(ih+2) = zero c if (msglvl .gt. 2) then call zvout(logfil, ncv, workl(irz), ndigit, & '_neupd: Ritz values passed in from _NAUPD.') call zvout(logfil, ncv, workl(ibd), ndigit, & '_neupd: Ritz estimates passed in from _NAUPD.') end if c if (rvec) then c reord = .false. c c %---------------------------------------------------% c | Use the temporary bounds array to store indices | c | These will be used to mark the select array later | c %---------------------------------------------------% c do 10 j = 1,ncv workl(bounds+j-1) = j select(j) = .false. 10 continue c c %-------------------------------------% c | Select the wanted Ritz values. | c | Sort the Ritz values so that the | c | wanted ones appear at the tailing | c | NEV positions of workl(irr) and | c | workl(iri). Move the corresponding | c | error estimates in workl(ibd) | c | accordingly. | c %-------------------------------------% c np = ncv - nev ishift = 0 call zngets(ishift, which , nev , & np , workl(irz), workl(bounds)) c if (msglvl .gt. 2) then call zvout (logfil, ncv, workl(irz), ndigit, & '_neupd: Ritz values after calling _NGETS.') call zvout (logfil, ncv, workl(bounds), ndigit, & '_neupd: Ritz value indices after calling _NGETS.') end if c c %-----------------------------------------------------% c | Record indices of the converged wanted Ritz values | c | Mark the select array for possible reordering | c %-----------------------------------------------------% c numcnv = 0 do 11 j = 1,ncv rtemp = max(eps23, & dlapy2 ( dble(workl(irz+ncv-j)), & dimag(workl(irz+ncv-j)) )) jj = workl(bounds + ncv - j) if (numcnv .lt. nconv .and. & dlapy2( dble(workl(ibd+jj-1)), & dimag(workl(ibd+jj-1)) ) & .le. tol*rtemp) then select(jj) = .true. numcnv = numcnv + 1 if (jj .gt. nev) reord = .true. endif 11 continue c c %-----------------------------------------------------------% c | Check the count (numcnv) of converged Ritz values with | c | the number (nconv) reported by dnaupd. If these two | c | are different then there has probably been an error | c | caused by incorrect passing of the dnaupd data. | c %-----------------------------------------------------------% c if (msglvl .gt. 2) then call ivout(logfil, 1, numcnv, ndigit, & '_neupd: Number of specified eigenvalues') call ivout(logfil, 1, nconv, ndigit, & '_neupd: Number of "converged" eigenvalues') end if c if (numcnv .ne. nconv) then info = -15 go to 9000 end if c c %-------------------------------------------------------% c | Call LAPACK routine zlahqr to compute the Schur form | c | of the upper Hessenberg matrix returned by ZNAUPD. | c | Make a copy of the upper Hessenberg matrix. | c | Initialize the Schur vector matrix Q to the identity. | c %-------------------------------------------------------% c call zcopy(ldh*ncv, workl(ih), 1, workl(iuptri), 1) call zlaset('All', ncv, ncv , & zero , one, workl(invsub), & ldq) call zlahqr(.true., .true. , ncv , & 1 , ncv , workl(iuptri), & ldh , workl(iheig) , 1 , & ncv , workl(invsub), ldq , & ierr) call zcopy(ncv , workl(invsub+ncv-1), ldq, & workl(ihbds), 1) c if (ierr .ne. 0) then info = -8 go to 9000 end if c if (msglvl .gt. 1) then call zvout (logfil, ncv, workl(iheig), ndigit, & '_neupd: Eigenvalues of H') call zvout (logfil, ncv, workl(ihbds), ndigit, & '_neupd: Last row of the Schur vector matrix') if (msglvl .gt. 3) then call zmout (logfil , ncv, ncv , & workl(iuptri), ldh, ndigit, & '_neupd: The upper triangular matrix ') end if end if c if (reord) then c c %-----------------------------------------------% c | Reorder the computed upper triangular matrix. | c %-----------------------------------------------% c call ztrsen('None' , 'V' , select , & ncv , workl(iuptri), ldh , & workl(invsub), ldq , workl(iheig), & nconv , conds , sep , & workev , ncv , ierr) c if (ierr .eq. 1) then info = 1 go to 9000 end if c if (msglvl .gt. 2) then call zvout (logfil, ncv, workl(iheig), ndigit, & '_neupd: Eigenvalues of H--reordered') if (msglvl .gt. 3) then call zmout(logfil , ncv, ncv , & workl(iuptri), ldq, ndigit, & '_neupd: Triangular matrix after re-ordering') end if end if c end if c c %---------------------------------------------% c | Copy the last row of the Schur basis matrix | c | to workl(ihbds). This vector will be used | c | to compute the Ritz estimates of converged | c | Ritz values. | c %---------------------------------------------% c call zcopy(ncv , workl(invsub+ncv-1), ldq, & workl(ihbds), 1) c c %--------------------------------------------% c | Place the computed eigenvalues of H into D | c | if a spectral transformation was not used. | c %--------------------------------------------% c if (type .eq. 'REGULR') then call zcopy(nconv, workl(iheig), 1, d, 1) end if c c %----------------------------------------------------------% c | Compute the QR factorization of the matrix representing | c | the wanted invariant subspace located in the first NCONV | c | columns of workl(invsub,ldq). | c %----------------------------------------------------------% c call zgeqr2(ncv , nconv , workl(invsub), & ldq , workev, workev(ncv+1), & ierr) c c %--------------------------------------------------------% c | * Postmultiply V by Q using zunm2r. | c | * Copy the first NCONV columns of VQ into Z. | c | * Postmultiply Z by R. | c | The N by NCONV matrix Z is now a matrix representation | c | of the approximate invariant subspace associated with | c | the Ritz values in workl(iheig). The first NCONV | c | columns of V are now approximate Schur vectors | c | associated with the upper triangular matrix of order | c | NCONV in workl(iuptri). | c %--------------------------------------------------------% c call zunm2r('Right', 'Notranspose', n , & ncv , nconv , workl(invsub), & ldq , workev , v , & ldv , workd(n+1) , ierr) call zlacpy('All', n, nconv, v, ldv, z, ldz) c do 20 j=1, nconv c c %---------------------------------------------------% c | Perform both a column and row scaling if the | c | diagonal element of workl(invsub,ldq) is negative | c | I'm lazy and don't take advantage of the upper | c | triangular form of workl(iuptri,ldq). | c | Note that since Q is orthogonal, R is a diagonal | c | matrix consisting of plus or minus ones. | c %---------------------------------------------------% c if ( dble( workl(invsub+(j-1)*ldq+j-1) ) .lt. & dble(zero) ) then call zscal(nconv, -one, workl(iuptri+j-1), ldq) call zscal(nconv, -one, workl(iuptri+(j-1)*ldq), 1) end if c 20 continue c if (howmny .eq. 'A') then c c %--------------------------------------------% c | Compute the NCONV wanted eigenvectors of T | c | located in workl(iuptri,ldq). | c %--------------------------------------------% c do 30 j=1, ncv if (j .le. nconv) then select(j) = .true. else select(j) = .false. end if 30 continue c call ztrevc('Right', 'Select' , select , & ncv , workl(iuptri), ldq , & vl , 1 , workl(invsub), & ldq , ncv , outncv , & workev , rwork , ierr) c if (ierr .ne. 0) then info = -9 go to 9000 end if c c %------------------------------------------------% c | Scale the returning eigenvectors so that their | c | Euclidean norms are all one. LAPACK subroutine | c | ztrevc returns each eigenvector normalized so | c | that the element of largest magnitude has | c | magnitude 1. | c %------------------------------------------------% c do 40 j=1, nconv rtemp = dznrm2(ncv, workl(invsub+(j-1)*ldq), 1) rtemp = dble(one) / rtemp call zdscal ( ncv, rtemp, & workl(invsub+(j-1)*ldq), 1 ) c c %------------------------------------------% c | Ritz estimates can be obtained by taking | c | the inner product of the last row of the | c | Schur basis of H with eigenvectors of T. | c | Note that the eigenvector matrix of T is | c | upper triangular, thus the length of the | c | inner product can be set to j. | c %------------------------------------------% c c FIXME GetDP: don't use zdotc on Apple with gfortran c workev(j) = zdotc(j, workl(ihbds), 1, c & workl(invsub+(j-1)*ldq), 1) workev(j) = 0 do 41 k=1, j workev(j) = workev(j) + conjg(workl(ihbds)+k-1) * & workl(invsub+(j-1)*ldq+k-1) 41 continue c END OF FIXME 40 continue c if (msglvl .gt. 2) then call zcopy(nconv, workl(invsub+ncv-1), ldq, & workl(ihbds), 1) call zvout (logfil, nconv, workl(ihbds), ndigit, & '_neupd: Last row of the eigenvector matrix for T') if (msglvl .gt. 3) then call zmout(logfil , ncv, ncv , & workl(invsub), ldq, ndigit, & '_neupd: The eigenvector matrix for T') end if end if c c %---------------------------------------% c | Copy Ritz estimates into workl(ihbds) | c %---------------------------------------% c call zcopy(nconv, workev, 1, workl(ihbds), 1) c c %----------------------------------------------% c | The eigenvector matrix Q of T is triangular. | c | Form Z*Q. | c %----------------------------------------------% c call ztrmm('Right' , 'Upper' , 'No transpose', & 'Non-unit', n , nconv , & one , workl(invsub), ldq , & z , ldz) end if c else c c %--------------------------------------------------% c | An approximate invariant subspace is not needed. | c | Place the Ritz values computed ZNAUPD into D. | c %--------------------------------------------------% c call zcopy(nconv, workl(ritz), 1, d, 1) call zcopy(nconv, workl(ritz), 1, workl(iheig), 1) call zcopy(nconv, workl(bounds), 1, workl(ihbds), 1) c end if c c %------------------------------------------------% c | Transform the Ritz values and possibly vectors | c | and corresponding error bounds of OP to those | c | of A*x = lambda*B*x. | c %------------------------------------------------% c if (type .eq. 'REGULR') then c if (rvec) & call zscal(ncv, rnorm, workl(ihbds), 1) c else c c %---------------------------------------% c | A spectral transformation was used. | c | * Determine the Ritz estimates of the | c | Ritz values in the original system. | c %---------------------------------------% c if (rvec) & call zscal(ncv, rnorm, workl(ihbds), 1) c do 50 k=1, ncv temp = workl(iheig+k-1) workl(ihbds+k-1) = workl(ihbds+k-1) / temp / temp 50 continue c end if c c %-----------------------------------------------------------% c | * Transform the Ritz values back to the original system. | c | For TYPE = 'SHIFTI' the transformation is | c | lambda = 1/theta + sigma | c | NOTES: | c | *The Ritz vectors are not affected by the transformation. | c %-----------------------------------------------------------% c if (type .eq. 'SHIFTI') then do 60 k=1, nconv d(k) = one / workl(iheig+k-1) + sigma 60 continue end if c if (type .ne. 'REGULR' .and. msglvl .gt. 1) then call zvout (logfil, nconv, d, ndigit, & '_neupd: Untransformed Ritz values.') call zvout (logfil, nconv, workl(ihbds), ndigit, & '_neupd: Ritz estimates of the untransformed Ritz values.') else if ( msglvl .gt. 1) then call zvout (logfil, nconv, d, ndigit, & '_neupd: Converged Ritz values.') call zvout (logfil, nconv, workl(ihbds), ndigit, & '_neupd: Associated Ritz estimates.') end if c c %-------------------------------------------------% c | Eigenvector Purification step. Formally perform | c | one of inverse subspace iteration. Only used | c | for MODE = 3. See reference 3. | c %-------------------------------------------------% c if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then c c %------------------------------------------------% c | Purify the computed Ritz vectors by adding a | c | little bit of the residual vector: | c | T | c | resid(:)*( e s ) / theta | c | NCV | c | where H s = s theta. | c %------------------------------------------------% c do 100 j=1, nconv if (workl(iheig+j-1) .ne. zero) then workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / & workl(iheig+j-1) endif 100 continue c %---------------------------------------% c | Perform a rank one update to Z and | c | purify all the Ritz vectors together. | c %---------------------------------------% c call zgeru (n, nconv, one, resid, 1, workev, 1, z, ldz) c end if c 9000 continue c return c c %---------------% c | End of zneupd| c %---------------% c end getdp-2.4.2-source/contrib/Arpack/debug.h000644 001750 001750 00000001351 11266605602 021704 0ustar00geuzainegeuzaine000000 000000 c c\SCCS Information: @(#) c FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 c c %---------------------------------% c | See debug.doc for documentation | c %---------------------------------% integer logfil, ndigit, mgetv0, & msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd, & mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd, & mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd common /debug/ & logfil, ndigit, mgetv0, & msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd, & mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd, & mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd getdp-2.4.2-source/contrib/Arpack/dlaqrb.f000644 001750 001750 00000044020 11266605602 022061 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dlaqrb c c\Description: c Compute the eigenvalues and the Schur decomposition of an upper c Hessenberg submatrix in rows and columns ILO to IHI. Only the c last component of the Schur vectors are computed. c c This is mostly a modification of the LAPACK routine dlahqr. c c\Usage: c call dlaqrb c ( WANTT, N, ILO, IHI, H, LDH, WR, WI, Z, INFO ) c c\Arguments c WANTT Logical variable. (INPUT) c = .TRUE. : the full Schur form T is required; c = .FALSE.: only eigenvalues are required. c c N Integer. (INPUT) c The order of the matrix H. N >= 0. c c ILO Integer. (INPUT) c IHI Integer. (INPUT) c It is assumed that H is already upper quasi-triangular in c rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless c ILO = 1). SLAQRB works primarily with the Hessenberg c submatrix in rows and columns ILO to IHI, but applies c transformations to all of H if WANTT is .TRUE.. c 1 <= ILO <= max(1,IHI); IHI <= N. c c H Double precision array, dimension (LDH,N). (INPUT/OUTPUT) c On entry, the upper Hessenberg matrix H. c On exit, if WANTT is .TRUE., H is upper quasi-triangular in c rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in c standard form. If WANTT is .FALSE., the contents of H are c unspecified on exit. c c LDH Integer. (INPUT) c The leading dimension of the array H. LDH >= max(1,N). c c WR Double precision array, dimension (N). (OUTPUT) c WI Double precision array, dimension (N). (OUTPUT) c The real and imaginary parts, respectively, of the computed c eigenvalues ILO to IHI are stored in the corresponding c elements of WR and WI. If two eigenvalues are computed as a c complex conjugate pair, they are stored in consecutive c elements of WR and WI, say the i-th and (i+1)th, with c WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the c eigenvalues are stored in the same order as on the diagonal c of the Schur form returned in H, with WR(i) = H(i,i), and, if c H(i:i+1,i:i+1) is a 2-by-2 diagonal block, c WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). c c Z Double precision array, dimension (N). (OUTPUT) c On exit Z contains the last components of the Schur vectors. c c INFO Integer. (OUPUT) c = 0: successful exit c > 0: SLAQRB failed to compute all the eigenvalues ILO to IHI c in a total of 30*(IHI-ILO+1) iterations; if INFO = i, c elements i+1:ihi of WR and WI contain those eigenvalues c which have been successfully computed. c c\Remarks c 1. None. c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c dlabad LAPACK routine that computes machine constants. c dlamch LAPACK routine that determines machine constants. c dlanhs LAPACK routine that computes various norms of a matrix. c dlanv2 LAPACK routine that computes the Schur factorization of c 2 by 2 nonsymmetric matrix in standard form. c dlarfg LAPACK Householder reflection construction routine. c dcopy Level 1 BLAS that copies one vector to another. c drot Level 1 BLAS that applies a rotation to a 2 by 2 matrix. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.4' c Modified from the LAPACK routine dlahqr so that only the c last component of the Schur vectors are computed. c c\SCCS Information: @(#) c FILE: laqrb.F SID: 2.2 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c subroutine dlaqrb ( wantt, n, ilo, ihi, h, ldh, wr, wi, & z, info ) c c %------------------% c | Scalar Arguments | c %------------------% c logical wantt integer ihi, ilo, info, ldh, n c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & h( ldh, * ), wi( * ), wr( * ), z( * ) c c %------------% c | Parameters | c %------------% c Double precision & zero, one, dat1, dat2 parameter (zero = 0.0D+0, one = 1.0D+0, dat1 = 7.5D-1, & dat2 = -4.375D-1) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c integer i, i1, i2, itn, its, j, k, l, m, nh, nr Double precision & cs, h00, h10, h11, h12, h21, h22, h33, h33s, & h43h34, h44, h44s, ovfl, s, smlnum, sn, sum, & t1, t2, t3, tst1, ulp, unfl, v1, v2, v3 Double precision & v( 3 ), work( 1 ) c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlamch, dlanhs external dlamch, dlanhs c c %----------------------% c | External Subroutines | c %----------------------% c external dcopy, dlabad, dlanv2, dlarfg, drot c c %-----------------------% c | Executable Statements | c %-----------------------% c info = 0 c c %--------------------------% c | Quick return if possible | c %--------------------------% c if( n.eq.0 ) & return if( ilo.eq.ihi ) then wr( ilo ) = h( ilo, ilo ) wi( ilo ) = zero return end if c c %---------------------------------------------% c | Initialize the vector of last components of | c | the Schur vectors for accumulation. | c %---------------------------------------------% c do 5 j = 1, n-1 z(j) = zero 5 continue z(n) = one c nh = ihi - ilo + 1 c c %-------------------------------------------------------------% c | Set machine-dependent constants for the stopping criterion. | c | If norm(H) <= sqrt(OVFL), overflow should not occur. | c %-------------------------------------------------------------% c unfl = dlamch( 'safe minimum' ) ovfl = one / unfl call dlabad( unfl, ovfl ) ulp = dlamch( 'precision' ) smlnum = unfl*( nh / ulp ) c c %---------------------------------------------------------------% c | I1 and I2 are the indices of the first row and last column | c | of H to which transformations must be applied. If eigenvalues | c | only are computed, I1 and I2 are set inside the main loop. | c | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE. | c | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE. | c %---------------------------------------------------------------% c if( wantt ) then i1 = 1 i2 = n do 8 i=1,i2-2 h(i1+i+1,i) = zero 8 continue else do 9 i=1, ihi-ilo-1 h(ilo+i+1,ilo+i-1) = zero 9 continue end if c c %---------------------------------------------------% c | ITN is the total number of QR iterations allowed. | c %---------------------------------------------------% c itn = 30*nh c c ------------------------------------------------------------------ c The main loop begins here. I is the loop index and decreases from c IHI to ILO in steps of 1 or 2. Each iteration of the loop works c with the active submatrix in rows and columns L to I. c Eigenvalues I+1 to IHI have already converged. Either L = ILO or c H(L,L-1) is negligible so that the matrix splits. c ------------------------------------------------------------------ c i = ihi 10 continue l = ilo if( i.lt.ilo ) & go to 150 c %--------------------------------------------------------------% c | Perform QR iterations on rows and columns ILO to I until a | c | submatrix of order 1 or 2 splits off at the bottom because a | c | subdiagonal element has become negligible. | c %--------------------------------------------------------------% do 130 its = 0, itn c c %----------------------------------------------% c | Look for a single small subdiagonal element. | c %----------------------------------------------% c do 20 k = i, l + 1, -1 tst1 = abs( h( k-1, k-1 ) ) + abs( h( k, k ) ) if( tst1.eq.zero ) & tst1 = dlanhs( '1', i-l+1, h( l, l ), ldh, work ) if( abs( h( k, k-1 ) ).le.max( ulp*tst1, smlnum ) ) & go to 30 20 continue 30 continue l = k if( l.gt.ilo ) then c c %------------------------% c | H(L,L-1) is negligible | c %------------------------% c h( l, l-1 ) = zero end if c c %-------------------------------------------------------------% c | Exit from loop if a submatrix of order 1 or 2 has split off | c %-------------------------------------------------------------% c if( l.ge.i-1 ) & go to 140 c c %---------------------------------------------------------% c | Now the active submatrix is in rows and columns L to I. | c | If eigenvalues only are being computed, only the active | c | submatrix need be transformed. | c %---------------------------------------------------------% c if( .not.wantt ) then i1 = l i2 = i end if c if( its.eq.10 .or. its.eq.20 ) then c c %-------------------% c | Exceptional shift | c %-------------------% c s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) ) h44 = dat1*s h33 = h44 h43h34 = dat2*s*s c else c c %-----------------------------------------% c | Prepare to use Wilkinson's double shift | c %-----------------------------------------% c h44 = h( i, i ) h33 = h( i-1, i-1 ) h43h34 = h( i, i-1 )*h( i-1, i ) end if c c %-----------------------------------------------------% c | Look for two consecutive small subdiagonal elements | c %-----------------------------------------------------% c do 40 m = i - 2, l, -1 c c %---------------------------------------------------------% c | Determine the effect of starting the double-shift QR | c | iteration at row M, and see if this would make H(M,M-1) | c | negligible. | c %---------------------------------------------------------% c h11 = h( m, m ) h22 = h( m+1, m+1 ) h21 = h( m+1, m ) h12 = h( m, m+1 ) h44s = h44 - h11 h33s = h33 - h11 v1 = ( h33s*h44s-h43h34 ) / h21 + h12 v2 = h22 - h11 - h33s - h44s v3 = h( m+2, m+1 ) s = abs( v1 ) + abs( v2 ) + abs( v3 ) v1 = v1 / s v2 = v2 / s v3 = v3 / s v( 1 ) = v1 v( 2 ) = v2 v( 3 ) = v3 if( m.eq.l ) & go to 50 h00 = h( m-1, m-1 ) h10 = h( m, m-1 ) tst1 = abs( v1 )*( abs( h00 )+abs( h11 )+abs( h22 ) ) if( abs( h10 )*( abs( v2 )+abs( v3 ) ).le.ulp*tst1 ) & go to 50 40 continue 50 continue c c %----------------------% c | Double-shift QR step | c %----------------------% c do 120 k = m, i - 1 c c ------------------------------------------------------------ c The first iteration of this loop determines a reflection G c from the vector V and applies it from left and right to H, c thus creating a nonzero bulge below the subdiagonal. c c Each subsequent iteration determines a reflection G to c restore the Hessenberg form in the (K-1)th column, and thus c chases the bulge one step toward the bottom of the active c submatrix. NR is the order of G. c ------------------------------------------------------------ c nr = min( 3, i-k+1 ) if( k.gt.m ) & call dcopy( nr, h( k, k-1 ), 1, v, 1 ) call dlarfg( nr, v( 1 ), v( 2 ), 1, t1 ) if( k.gt.m ) then h( k, k-1 ) = v( 1 ) h( k+1, k-1 ) = zero if( k.lt.i-1 ) & h( k+2, k-1 ) = zero else if( m.gt.l ) then h( k, k-1 ) = -h( k, k-1 ) end if v2 = v( 2 ) t2 = t1*v2 if( nr.eq.3 ) then v3 = v( 3 ) t3 = t1*v3 c c %------------------------------------------------% c | Apply G from the left to transform the rows of | c | the matrix in columns K to I2. | c %------------------------------------------------% c do 60 j = k, i2 sum = h( k, j ) + v2*h( k+1, j ) + v3*h( k+2, j ) h( k, j ) = h( k, j ) - sum*t1 h( k+1, j ) = h( k+1, j ) - sum*t2 h( k+2, j ) = h( k+2, j ) - sum*t3 60 continue c c %----------------------------------------------------% c | Apply G from the right to transform the columns of | c | the matrix in rows I1 to min(K+3,I). | c %----------------------------------------------------% c do 70 j = i1, min( k+3, i ) sum = h( j, k ) + v2*h( j, k+1 ) + v3*h( j, k+2 ) h( j, k ) = h( j, k ) - sum*t1 h( j, k+1 ) = h( j, k+1 ) - sum*t2 h( j, k+2 ) = h( j, k+2 ) - sum*t3 70 continue c c %----------------------------------% c | Accumulate transformations for Z | c %----------------------------------% c sum = z( k ) + v2*z( k+1 ) + v3*z( k+2 ) z( k ) = z( k ) - sum*t1 z( k+1 ) = z( k+1 ) - sum*t2 z( k+2 ) = z( k+2 ) - sum*t3 else if( nr.eq.2 ) then c c %------------------------------------------------% c | Apply G from the left to transform the rows of | c | the matrix in columns K to I2. | c %------------------------------------------------% c do 90 j = k, i2 sum = h( k, j ) + v2*h( k+1, j ) h( k, j ) = h( k, j ) - sum*t1 h( k+1, j ) = h( k+1, j ) - sum*t2 90 continue c c %----------------------------------------------------% c | Apply G from the right to transform the columns of | c | the matrix in rows I1 to min(K+3,I). | c %----------------------------------------------------% c do 100 j = i1, i sum = h( j, k ) + v2*h( j, k+1 ) h( j, k ) = h( j, k ) - sum*t1 h( j, k+1 ) = h( j, k+1 ) - sum*t2 100 continue c c %----------------------------------% c | Accumulate transformations for Z | c %----------------------------------% c sum = z( k ) + v2*z( k+1 ) z( k ) = z( k ) - sum*t1 z( k+1 ) = z( k+1 ) - sum*t2 end if 120 continue 130 continue c c %-------------------------------------------------------% c | Failure to converge in remaining number of iterations | c %-------------------------------------------------------% c info = i return 140 continue if( l.eq.i ) then c c %------------------------------------------------------% c | H(I,I-1) is negligible: one eigenvalue has converged | c %------------------------------------------------------% c wr( i ) = h( i, i ) wi( i ) = zero else if( l.eq.i-1 ) then c c %--------------------------------------------------------% c | H(I-1,I-2) is negligible; | c | a pair of eigenvalues have converged. | c | | c | Transform the 2-by-2 submatrix to standard Schur form, | c | and compute and store the eigenvalues. | c %--------------------------------------------------------% c call dlanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ), & h( i, i ), wr( i-1 ), wi( i-1 ), wr( i ), wi( i ), & cs, sn ) if( wantt ) then c c %-----------------------------------------------------% c | Apply the transformation to the rest of H and to Z, | c | as required. | c %-----------------------------------------------------% c if( i2.gt.i ) & call drot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh, & cs, sn ) call drot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn ) sum = cs*z( i-1 ) + sn*z( i ) z( i ) = cs*z( i ) - sn*z( i-1 ) z( i-1 ) = sum end if end if c c %---------------------------------------------------------% c | Decrement number of remaining iterations, and return to | c | start of the main loop with new value of I. | c %---------------------------------------------------------% c itn = itn - its i = l - 1 go to 10 150 continue return c c %---------------% c | End of dlaqrb | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/snaupe.f000644 001750 001750 00000000000 11266605602 022075 0ustar00geuzainegeuzaine000000 000000 getdp-2.4.2-source/contrib/Arpack/sngets.f000644 001750 001750 00000017454 11266605602 022132 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: sngets c c\Description: c Given the eigenvalues of the upper Hessenberg matrix H, c computes the NP shifts AMU that are zeros of the polynomial of c degree NP which filters out components of the unwanted eigenvectors c corresponding to the AMU's based on some given criteria. c c NOTE: call this even in the case of user specified shifts in order c to sort the eigenvalues, and error bounds of H for later use. c c\Usage: c call sngets c ( ISHIFT, WHICH, KEV, NP, RITZR, RITZI, BOUNDS, SHIFTR, SHIFTI ) c c\Arguments c ISHIFT Integer. (INPUT) c Method for selecting the implicit shifts at each iteration. c ISHIFT = 0: user specified shifts c ISHIFT = 1: exact shift with respect to the matrix H. c c WHICH Character*2. (INPUT) c Shift selection criteria. c 'LM' -> want the KEV eigenvalues of largest magnitude. c 'SM' -> want the KEV eigenvalues of smallest magnitude. c 'LR' -> want the KEV eigenvalues of largest real part. c 'SR' -> want the KEV eigenvalues of smallest real part. c 'LI' -> want the KEV eigenvalues of largest imaginary part. c 'SI' -> want the KEV eigenvalues of smallest imaginary part. c c KEV Integer. (INPUT/OUTPUT) c INPUT: KEV+NP is the size of the matrix H. c OUTPUT: Possibly increases KEV by one to keep complex conjugate c pairs together. c c NP Integer. (INPUT/OUTPUT) c Number of implicit shifts to be computed. c OUTPUT: Possibly decreases NP by one to keep complex conjugate c pairs together. c c RITZR, Real array of length KEV+NP. (INPUT/OUTPUT) c RITZI On INPUT, RITZR and RITZI contain the real and imaginary c parts of the eigenvalues of H. c On OUTPUT, RITZR and RITZI are sorted so that the unwanted c eigenvalues are in the first NP locations and the wanted c portion is in the last KEV locations. When exact shifts are c selected, the unwanted part corresponds to the shifts to c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues c are further sorted so that the ones with largest Ritz values c are first. c c BOUNDS Real array of length KEV+NP. (INPUT/OUTPUT) c Error bounds corresponding to the ordering in RITZ. c c SHIFTR, SHIFTI *** USE deprecated as of version 2.1. *** c c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c ssortc ARPACK sorting routine. c scopy Level 1 BLAS that copies one vector to another . c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.1' c c\SCCS Information: @(#) c FILE: ngets.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c 1. xxxx c c\EndLib c c----------------------------------------------------------------------- c subroutine sngets ( ishift, which, kev, np, ritzr, ritzi, bounds, & shiftr, shifti ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which integer ishift, kev, np c c %-----------------% c | Array Arguments | c %-----------------% c Real & bounds(kev+np), ritzr(kev+np), ritzi(kev+np), & shiftr(1), shifti(1) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0, zero = 0.0) c c %---------------% c | Local Scalars | c %---------------% c integer msglvl c c %----------------------% c | External Subroutines | c %----------------------% c external scopy, ssortc, second c c %----------------------% c | Intrinsics Functions | c %----------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mngets c c %----------------------------------------------------% c | LM, SM, LR, SR, LI, SI case. | c | Sort the eigenvalues of H into the desired order | c | and apply the resulting order to BOUNDS. | c | The eigenvalues are sorted so that the wanted part | c | are always in the last KEV locations. | c | We first do a pre-processing sort in order to keep | c | complex conjugate pairs together | c %----------------------------------------------------% c if (which .eq. 'LM') then call ssortc ('LR', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'SM') then call ssortc ('SR', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'LR') then call ssortc ('LM', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'SR') then call ssortc ('SM', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'LI') then call ssortc ('LM', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'SI') then call ssortc ('SM', .true., kev+np, ritzr, ritzi, bounds) end if c call ssortc (which, .true., kev+np, ritzr, ritzi, bounds) c c %-------------------------------------------------------% c | Increase KEV by one if the ( ritzr(np),ritzi(np) ) | c | = ( ritzr(np+1),-ritzi(np+1) ) and ritz(np) .ne. zero | c | Accordingly decrease NP by one. In other words keep | c | complex conjugate pairs together. | c %-------------------------------------------------------% c if ( ( ritzr(np+1) - ritzr(np) ) .eq. zero & .and. ( ritzi(np+1) + ritzi(np) ) .eq. zero ) then np = np - 1 kev = kev + 1 end if c if ( ishift .eq. 1 ) then c c %-------------------------------------------------------% c | Sort the unwanted Ritz values used as shifts so that | c | the ones with largest Ritz estimates are first | c | This will tend to minimize the effects of the | c | forward instability of the iteration when they shifts | c | are applied in subroutine snapps. | c | Be careful and use 'SR' since we want to sort BOUNDS! | c %-------------------------------------------------------% c call ssortc ( 'SR', .true., np, bounds, ritzr, ritzi ) end if c call second (t1) tngets = tngets + (t1 - t0) c if (msglvl .gt. 0) then call ivout (logfil, 1, kev, ndigit, '_ngets: KEV is') call ivout (logfil, 1, np, ndigit, '_ngets: NP is') call svout (logfil, kev+np, ritzr, ndigit, & '_ngets: Eigenvalues of current H matrix -- real part') call svout (logfil, kev+np, ritzi, ndigit, & '_ngets: Eigenvalues of current H matrix -- imag part') call svout (logfil, kev+np, bounds, ndigit, & '_ngets: Ritz estimates of the current KEV+NP Ritz values') end if c return c c %---------------% c | End of sngets | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/sgetv0.f000644 001750 001750 00000031466 11266605602 022036 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: sgetv0 c c\Description: c Generate a random initial residual vector for the Arnoldi process. c Force the residual vector to be in the range of the operator OP. c c\Usage: c call sgetv0 c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, c IPNTR, WORKD, IERR ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to sgetv0. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 99: done c ------------------------------------------------------------- c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B in the (generalized) c eigenvalue problem A*x = lambda*B*x. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x c c ITRY Integer. (INPUT) c ITRY counts the number of times that sgetv0 is called. c It should be set to 1 on the initial call to sgetv0. c c INITV Logical variable. (INPUT) c .TRUE. => the initial residual vector is given in RESID. c .FALSE. => generate a random initial residual vector. c c N Integer. (INPUT) c Dimension of the problem. c c J Integer. (INPUT) c Index of the residual vector to be generated, with respect to c the Arnoldi process. J > 1 in case of a "restart". c c V Real N by J array. (INPUT) c The first J-1 columns of V contain the current Arnoldi basis c if this is a "restart". c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c RESID Real array of length N. (INPUT/OUTPUT) c Initial residual vector to be generated. If RESID is c provided, force RESID into the range of the operator OP. c c RNORM Real scalar. (OUTPUT) c B-norm of the generated residual. c c IPNTR Integer array of length 3. (OUTPUT) c c WORKD Real work array of length 2*N. (REVERSE COMMUNICATION). c On exit, WORK(1:N) = B*RESID to be used in SSAITR. c c IERR Integer. (OUTPUT) c = 0: Normal exit. c = -1: Cannot generate a nontrivial restarted residual vector c in the range of the operator OP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c second ARPACK utility routine for timing. c svout ARPACK utility routine for vector output. c slarnv LAPACK routine for generating a random vector. c sgemv Level 2 BLAS routine for matrix vector multiplication. c scopy Level 1 BLAS that copies one vector to another. c sdot Level 1 BLAS that computes the scalar product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: getv0.F SID: 2.7 DATE OF SID: 04/07/99 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine sgetv0 & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, & ipntr, workd, ierr ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 logical initv integer ido, ierr, itry, j, ldv, n Real & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Real & resid(n), v(ldv,j), workd(2*n) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c logical first, inits, orth integer idist, iseed(4), iter, msglvl, jj Real & rnorm0 save first, iseed, inits, iter, msglvl, orth, rnorm0 c c %----------------------% c | External Subroutines | c %----------------------% c external slarnv, svout, scopy, sgemv, second c c %--------------------% c | External Functions | c %--------------------% c Real & sdot, snrm2 external sdot, snrm2 c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs, sqrt c c %-----------------% c | Data Statements | c %-----------------% c data inits /.true./ c c %-----------------------% c | Executable Statements | c %-----------------------% c c c %-----------------------------------% c | Initialize the seed of the LAPACK | c | random number generator | c %-----------------------------------% c if (inits) then iseed(1) = 1 iseed(2) = 3 iseed(3) = 5 iseed(4) = 7 inits = .false. end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mgetv0 c ierr = 0 iter = 0 first = .FALSE. orth = .FALSE. c c %-----------------------------------------------------% c | Possibly generate a random starting vector in RESID | c | Use a LAPACK random number generator used by the | c | matrix generation routines. | c | idist = 1: uniform (0,1) distribution; | c | idist = 2: uniform (-1,1) distribution; | c | idist = 3: normal (0,1) distribution; | c %-----------------------------------------------------% c if (.not.initv) then idist = 2 call slarnv (idist, iseed, n, resid) end if c c %----------------------------------------------------------% c | Force the starting vector into the range of OP to handle | c | the generalized problem when B is possibly (singular). | c %----------------------------------------------------------% c call second (t2) if (bmat .eq. 'G') then nopx = nopx + 1 ipntr(1) = 1 ipntr(2) = n + 1 call scopy (n, resid, 1, workd, 1) ido = -1 go to 9000 end if end if c c %-----------------------------------------% c | Back from computing OP*(initial-vector) | c %-----------------------------------------% c if (first) go to 20 c c %-----------------------------------------------% c | Back from computing B*(orthogonalized-vector) | c %-----------------------------------------------% c if (orth) go to 40 c if (bmat .eq. 'G') then call second (t3) tmvopx = tmvopx + (t3 - t2) end if c c %------------------------------------------------------% c | Starting vector is now in the range of OP; r = OP*r; | c | Compute B-norm of starting vector. | c %------------------------------------------------------% c call second (t2) first = .TRUE. if (bmat .eq. 'G') then nbx = nbx + 1 call scopy (n, workd(n+1), 1, resid, 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd, 1) end if c 20 continue c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c first = .FALSE. if (bmat .eq. 'G') then rnorm0 = sdot (n, resid, 1, workd, 1) rnorm0 = sqrt(abs(rnorm0)) else if (bmat .eq. 'I') then rnorm0 = snrm2(n, resid, 1) end if rnorm = rnorm0 c c %---------------------------------------------% c | Exit if this is the very first Arnoldi step | c %---------------------------------------------% c if (j .eq. 1) go to 50 c c %---------------------------------------------------------------- c | Otherwise need to B-orthogonalize the starting vector against | c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | c | This is the case where an invariant subspace is encountered | c | in the middle of the Arnoldi factorization. | c | | c | s = V^{T}*B*r; r = r - V*s; | c | | c | Stopping criteria used for iter. ref. is discussed in | c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | c %---------------------------------------------------------------% c orth = .TRUE. 30 continue c call sgemv ('T', n, j-1, one, v, ldv, workd, 1, & zero, workd(n+1), 1) call sgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, & one, resid, 1) c c %----------------------------------------------------------% c | Compute the B-norm of the orthogonalized starting vector | c %----------------------------------------------------------% c call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call scopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd, 1) end if c 40 continue c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then rnorm = sdot (n, resid, 1, workd, 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = snrm2(n, resid, 1) end if c c %--------------------------------------% c | Check for further orthogonalization. | c %--------------------------------------% c if (msglvl .gt. 2) then call svout (logfil, 1, rnorm0, ndigit, & '_getv0: re-orthonalization ; rnorm0 is') call svout (logfil, 1, rnorm, ndigit, & '_getv0: re-orthonalization ; rnorm is') end if c if (rnorm .gt. 0.717*rnorm0) go to 50 c iter = iter + 1 if (iter .le. 5) then c c %-----------------------------------% c | Perform iterative refinement step | c %-----------------------------------% c rnorm0 = rnorm go to 30 else c c %------------------------------------% c | Iterative refinement step "failed" | c %------------------------------------% c do 45 jj = 1, n resid(jj) = zero 45 continue rnorm = zero ierr = -1 end if c 50 continue c if (msglvl .gt. 0) then call svout (logfil, 1, rnorm, ndigit, & '_getv0: B-norm of initial / restarted starting vector') end if if (msglvl .gt. 3) then call svout (logfil, n, resid, ndigit, & '_getv0: initial / restarted starting vector') end if ido = 99 c call second (t1) tgetv0 = tgetv0 + (t1 - t0) c 9000 continue return c c %---------------% c | End of sgetv0 | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dseupd.f000644 001750 001750 00000103200 11266605602 022074 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: dseupd c c\Description: c c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) the corresponding approximate eigenvectors, c c (2) an orthonormal (Lanczos) basis for the associated approximate c invariant subspace, c c (3) Both. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c (Lanczos) basis is always computed. There is an additional storage cost c of n*nev if both are requested (in this case a separate array Z must be c supplied). c c These quantities are obtained from the Lanczos factorization computed c by DSAUPD for the linear operator OP prescribed by the MODE selection c (see IPARAM(7) in DSAUPD documentation.) DSAUPD must be called before c this routine is called. These approximate eigenvalues and vectors are c commonly called Ritz values and Ritz vectors respectively. They are c referred to as such in the comments that follow. The computed orthonormal c basis for the invariant subspace corresponding to these Ritz values is c referred to as a Lanczos basis. c c See documentation in the header of the subroutine DSAUPD for a definition c of OP as well as other terms and the relation of computed Ritz values c and vectors of OP with respect to the given problem A*z = lambda*B*z. c c The approximate eigenvalues of the original problem are returned in c ascending algebraic order. The user may elect to call this routine c once for each desired Ritz vector and store it peripherally if desired. c There is also the option of computing a selected set of these vectors c with a single call. c c\Usage: c call dseupd c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, BMAT, N, WHICH, NEV, TOL, c RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, LWORKL, INFO ) c c RVEC LOGICAL (INPUT) c Specifies whether Ritz vectors corresponding to the Ritz value c approximations to the eigenproblem A*z = lambda*B*z are computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute Ritz vectors. c c HOWMNY Character*1 (INPUT) c Specifies how many Ritz vectors are wanted and the form of Z c the matrix of Ritz vectors. See remark 1 below. c = 'A': compute NEV Ritz vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT/WORKSPACE) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the Ritz vector corresponding to a c Ritz value D(j), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' , SELECT is used as a workspace for c reordering the Ritz values. c c D Double precision array of dimension NEV. (OUTPUT) c On exit, D contains the Ritz value approximations to the c eigenvalues of A*z = lambda*B*z. The values are returned c in ascending order. If IPARAM(7) = 3,4,5 then D represents c the Ritz values of OP computed by dsaupd transformed to c those of the original eigensystem A*z = lambda*B*z. If c IPARAM(7) = 1,2 then the Ritz values of OP are the same c as the those of A*z = lambda*B*z. c c Z Double precision N by NEV array if HOWMNY = 'A'. (OUTPUT) c On exit, Z contains the B-orthonormal Ritz vectors of the c eigensystem A*z = lambda*B*z corresponding to the Ritz c value approximations. c If RVEC = .FALSE. then Z is not referenced. c NOTE: The array Z may be set equal to first NEV columns of the c Arnoldi/Lanczos basis array V computed by DSAUPD . c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ .ge. max( 1, N ). In any case, LDZ .ge. 1. c c SIGMA Double precision (INPUT) c If IPARAM(7) = 3,4,5 represents the shift. Not referenced if c IPARAM(7) = 1 or 2. c c c **** The remaining arguments MUST be the same as for the **** c **** call to DSAUPD that was just completed. **** c c NOTE: The remaining arguments c c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, c WORKD, WORKL, LWORKL, INFO c c must be passed directly to DSEUPD following the last call c to DSAUPD . These arguments MUST NOT BE MODIFIED between c the the last call to DSAUPD and the call to DSEUPD . c c Two of these parameters (WORKL, INFO) are also output parameters: c c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) c WORKL(1:4*ncv) contains information obtained in c dsaupd . They are not changed by dseupd . c WORKL(4*ncv+1:ncv*ncv+8*ncv) holds the c untransformed Ritz values, the computed error estimates, c and the associated eigenvector matrix of H. c c Note: IPNTR(8:10) contains the pointer into WORKL for addresses c of the above information computed by dseupd . c ------------------------------------------------------------- c IPNTR(8): pointer to the NCV RITZ values of the original system. c IPNTR(9): pointer to the NCV corresponding error bounds. c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors c of the tridiagonal matrix T. Only referenced by c dseupd if RVEC = .TRUE. See Remarks. c ------------------------------------------------------------- c c INFO Integer. (OUTPUT) c Error flag on output. c = 0: Normal exit. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV must be greater than NEV and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from trid. eigenvalue calculation; c Information error from LAPACK routine dsteqr . c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3,4,5. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: NEV and WHICH = 'BE' are incompatible. c = -14: DSAUPD did not find any eigenvalues to sufficient c accuracy. c = -15: HOWMNY must be one of 'A' or 'S' if RVEC = .true. c = -16: HOWMNY = 'S' not yet implemented c = -17: DSEUPD got a different count of the number of converged c Ritz values than DSAUPD got. This indicates the user c probably made an error in passing data from DSAUPD to c DSEUPD or that the data was modified before entering c DSEUPD . c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, c 1980. c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", c Computer Physics Communications, 53 (1989), pp 169-179. c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to c Implement the Spectral Transformation", Math. Comp., 48 (1987), c pp 663-673. c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", c SIAM J. Matr. Anal. Apps., January (1993). c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines c for Updating the QR decomposition", ACM TOMS, December 1990, c Volume 16 Number 4, pp 369-377. c c\Remarks c 1. The converged Ritz values are always returned in increasing c (algebraic) order. c c 2. Currently only HOWMNY = 'A' is implemented. It is included at this c stage for the user who wants to incorporate it. c c\Routines called: c dsesrt ARPACK routine that sorts an array X, and applies the c corresponding permutation to a matrix A. c dsortr dsortr ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c dvout ARPACK utility routine that prints vectors. c dgeqr2 LAPACK routine that computes the QR factorization of c a matrix. c dlacpy LAPACK matrix copy routine. c dlamch LAPACK routine that determines machine constants. c dorm2r LAPACK routine that applies an orthogonal matrix in c factored form. c dsteqr LAPACK routine that computes eigenvalues and eigenvectors c of a tridiagonal matrix. c dger Level 2 BLAS rank one update to a matrix. c dcopy Level 1 BLAS that copies one vector to another . c dnrm2 Level 1 BLAS that computes the norm of a vector. c dscal Level 1 BLAS that scales a vector. c dswap Level 1 BLAS that swaps the contents of two vectors. c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Chao Yang Houston, Texas c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/15/93: Version ' 2.1' c c\SCCS Information: @(#) c FILE: seupd.F SID: 2.11 DATE OF SID: 04/10/01 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- subroutine dseupd (rvec , howmny, select, d , & z , ldz , sigma , bmat , & n , which , nev , tol , & resid , ncv , v , ldv , & iparam, ipntr , workd , workl, & lworkl, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat, howmny, which*2 logical rvec integer info, ldz, ldv, lworkl, n, ncv, nev Double precision & sigma, tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(7), ipntr(11) logical select(ncv) Double precision & d(nev) , resid(n) , v(ldv,ncv), & z(ldz, nev), workd(2*n), workl(lworkl) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0 , zero = 0.0D+0 ) c c %---------------% c | Local Scalars | c %---------------% c character type*6 integer bounds , ierr , ih , ihb , ihd , & iq , iw , j , k , ldh , & ldq , mode , msglvl, nconv , next , & ritz , irz , ibd , np , ishift, & leftptr, rghtptr, numcnv, jj Double precision & bnorm2 , rnorm, temp, temp1, eps23 logical reord c c %----------------------% c | External Subroutines | c %----------------------% c external dcopy , dger , dgeqr2 , dlacpy , dorm2r , dscal , & dsesrt , dsteqr , dswap , dvout , ivout , dsortr c c %--------------------% c | External Functions | c %--------------------% c Double precision & dnrm2 , dlamch external dnrm2 , dlamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic min c c %-----------------------% c | Executable Statements | c %-----------------------% c c %------------------------% c | Set default parameters | c %------------------------% c msglvl = mseupd mode = iparam(7) nconv = iparam(5) info = 0 c c %--------------% c | Quick return | c %--------------% c if (nconv .eq. 0) go to 9000 ierr = 0 c if (nconv .le. 0) ierr = -14 if (n .le. 0) ierr = -1 if (nev .le. 0) ierr = -2 if (ncv .le. nev .or. ncv .gt. n) ierr = -3 if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LA' .and. & which .ne. 'SA' .and. & which .ne. 'BE') ierr = -5 if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 if ( (howmny .ne. 'A' .and. & howmny .ne. 'P' .and. & howmny .ne. 'S') .and. rvec ) & ierr = -15 if (rvec .and. howmny .eq. 'S') ierr = -16 c if (rvec .and. lworkl .lt. ncv**2+8*ncv) ierr = -7 c if (mode .eq. 1 .or. mode .eq. 2) then type = 'REGULR' else if (mode .eq. 3 ) then type = 'SHIFTI' else if (mode .eq. 4 ) then type = 'BUCKLE' else if (mode .eq. 5 ) then type = 'CAYLEY' else ierr = -10 end if if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 if (nev .eq. 1 .and. which .eq. 'BE') ierr = -12 c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr go to 9000 end if c c %-------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:2*ncv) := generated tridiagonal matrix H | c | The subdiagonal is stored in workl(2:ncv). | c | The dead spot is workl(1) but upon exiting | c | dsaupd stores the B-norm of the last residual | c | vector in workl(1). We use this !!! | c | workl(2*ncv+1:2*ncv+ncv) := ritz values | c | The wanted values are in the first NCONV spots. | c | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates | c | The wanted values are in the first NCONV spots. | c | NOTE: workl(1:4*ncv) is set by dsaupd and is not | c | modified by dseupd . | c %-------------------------------------------------------% c c %-------------------------------------------------------% c | The following is used and set by dseupd . | c | workl(4*ncv+1:4*ncv+ncv) := used as workspace during | c | computation of the eigenvectors of H. Stores | c | the diagonal of H. Upon EXIT contains the NCV | c | Ritz values of the original system. The first | c | NCONV spots have the wanted values. If MODE = | c | 1 or 2 then will equal workl(2*ncv+1:3*ncv). | c | workl(5*ncv+1:5*ncv+ncv) := used as workspace during | c | computation of the eigenvectors of H. Stores | c | the subdiagonal of H. Upon EXIT contains the | c | NCV corresponding Ritz estimates of the | c | original system. The first NCONV spots have the | c | wanted values. If MODE = 1,2 then will equal | c | workl(3*ncv+1:4*ncv). | c | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is | c | the eigenvector matrix for H as returned by | c | dsteqr . Not referenced if RVEC = .False. | c | Ordering follows that of workl(4*ncv+1:5*ncv) | c | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := | c | Workspace. Needed by dsteqr and by dseupd . | c | GRAND total of NCV*(NCV+8) locations. | c %-------------------------------------------------------% c c ih = ipntr(5) ritz = ipntr(6) bounds = ipntr(7) ldh = ncv ldq = ncv ihd = bounds + ldh ihb = ihd + ldh iq = ihb + ldh iw = iq + ldh*ncv next = iw + 2*ncv ipntr(4) = next ipntr(8) = ihd ipntr(9) = ihb ipntr(10) = iq c c %----------------------------------------% c | irz points to the Ritz values computed | c | by _seigt before exiting _saup2. | c | ibd points to the Ritz estimates | c | computed by _seigt before exiting | c | _saup2. | c %----------------------------------------% c irz = ipntr(11)+ncv ibd = irz+ncv c c c %---------------------------------% c | Set machine dependent constant. | c %---------------------------------% c eps23 = dlamch ('Epsilon-Machine') eps23 = eps23**(2.0D+0 / 3.0D+0 ) c c %---------------------------------------% c | RNORM is B-norm of the RESID(1:N). | c | BNORM2 is the 2 norm of B*RESID(1:N). | c | Upon exit of dsaupd WORKD(1:N) has | c | B*RESID(1:N). | c %---------------------------------------% c rnorm = workl(ih) if (bmat .eq. 'I') then bnorm2 = rnorm else if (bmat .eq. 'G') then bnorm2 = dnrm2 (n, workd, 1) end if c if (msglvl .gt. 2) then call dvout (logfil, ncv, workl(irz), ndigit, & '_seupd: Ritz values passed in from _SAUPD.') call dvout (logfil, ncv, workl(ibd), ndigit, & '_seupd: Ritz estimates passed in from _SAUPD.') end if c if (rvec) then c reord = .false. c c %---------------------------------------------------% c | Use the temporary bounds array to store indices | c | These will be used to mark the select array later | c %---------------------------------------------------% c do 10 j = 1,ncv workl(bounds+j-1) = j select(j) = .false. 10 continue c c %-------------------------------------% c | Select the wanted Ritz values. | c | Sort the Ritz values so that the | c | wanted ones appear at the tailing | c | NEV positions of workl(irr) and | c | workl(iri). Move the corresponding | c | error estimates in workl(bound) | c | accordingly. | c %-------------------------------------% c np = ncv - nev ishift = 0 call dsgets (ishift, which , nev , & np , workl(irz) , workl(bounds), & workl) c if (msglvl .gt. 2) then call dvout (logfil, ncv, workl(irz), ndigit, & '_seupd: Ritz values after calling _SGETS.') call dvout (logfil, ncv, workl(bounds), ndigit, & '_seupd: Ritz value indices after calling _SGETS.') end if c c %-----------------------------------------------------% c | Record indices of the converged wanted Ritz values | c | Mark the select array for possible reordering | c %-----------------------------------------------------% c numcnv = 0 do 11 j = 1,ncv temp1 = max(eps23, abs(workl(irz+ncv-j)) ) jj = workl(bounds + ncv - j) if (numcnv .lt. nconv .and. & workl(ibd+jj-1) .le. tol*temp1) then select(jj) = .true. numcnv = numcnv + 1 if (jj .gt. nev) reord = .true. endif 11 continue c c %-----------------------------------------------------------% c | Check the count (numcnv) of converged Ritz values with | c | the number (nconv) reported by _saupd. If these two | c | are different then there has probably been an error | c | caused by incorrect passing of the _saupd data. | c %-----------------------------------------------------------% c if (msglvl .gt. 2) then call ivout(logfil, 1, numcnv, ndigit, & '_seupd: Number of specified eigenvalues') call ivout(logfil, 1, nconv, ndigit, & '_seupd: Number of "converged" eigenvalues') end if c if (numcnv .ne. nconv) then info = -17 go to 9000 end if c c %-----------------------------------------------------------% c | Call LAPACK routine _steqr to compute the eigenvalues and | c | eigenvectors of the final symmetric tridiagonal matrix H. | c | Initialize the eigenvector matrix Q to the identity. | c %-----------------------------------------------------------% c call dcopy (ncv-1, workl(ih+1), 1, workl(ihb), 1) call dcopy (ncv, workl(ih+ldh), 1, workl(ihd), 1) c call dsteqr ('Identity', ncv, workl(ihd), workl(ihb), & workl(iq) , ldq, workl(iw), ierr) c if (ierr .ne. 0) then info = -8 go to 9000 end if c if (msglvl .gt. 1) then call dcopy (ncv, workl(iq+ncv-1), ldq, workl(iw), 1) call dvout (logfil, ncv, workl(ihd), ndigit, & '_seupd: NCV Ritz values of the final H matrix') call dvout (logfil, ncv, workl(iw), ndigit, & '_seupd: last row of the eigenvector matrix for H') end if c if (reord) then c c %---------------------------------------------% c | Reordered the eigenvalues and eigenvectors | c | computed by _steqr so that the "converged" | c | eigenvalues appear in the first NCONV | c | positions of workl(ihd), and the associated | c | eigenvectors appear in the first NCONV | c | columns. | c %---------------------------------------------% c leftptr = 1 rghtptr = ncv c if (ncv .eq. 1) go to 30 c 20 if (select(leftptr)) then c c %-------------------------------------------% c | Search, from the left, for the first Ritz | c | value that has not converged. | c %-------------------------------------------% c leftptr = leftptr + 1 c else if ( .not. select(rghtptr)) then c c %----------------------------------------------% c | Search, from the right, the first Ritz value | c | that has converged. | c %----------------------------------------------% c rghtptr = rghtptr - 1 c else c c %----------------------------------------------% c | Swap the Ritz value on the left that has not | c | converged with the Ritz value on the right | c | that has converged. Swap the associated | c | eigenvector of the tridiagonal matrix H as | c | well. | c %----------------------------------------------% c temp = workl(ihd+leftptr-1) workl(ihd+leftptr-1) = workl(ihd+rghtptr-1) workl(ihd+rghtptr-1) = temp call dcopy (ncv, workl(iq+ncv*(leftptr-1)), 1, & workl(iw), 1) call dcopy (ncv, workl(iq+ncv*(rghtptr-1)), 1, & workl(iq+ncv*(leftptr-1)), 1) call dcopy (ncv, workl(iw), 1, & workl(iq+ncv*(rghtptr-1)), 1) leftptr = leftptr + 1 rghtptr = rghtptr - 1 c end if c if (leftptr .lt. rghtptr) go to 20 c 30 end if c if (msglvl .gt. 2) then call dvout (logfil, ncv, workl(ihd), ndigit, & '_seupd: The eigenvalues of H--reordered') end if c c %----------------------------------------% c | Load the converged Ritz values into D. | c %----------------------------------------% c call dcopy (nconv, workl(ihd), 1, d, 1) c else c c %-----------------------------------------------------% c | Ritz vectors not required. Load Ritz values into D. | c %-----------------------------------------------------% c call dcopy (nconv, workl(ritz), 1, d, 1) call dcopy (ncv, workl(ritz), 1, workl(ihd), 1) c end if c c %------------------------------------------------------------------% c | Transform the Ritz values and possibly vectors and corresponding | c | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values | c | (and corresponding data) are returned in ascending order. | c %------------------------------------------------------------------% c if (type .eq. 'REGULR') then c c %---------------------------------------------------------% c | Ascending sort of wanted Ritz values, vectors and error | c | bounds. Not necessary if only Ritz values are desired. | c %---------------------------------------------------------% c if (rvec) then call dsesrt ('LA', rvec , nconv, d, ncv, workl(iq), ldq) else call dcopy (ncv, workl(bounds), 1, workl(ihb), 1) end if c else c c %-------------------------------------------------------------% c | * Make a copy of all the Ritz values. | c | * Transform the Ritz values back to the original system. | c | For TYPE = 'SHIFTI' the transformation is | c | lambda = 1/theta + sigma | c | For TYPE = 'BUCKLE' the transformation is | c | lambda = sigma * theta / ( theta - 1 ) | c | For TYPE = 'CAYLEY' the transformation is | c | lambda = sigma * (theta + 1) / (theta - 1 ) | c | where the theta are the Ritz values returned by dsaupd . | c | NOTES: | c | *The Ritz vectors are not affected by the transformation. | c | They are only reordered. | c %-------------------------------------------------------------% c call dcopy (ncv, workl(ihd), 1, workl(iw), 1) if (type .eq. 'SHIFTI') then do 40 k=1, ncv workl(ihd+k-1) = one / workl(ihd+k-1) + sigma 40 continue else if (type .eq. 'BUCKLE') then do 50 k=1, ncv workl(ihd+k-1) = sigma * workl(ihd+k-1) / & (workl(ihd+k-1) - one) 50 continue else if (type .eq. 'CAYLEY') then do 60 k=1, ncv workl(ihd+k-1) = sigma * (workl(ihd+k-1) + one) / & (workl(ihd+k-1) - one) 60 continue end if c c %-------------------------------------------------------------% c | * Store the wanted NCONV lambda values into D. | c | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) | c | into ascending order and apply sort to the NCONV theta | c | values in the transformed system. We will need this to | c | compute Ritz estimates in the original system. | c | * Finally sort the lambda`s into ascending order and apply | c | to Ritz vectors if wanted. Else just sort lambda`s into | c | ascending order. | c | NOTES: | c | *workl(iw:iw+ncv-1) contain the theta ordered so that they | c | match the ordering of the lambda. We`ll use them again for | c | Ritz vector purification. | c %-------------------------------------------------------------% c call dcopy (nconv, workl(ihd), 1, d, 1) call dsortr ('LA', .true., nconv, workl(ihd), workl(iw)) if (rvec) then call dsesrt ('LA', rvec , nconv, d, ncv, workl(iq), ldq) else call dcopy (ncv, workl(bounds), 1, workl(ihb), 1) call dscal (ncv, bnorm2/rnorm, workl(ihb), 1) call dsortr ('LA', .true., nconv, d, workl(ihb)) end if c end if c c %------------------------------------------------% c | Compute the Ritz vectors. Transform the wanted | c | eigenvectors of the symmetric tridiagonal H by | c | the Lanczos basis matrix V. | c %------------------------------------------------% c if (rvec .and. howmny .eq. 'A') then c c %----------------------------------------------------------% c | Compute the QR factorization of the matrix representing | c | the wanted invariant subspace located in the first NCONV | c | columns of workl(iq,ldq). | c %----------------------------------------------------------% c call dgeqr2 (ncv, nconv , workl(iq) , & ldq, workl(iw+ncv), workl(ihb), & ierr) c c %--------------------------------------------------------% c | * Postmultiply V by Q. | c | * Copy the first NCONV columns of VQ into Z. | c | The N by NCONV matrix Z is now a matrix representation | c | of the approximate invariant subspace associated with | c | the Ritz values in workl(ihd). | c %--------------------------------------------------------% c call dorm2r ('Right', 'Notranspose', n , & ncv , nconv , workl(iq), & ldq , workl(iw+ncv), v , & ldv , workd(n+1) , ierr) call dlacpy ('All', n, nconv, v, ldv, z, ldz) c c %-----------------------------------------------------% c | In order to compute the Ritz estimates for the Ritz | c | values in both systems, need the last row of the | c | eigenvector matrix. Remember, it`s in factored form | c %-----------------------------------------------------% c do 65 j = 1, ncv-1 workl(ihb+j-1) = zero 65 continue workl(ihb+ncv-1) = one call dorm2r ('Left', 'Transpose' , ncv , & 1 , nconv , workl(iq) , & ldq , workl(iw+ncv), workl(ihb), & ncv , temp , ierr) c else if (rvec .and. howmny .eq. 'S') then c c Not yet implemented. See remark 2 above. c end if c if (type .eq. 'REGULR' .and. rvec) then c do 70 j=1, ncv workl(ihb+j-1) = rnorm * abs( workl(ihb+j-1) ) 70 continue c else if (type .ne. 'REGULR' .and. rvec) then c c %-------------------------------------------------% c | * Determine Ritz estimates of the theta. | c | If RVEC = .true. then compute Ritz estimates | c | of the theta. | c | If RVEC = .false. then copy Ritz estimates | c | as computed by dsaupd . | c | * Determine Ritz estimates of the lambda. | c %-------------------------------------------------% c call dscal (ncv, bnorm2, workl(ihb), 1) if (type .eq. 'SHIFTI') then c do 80 k=1, ncv workl(ihb+k-1) = abs( workl(ihb+k-1) ) & / workl(iw+k-1)**2 80 continue c else if (type .eq. 'BUCKLE') then c do 90 k=1, ncv workl(ihb+k-1) = sigma * abs( workl(ihb+k-1) ) & / (workl(iw+k-1)-one )**2 90 continue c else if (type .eq. 'CAYLEY') then c do 100 k=1, ncv workl(ihb+k-1) = abs( workl(ihb+k-1) & / workl(iw+k-1)*(workl(iw+k-1)-one) ) 100 continue c end if c end if c if (type .ne. 'REGULR' .and. msglvl .gt. 1) then call dvout (logfil, nconv, d, ndigit, & '_seupd: Untransformed converged Ritz values') call dvout (logfil, nconv, workl(ihb), ndigit, & '_seupd: Ritz estimates of the untransformed Ritz values') else if (msglvl .gt. 1) then call dvout (logfil, nconv, d, ndigit, & '_seupd: Converged Ritz values') call dvout (logfil, nconv, workl(ihb), ndigit, & '_seupd: Associated Ritz estimates') end if c c %-------------------------------------------------% c | Ritz vector purification step. Formally perform | c | one of inverse subspace iteration. Only used | c | for MODE = 3,4,5. See reference 7 | c %-------------------------------------------------% c if (rvec .and. (type .eq. 'SHIFTI' .or. type .eq. 'CAYLEY')) then c do 110 k=0, nconv-1 workl(iw+k) = workl(iq+k*ldq+ncv-1) & / workl(iw+k) 110 continue c else if (rvec .and. type .eq. 'BUCKLE') then c do 120 k=0, nconv-1 workl(iw+k) = workl(iq+k*ldq+ncv-1) & / (workl(iw+k)-one) 120 continue c end if c if (type .ne. 'REGULR') & call dger (n, nconv, one, resid, 1, workl(iw), 1, z, ldz) c 9000 continue c return c c %---------------% c | End of dseupd | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/cnaup2.f000644 001750 001750 00000071035 11266605602 022012 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: cnaup2 c c\Description: c Intermediate level interface called by cnaupd. c c\Usage: c call cnaup2 c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, c Q, LDQ, WORKL, IPNTR, WORKD, RWORK, INFO ) c c\Arguments c c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in cnaupd. c MODE, ISHIFT, MXITER: see the definition of IPARAM in cnaupd. c c NP Integer. (INPUT/OUTPUT) c Contains the number of implicit shifts to apply during c each Arnoldi iteration. c If ISHIFT=1, NP is adjusted dynamically at each iteration c to accelerate convergence and prevent stagnation. c This is also roughly equal to the number of matrix-vector c products (involving the operator OP) per Arnoldi iteration. c The logic for adjusting is contained within the current c subroutine. c If ISHIFT=0, NP is the number of shifts the user needs c to provide via reverse comunication. 0 < NP < NCV-NEV. c NP may be less than NCV-NEV since a leading block of the current c upper Hessenberg matrix has split off and contains "unwanted" c Ritz values. c Upon termination of the IRA iteration, NP contains the number c of "converged" wanted Ritz values. c c IUPD Integer. (INPUT) c IUPD .EQ. 0: use explicit restart instead implicit update. c IUPD .NE. 0: use implicit update. c c V Complex N by (NEV+NP) array. (INPUT/OUTPUT) c The Arnoldi basis vectors are returned in the first NEV c columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Complex (NEV+NP) by (NEV+NP) array. (OUTPUT) c H is used to store the generated upper Hessenberg matrix c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZ Complex array of length NEV+NP. (OUTPUT) c RITZ(1:NEV) contains the computed Ritz values of OP. c c BOUNDS Complex array of length NEV+NP. (OUTPUT) c BOUNDS(1:NEV) contain the error bounds corresponding to c the computed Ritz values. c c Q Complex (NEV+NP) by (NEV+NP) array. (WORKSPACE) c Private (replicated) work array used to accumulate the c rotation in the shift application step. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Complex work array of length at least c (NEV+NP)**2 + 3*(NEV+NP). (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. It is used in shifts calculation, shifts c application and convergence checking. c c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORKD for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Complex work array of length 3*N. (WORKSPACE) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration !!!!!!!!!! c See Data Distribution Note in CNAUPD. c c RWORK Real work array of length NEV+NP ( WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal return. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. c NP returns the number of converged Ritz values. c = 2: No shifts could be applied. c = -8: Error return from LAPACK eigenvalue calculation; c This should never happen. c = -9: Starting vector is zero. c = -9999: Could not build an Arnoldi factorization. c Size that was built in returned in NP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c cgetv0 ARPACK initial vector generation routine. c cnaitr ARPACK Arnoldi factorization routine. c cnapps ARPACK application of implicit shifts routine. c cneigh ARPACK compute Ritz values and error bounds routine. c cngets ARPACK reorder Ritz values and error bounds routine. c csortc ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c cmout ARPACK utility routine that prints matrices c cvout ARPACK utility routine that prints vectors. c svout ARPACK utility routine that prints vectors. c slamch LAPACK routine that determines machine constants. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c ccopy Level 1 BLAS that copies one vector to another . c cdotc Level 1 BLAS that computes the scalar product of two vectors. c cswap Level 1 BLAS that swaps two vectors. c scnrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice Universitya c Chao Yang Houston, Texas c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: naup2.F SID: 2.6 DATE OF SID: 06/01/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c subroutine cnaup2 & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, & q, ldq, workl, ipntr, workd, rwork, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, & n, nev, np Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(13) Complex & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), & resid(n), ritz(nev+np), v(ldv,nev+np), & workd(3*n), workl( (nev+np)*(nev+np+3) ) Real & rwork(nev+np) c c %------------% c | Parameters | c %------------% c Complex & one, zero Real & rzero parameter (one = (1.0E+0, 0.0E+0) , zero = (0.0E+0, 0.0E+0) , & rzero = 0.0E+0 ) c c %---------------% c | Local Scalars | c %---------------% c logical cnorm , getv0, initv , update, ushift integer ierr , iter , kplusp, msglvl, nconv, & nevbef, nev0 , np0 , nptemp, i , & j Complex & cmpnorm Real & rnorm , eps23, rtemp character wprime*2 c save cnorm, getv0, initv , update, ushift, & rnorm, iter , kplusp, msglvl, nconv , & nevbef, nev0 , np0 , eps23 c c c %-----------------------% c | Local array arguments | c %-----------------------% c integer kp(3) c c %----------------------% c | External Subroutines | c %----------------------% c external ccopy, cgetv0, cnaitr, cneigh, cngets, cnapps, & csortc, cswap, cmout, cvout, ivout, second c c %--------------------% c | External functions | c %--------------------% c Complex & cdotc Real & scnrm2, slamch, slapy2 external cdotc, scnrm2, slamch, slapy2 c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic aimag, real , min, max c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c call second (t0) c msglvl = mcaup2 c nev0 = nev np0 = np c c %-------------------------------------% c | kplusp is the bound on the largest | c | Lanczos factorization built. | c | nconv is the current number of | c | "converged" eigenvalues. | c | iter is the counter on the current | c | iteration step. | c %-------------------------------------% c kplusp = nev + np nconv = 0 iter = 0 c c %---------------------------------% c | Get machine dependent constant. | c %---------------------------------% c eps23 = slamch('Epsilon-Machine') eps23 = eps23**(2.0E+0 / 3.0E+0 ) c c %---------------------------------------% c | Set flags for computing the first NEV | c | steps of the Arnoldi factorization. | c %---------------------------------------% c getv0 = .true. update = .false. ushift = .false. cnorm = .false. c if (info .ne. 0) then c c %--------------------------------------------% c | User provides the initial residual vector. | c %--------------------------------------------% c initv = .true. info = 0 else initv = .false. end if end if c c %---------------------------------------------% c | Get a possibly random starting vector and | c | force it into the range of the operator OP. | c %---------------------------------------------% c 10 continue c if (getv0) then call cgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, & ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (rnorm .eq. rzero) then c c %-----------------------------------------% c | The initial vector is zero. Error exit. | c %-----------------------------------------% c info = -9 go to 1100 end if getv0 = .false. ido = 0 end if c c %-----------------------------------% c | Back from reverse communication : | c | continue with update step | c %-----------------------------------% c if (update) go to 20 c c %-------------------------------------------% c | Back from computing user specified shifts | c %-------------------------------------------% c if (ushift) go to 50 c c %-------------------------------------% c | Back from computing residual norm | c | at the end of the current iteration | c %-------------------------------------% c if (cnorm) go to 100 c c %----------------------------------------------------------% c | Compute the first NEV steps of the Arnoldi factorization | c %----------------------------------------------------------% c call cnaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, & h, ldh, ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then np = info mxiter = iter info = -9999 go to 1200 end if c c %--------------------------------------------------------------% c | | c | M A I N ARNOLDI I T E R A T I O N L O O P | c | Each iteration implicitly restarts the Arnoldi | c | factorization in place. | c | | c %--------------------------------------------------------------% c 1000 continue c iter = iter + 1 c if (msglvl .gt. 0) then call ivout (logfil, 1, iter, ndigit, & '_naup2: **** Start of major iteration number ****') end if c c %-----------------------------------------------------------% c | Compute NP additional steps of the Arnoldi factorization. | c | Adjust NP since NEV might have been updated by last call | c | to the shift application routine cnapps. | c %-----------------------------------------------------------% c np = kplusp - nev c if (msglvl .gt. 1) then call ivout (logfil, 1, nev, ndigit, & '_naup2: The length of the current Arnoldi factorization') call ivout (logfil, 1, np, ndigit, & '_naup2: Extend the Arnoldi factorization by') end if c c %-----------------------------------------------------------% c | Compute NP additional steps of the Arnoldi factorization. | c %-----------------------------------------------------------% c ido = 0 20 continue update = .true. c call cnaitr(ido, bmat, n, nev, np, mode, resid, rnorm, & v , ldv , h, ldh, ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then np = info mxiter = iter info = -9999 go to 1200 end if update = .false. c if (msglvl .gt. 1) then call svout (logfil, 1, rnorm, ndigit, & '_naup2: Corresponding B-norm of the residual') end if c c %--------------------------------------------------------% c | Compute the eigenvalues and corresponding error bounds | c | of the current upper Hessenberg matrix. | c %--------------------------------------------------------% c call cneigh (rnorm, kplusp, h, ldh, ritz, bounds, & q, ldq, workl, rwork, ierr) c if (ierr .ne. 0) then info = -8 go to 1200 end if c c %---------------------------------------------------% c | Select the wanted Ritz values and their bounds | c | to be used in the convergence test. | c | The wanted part of the spectrum and corresponding | c | error bounds are in the last NEV loc. of RITZ, | c | and BOUNDS respectively. | c %---------------------------------------------------% c nev = nev0 np = np0 c c %--------------------------------------------------% c | Make a copy of Ritz values and the corresponding | c | Ritz estimates obtained from cneigh. | c %--------------------------------------------------% c call ccopy(kplusp,ritz,1,workl(kplusp**2+1),1) call ccopy(kplusp,bounds,1,workl(kplusp**2+kplusp+1),1) c c %---------------------------------------------------% c | Select the wanted Ritz values and their bounds | c | to be used in the convergence test. | c | The wanted part of the spectrum and corresponding | c | bounds are in the last NEV loc. of RITZ | c | BOUNDS respectively. | c %---------------------------------------------------% c call cngets (ishift, which, nev, np, ritz, bounds) c c %------------------------------------------------------------% c | Convergence test: currently we use the following criteria. | c | The relative accuracy of a Ritz value is considered | c | acceptable if: | c | | c | error_bounds(i) .le. tol*max(eps23, magnitude_of_ritz(i)). | c | | c %------------------------------------------------------------% c nconv = 0 c do 25 i = 1, nev rtemp = max( eps23, slapy2( real (ritz(np+i)), & aimag(ritz(np+i)) ) ) if ( slapy2(real (bounds(np+i)),aimag(bounds(np+i))) & .le. tol*rtemp ) then nconv = nconv + 1 end if 25 continue c if (msglvl .gt. 2) then kp(1) = nev kp(2) = np kp(3) = nconv call ivout (logfil, 3, kp, ndigit, & '_naup2: NEV, NP, NCONV are') call cvout (logfil, kplusp, ritz, ndigit, & '_naup2: The eigenvalues of H') call cvout (logfil, kplusp, bounds, ndigit, & '_naup2: Ritz estimates of the current NCV Ritz values') end if c c %---------------------------------------------------------% c | Count the number of unwanted Ritz values that have zero | c | Ritz estimates. If any Ritz estimates are equal to zero | c | then a leading block of H of order equal to at least | c | the number of Ritz values with zero Ritz estimates has | c | split off. None of these Ritz values may be removed by | c | shifting. Decrease NP the number of shifts to apply. If | c | no shifts may be applied, then prepare to exit | c %---------------------------------------------------------% c nptemp = np do 30 j=1, nptemp if (bounds(j) .eq. zero) then np = np - 1 nev = nev + 1 end if 30 continue c if ( (nconv .ge. nev0) .or. & (iter .gt. mxiter) .or. & (np .eq. 0) ) then c if (msglvl .gt. 4) then call cvout(logfil, kplusp, workl(kplusp**2+1), ndigit, & '_naup2: Eigenvalues computed by _neigh:') call cvout(logfil, kplusp, workl(kplusp**2+kplusp+1), & ndigit, & '_naup2: Ritz estimates computed by _neigh:') end if c c %------------------------------------------------% c | Prepare to exit. Put the converged Ritz values | c | and corresponding bounds in RITZ(1:NCONV) and | c | BOUNDS(1:NCONV) respectively. Then sort. Be | c | careful when NCONV > NP | c %------------------------------------------------% c c %------------------------------------------% c | Use h( 3,1 ) as storage to communicate | c | rnorm to cneupd if needed | c %------------------------------------------% h(3,1) = cmplx(rnorm,rzero) c c %----------------------------------------------% c | Sort Ritz values so that converged Ritz | c | values appear within the first NEV locations | c | of ritz and bounds, and the most desired one | c | appears at the front. | c %----------------------------------------------% c if (which .eq. 'LM') wprime = 'SM' if (which .eq. 'SM') wprime = 'LM' if (which .eq. 'LR') wprime = 'SR' if (which .eq. 'SR') wprime = 'LR' if (which .eq. 'LI') wprime = 'SI' if (which .eq. 'SI') wprime = 'LI' c call csortc(wprime, .true., kplusp, ritz, bounds) c c %--------------------------------------------------% c | Scale the Ritz estimate of each Ritz value | c | by 1 / max(eps23, magnitude of the Ritz value). | c %--------------------------------------------------% c do 35 j = 1, nev0 rtemp = max( eps23, slapy2( real (ritz(j)), & aimag(ritz(j)) ) ) bounds(j) = bounds(j)/rtemp 35 continue c c %---------------------------------------------------% c | Sort the Ritz values according to the scaled Ritz | c | estimates. This will push all the converged ones | c | towards the front of ritz, bounds (in the case | c | when NCONV < NEV.) | c %---------------------------------------------------% c wprime = 'LM' call csortc(wprime, .true., nev0, bounds, ritz) c c %----------------------------------------------% c | Scale the Ritz estimate back to its original | c | value. | c %----------------------------------------------% c do 40 j = 1, nev0 rtemp = max( eps23, slapy2( real (ritz(j)), & aimag(ritz(j)) ) ) bounds(j) = bounds(j)*rtemp 40 continue c c %-----------------------------------------------% c | Sort the converged Ritz values again so that | c | the "threshold" value appears at the front of | c | ritz and bound. | c %-----------------------------------------------% c call csortc(which, .true., nconv, ritz, bounds) c if (msglvl .gt. 1) then call cvout (logfil, kplusp, ritz, ndigit, & '_naup2: Sorted eigenvalues') call cvout (logfil, kplusp, bounds, ndigit, & '_naup2: Sorted ritz estimates.') end if c c %------------------------------------% c | Max iterations have been exceeded. | c %------------------------------------% c if (iter .gt. mxiter .and. nconv .lt. nev0) info = 1 c c %---------------------% c | No shifts to apply. | c %---------------------% c if (np .eq. 0 .and. nconv .lt. nev0) info = 2 c np = nconv go to 1100 c else if ( (nconv .lt. nev0) .and. (ishift .eq. 1) ) then c c %-------------------------------------------------% c | Do not have all the requested eigenvalues yet. | c | To prevent possible stagnation, adjust the size | c | of NEV. | c %-------------------------------------------------% c nevbef = nev nev = nev + min(nconv, np/2) if (nev .eq. 1 .and. kplusp .ge. 6) then nev = kplusp / 2 else if (nev .eq. 1 .and. kplusp .gt. 3) then nev = 2 end if np = kplusp - nev c c %---------------------------------------% c | If the size of NEV was just increased | c | resort the eigenvalues. | c %---------------------------------------% c if (nevbef .lt. nev) & call cngets (ishift, which, nev, np, ritz, bounds) c end if c if (msglvl .gt. 0) then call ivout (logfil, 1, nconv, ndigit, & '_naup2: no. of "converged" Ritz values at this iter.') if (msglvl .gt. 1) then kp(1) = nev kp(2) = np call ivout (logfil, 2, kp, ndigit, & '_naup2: NEV and NP are') call cvout (logfil, nev, ritz(np+1), ndigit, & '_naup2: "wanted" Ritz values ') call cvout (logfil, nev, bounds(np+1), ndigit, & '_naup2: Ritz estimates of the "wanted" values ') end if end if c if (ishift .eq. 0) then c c %-------------------------------------------------------% c | User specified shifts: pop back out to get the shifts | c | and return them in the first 2*NP locations of WORKL. | c %-------------------------------------------------------% c ushift = .true. ido = 3 go to 9000 end if 50 continue ushift = .false. c if ( ishift .ne. 1 ) then c c %----------------------------------% c | Move the NP shifts from WORKL to | c | RITZ, to free up WORKL | c | for non-exact shift case. | c %----------------------------------% c call ccopy (np, workl, 1, ritz, 1) end if c if (msglvl .gt. 2) then call ivout (logfil, 1, np, ndigit, & '_naup2: The number of shifts to apply ') call cvout (logfil, np, ritz, ndigit, & '_naup2: values of the shifts') if ( ishift .eq. 1 ) & call cvout (logfil, np, bounds, ndigit, & '_naup2: Ritz estimates of the shifts') end if c c %---------------------------------------------------------% c | Apply the NP implicit shifts by QR bulge chasing. | c | Each shift is applied to the whole upper Hessenberg | c | matrix H. | c | The first 2*N locations of WORKD are used as workspace. | c %---------------------------------------------------------% c call cnapps (n, nev, np, ritz, v, ldv, & h, ldh, resid, q, ldq, workl, workd) c c %---------------------------------------------% c | Compute the B-norm of the updated residual. | c | Keep B*RESID in WORKD(1:N) to be used in | c | the first step of the next call to cnaitr. | c %---------------------------------------------% c cnorm = .true. call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call ccopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 c c %----------------------------------% c | Exit in order to compute B*RESID | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call ccopy (n, resid, 1, workd, 1) end if c 100 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(1:N) := B*RESID | c %----------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then cmpnorm = cdotc (n, resid, 1, workd, 1) rnorm = sqrt(slapy2(real (cmpnorm),aimag(cmpnorm))) else if (bmat .eq. 'I') then rnorm = scnrm2(n, resid, 1) end if cnorm = .false. c if (msglvl .gt. 2) then call svout (logfil, 1, rnorm, ndigit, & '_naup2: B-norm of residual for compressed factorization') call cmout (logfil, nev, nev, h, ldh, ndigit, & '_naup2: Compressed upper Hessenberg matrix H') end if c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 1100 continue c mxiter = iter nev = nconv c 1200 continue ido = 99 c c %------------% c | Error Exit | c %------------% c call second (t1) tcaup2 = t1 - t0 c 9000 continue c c %---------------% c | End of cnaup2 | c %---------------% c return end getdp-2.4.2-source/contrib/Arpack/iset.f000644 001750 001750 00000000505 11266605602 021560 0ustar00geuzainegeuzaine000000 000000 c c----------------------------------------------------------------------- c c Only work with increment equal to 1 right now. c subroutine iset (n, value, array, inc) c integer n, value, inc integer array(*) c do 10 i = 1, n array(i) = value 10 continue c return end getdp-2.4.2-source/contrib/Arpack/stat.h000644 001750 001750 00000001713 11266605602 021573 0ustar00geuzainegeuzaine000000 000000 c %--------------------------------% c | See stat.doc for documentation | c %--------------------------------% c c\SCCS Information: @(#) c FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 c real t0, t1, t2, t3, t4, t5 save t0, t1, t2, t3, t4, t5 c integer nopx, nbx, nrorth, nitref, nrstrt real tsaupd, tsaup2, tsaitr, tseigt, tsgets, tsapps, tsconv, & tnaupd, tnaup2, tnaitr, tneigh, tngets, tnapps, tnconv, & tcaupd, tcaup2, tcaitr, tceigh, tcgets, tcapps, tcconv, & tmvopx, tmvbx, tgetv0, titref, trvec common /timing/ & nopx, nbx, nrorth, nitref, nrstrt, & tsaupd, tsaup2, tsaitr, tseigt, tsgets, tsapps, tsconv, & tnaupd, tnaup2, tnaitr, tneigh, tngets, tnapps, tnconv, & tcaupd, tcaup2, tcaitr, tceigh, tcgets, tcapps, tcconv, & tmvopx, tmvbx, tgetv0, titref, trvec getdp-2.4.2-source/contrib/Arpack/znaup2.f000644 001750 001750 00000071342 11266605602 022042 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: znaup2 c c\Description: c Intermediate level interface called by znaupd . c c\Usage: c call znaup2 c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, c Q, LDQ, WORKL, IPNTR, WORKD, RWORK, INFO ) c c\Arguments c c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in znaupd . c MODE, ISHIFT, MXITER: see the definition of IPARAM in znaupd . c c NP Integer. (INPUT/OUTPUT) c Contains the number of implicit shifts to apply during c each Arnoldi iteration. c If ISHIFT=1, NP is adjusted dynamically at each iteration c to accelerate convergence and prevent stagnation. c This is also roughly equal to the number of matrix-vector c products (involving the operator OP) per Arnoldi iteration. c The logic for adjusting is contained within the current c subroutine. c If ISHIFT=0, NP is the number of shifts the user needs c to provide via reverse comunication. 0 < NP < NCV-NEV. c NP may be less than NCV-NEV since a leading block of the current c upper Hessenberg matrix has split off and contains "unwanted" c Ritz values. c Upon termination of the IRA iteration, NP contains the number c of "converged" wanted Ritz values. c c IUPD Integer. (INPUT) c IUPD .EQ. 0: use explicit restart instead implicit update. c IUPD .NE. 0: use implicit update. c c V Complex*16 N by (NEV+NP) array. (INPUT/OUTPUT) c The Arnoldi basis vectors are returned in the first NEV c columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Complex*16 (NEV+NP) by (NEV+NP) array. (OUTPUT) c H is used to store the generated upper Hessenberg matrix c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZ Complex*16 array of length NEV+NP. (OUTPUT) c RITZ(1:NEV) contains the computed Ritz values of OP. c c BOUNDS Complex*16 array of length NEV+NP. (OUTPUT) c BOUNDS(1:NEV) contain the error bounds corresponding to c the computed Ritz values. c c Q Complex*16 (NEV+NP) by (NEV+NP) array. (WORKSPACE) c Private (replicated) work array used to accumulate the c rotation in the shift application step. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Complex*16 work array of length at least c (NEV+NP)**2 + 3*(NEV+NP). (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. It is used in shifts calculation, shifts c application and convergence checking. c c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORKD for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Complex*16 work array of length 3*N. (WORKSPACE) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration !!!!!!!!!! c See Data Distribution Note in ZNAUPD . c c RWORK Double precision work array of length NEV+NP ( WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal return. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. c NP returns the number of converged Ritz values. c = 2: No shifts could be applied. c = -8: Error return from LAPACK eigenvalue calculation; c This should never happen. c = -9: Starting vector is zero. c = -9999: Could not build an Arnoldi factorization. c Size that was built in returned in NP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex*16 c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c zgetv0 ARPACK initial vector generation routine. c znaitr ARPACK Arnoldi factorization routine. c znapps ARPACK application of implicit shifts routine. c zneigh ARPACK compute Ritz values and error bounds routine. c zngets ARPACK reorder Ritz values and error bounds routine. c zsortc ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c zmout ARPACK utility routine that prints matrices c zvout ARPACK utility routine that prints vectors. c dvout ARPACK utility routine that prints vectors. c dlamch LAPACK routine that determines machine constants. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c zcopy Level 1 BLAS that copies one vector to another . c zdotc Level 1 BLAS that computes the scalar product of two vectors. c zswap Level 1 BLAS that swaps two vectors. c dznrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice Universitya c Chao Yang Houston, Texas c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: naup2.F SID: 2.6 DATE OF SID: 06/01/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c subroutine znaup2 & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, & q, ldq, workl, ipntr, workd, rwork, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, & n, nev, np Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(13) Complex*16 & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), & resid(n), ritz(nev+np), v(ldv,nev+np), & workd(3*n), workl( (nev+np)*(nev+np+3) ) Double precision & rwork(nev+np) c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero Double precision & rzero parameter (one = (1.0D+0, 0.0D+0) , zero = (0.0D+0, 0.0D+0) , & rzero = 0.0D+0 ) c c %---------------% c | Local Scalars | c %---------------% c logical cnorm , getv0, initv , update, ushift integer ierr , iter , kplusp, msglvl, nconv, & nevbef, nev0 , np0 , nptemp, i , & j Complex*16 & cmpnorm Double precision & rnorm , eps23, rtemp character wprime*2 c save cnorm, getv0, initv , update, ushift, & rnorm, iter , kplusp, msglvl, nconv , & nevbef, nev0 , np0 , eps23 c c c %-----------------------% c | Local array arguments | c %-----------------------% c integer kp(3) c c %----------------------% c | External Subroutines | c %----------------------% c external zcopy , zgetv0 , znaitr , zneigh , zngets , znapps , & zsortc , zswap , zmout , zvout , ivout, second c c %--------------------% c | External functions | c %--------------------% c Complex*16 & zdotc Double precision & dznrm2 , dlamch , dlapy2 external zdotc , dznrm2 , dlamch , dlapy2 c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic dimag , dble , min, max c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c call second (t0) c msglvl = mcaup2 c nev0 = nev np0 = np c c %-------------------------------------% c | kplusp is the bound on the largest | c | Lanczos factorization built. | c | nconv is the current number of | c | "converged" eigenvalues. | c | iter is the counter on the current | c | iteration step. | c %-------------------------------------% c kplusp = nev + np nconv = 0 iter = 0 c c %---------------------------------% c | Get machine dependent constant. | c %---------------------------------% c eps23 = dlamch ('Epsilon-Machine') eps23 = eps23**(2.0D+0 / 3.0D+0 ) c c %---------------------------------------% c | Set flags for computing the first NEV | c | steps of the Arnoldi factorization. | c %---------------------------------------% c getv0 = .true. update = .false. ushift = .false. cnorm = .false. c if (info .ne. 0) then c c %--------------------------------------------% c | User provides the initial residual vector. | c %--------------------------------------------% c initv = .true. info = 0 else initv = .false. end if end if c c %---------------------------------------------% c | Get a possibly random starting vector and | c | force it into the range of the operator OP. | c %---------------------------------------------% c 10 continue c if (getv0) then call zgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, & ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (rnorm .eq. rzero) then c c %-----------------------------------------% c | The initial vector is zero. Error exit. | c %-----------------------------------------% c info = -9 go to 1100 end if getv0 = .false. ido = 0 end if c c %-----------------------------------% c | Back from reverse communication : | c | continue with update step | c %-----------------------------------% c if (update) go to 20 c c %-------------------------------------------% c | Back from computing user specified shifts | c %-------------------------------------------% c if (ushift) go to 50 c c %-------------------------------------% c | Back from computing residual norm | c | at the end of the current iteration | c %-------------------------------------% c if (cnorm) go to 100 c c %----------------------------------------------------------% c | Compute the first NEV steps of the Arnoldi factorization | c %----------------------------------------------------------% c call znaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, & h, ldh, ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then np = info mxiter = iter info = -9999 go to 1200 end if c c %--------------------------------------------------------------% c | | c | M A I N ARNOLDI I T E R A T I O N L O O P | c | Each iteration implicitly restarts the Arnoldi | c | factorization in place. | c | | c %--------------------------------------------------------------% c 1000 continue c iter = iter + 1 c if (msglvl .gt. 0) then call ivout (logfil, 1, iter, ndigit, & '_naup2: **** Start of major iteration number ****') end if c c %-----------------------------------------------------------% c | Compute NP additional steps of the Arnoldi factorization. | c | Adjust NP since NEV might have been updated by last call | c | to the shift application routine znapps . | c %-----------------------------------------------------------% c np = kplusp - nev c if (msglvl .gt. 1) then call ivout (logfil, 1, nev, ndigit, & '_naup2: The length of the current Arnoldi factorization') call ivout (logfil, 1, np, ndigit, & '_naup2: Extend the Arnoldi factorization by') end if c c %-----------------------------------------------------------% c | Compute NP additional steps of the Arnoldi factorization. | c %-----------------------------------------------------------% c ido = 0 20 continue update = .true. c call znaitr (ido, bmat, n, nev, np, mode, resid, rnorm, & v , ldv , h, ldh, ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then np = info mxiter = iter info = -9999 go to 1200 end if update = .false. c if (msglvl .gt. 1) then call dvout (logfil, 1, rnorm, ndigit, & '_naup2: Corresponding B-norm of the residual') end if c c %--------------------------------------------------------% c | Compute the eigenvalues and corresponding error bounds | c | of the current upper Hessenberg matrix. | c %--------------------------------------------------------% c call zneigh (rnorm, kplusp, h, ldh, ritz, bounds, & q, ldq, workl, rwork, ierr) c if (ierr .ne. 0) then info = -8 go to 1200 end if c c %---------------------------------------------------% c | Select the wanted Ritz values and their bounds | c | to be used in the convergence test. | c | The wanted part of the spectrum and corresponding | c | error bounds are in the last NEV loc. of RITZ, | c | and BOUNDS respectively. | c %---------------------------------------------------% c nev = nev0 np = np0 c c %--------------------------------------------------% c | Make a copy of Ritz values and the corresponding | c | Ritz estimates obtained from zneigh . | c %--------------------------------------------------% c call zcopy (kplusp,ritz,1,workl(kplusp**2+1),1) call zcopy (kplusp,bounds,1,workl(kplusp**2+kplusp+1),1) c c %---------------------------------------------------% c | Select the wanted Ritz values and their bounds | c | to be used in the convergence test. | c | The wanted part of the spectrum and corresponding | c | bounds are in the last NEV loc. of RITZ | c | BOUNDS respectively. | c %---------------------------------------------------% c call zngets (ishift, which, nev, np, ritz, bounds) c c %------------------------------------------------------------% c | Convergence test: currently we use the following criteria. | c | The relative accuracy of a Ritz value is considered | c | acceptable if: | c | | c | error_bounds(i) .le. tol*max(eps23, magnitude_of_ritz(i)). | c | | c %------------------------------------------------------------% c nconv = 0 c do 25 i = 1, nev rtemp = max( eps23, dlapy2 ( dble (ritz(np+i)), & dimag (ritz(np+i)) ) ) if ( dlapy2 (dble (bounds(np+i)),dimag (bounds(np+i))) & .le. tol*rtemp ) then nconv = nconv + 1 end if 25 continue c if (msglvl .gt. 2) then kp(1) = nev kp(2) = np kp(3) = nconv call ivout (logfil, 3, kp, ndigit, & '_naup2: NEV, NP, NCONV are') call zvout (logfil, kplusp, ritz, ndigit, & '_naup2: The eigenvalues of H') call zvout (logfil, kplusp, bounds, ndigit, & '_naup2: Ritz estimates of the current NCV Ritz values') end if c c %---------------------------------------------------------% c | Count the number of unwanted Ritz values that have zero | c | Ritz estimates. If any Ritz estimates are equal to zero | c | then a leading block of H of order equal to at least | c | the number of Ritz values with zero Ritz estimates has | c | split off. None of these Ritz values may be removed by | c | shifting. Decrease NP the number of shifts to apply. If | c | no shifts may be applied, then prepare to exit | c %---------------------------------------------------------% c nptemp = np do 30 j=1, nptemp if (bounds(j) .eq. zero) then np = np - 1 nev = nev + 1 end if 30 continue c if ( (nconv .ge. nev0) .or. & (iter .gt. mxiter) .or. & (np .eq. 0) ) then c if (msglvl .gt. 4) then call zvout (logfil, kplusp, workl(kplusp**2+1), ndigit, & '_naup2: Eigenvalues computed by _neigh:') call zvout (logfil, kplusp, workl(kplusp**2+kplusp+1), & ndigit, & '_naup2: Ritz estimates computed by _neigh:') end if c c %------------------------------------------------% c | Prepare to exit. Put the converged Ritz values | c | and corresponding bounds in RITZ(1:NCONV) and | c | BOUNDS(1:NCONV) respectively. Then sort. Be | c | careful when NCONV > NP | c %------------------------------------------------% c c %------------------------------------------% c | Use h( 3,1 ) as storage to communicate | c | rnorm to zneupd if needed | c %------------------------------------------% h(3,1) = dcmplx (rnorm,rzero) c c %----------------------------------------------% c | Sort Ritz values so that converged Ritz | c | values appear within the first NEV locations | c | of ritz and bounds, and the most desired one | c | appears at the front. | c %----------------------------------------------% c if (which .eq. 'LM') wprime = 'SM' if (which .eq. 'SM') wprime = 'LM' if (which .eq. 'LR') wprime = 'SR' if (which .eq. 'SR') wprime = 'LR' if (which .eq. 'LI') wprime = 'SI' if (which .eq. 'SI') wprime = 'LI' c call zsortc (wprime, .true., kplusp, ritz, bounds) c c %--------------------------------------------------% c | Scale the Ritz estimate of each Ritz value | c | by 1 / max(eps23, magnitude of the Ritz value). | c %--------------------------------------------------% c do 35 j = 1, nev0 rtemp = max( eps23, dlapy2 ( dble (ritz(j)), & dimag (ritz(j)) ) ) bounds(j) = bounds(j)/rtemp 35 continue c c %---------------------------------------------------% c | Sort the Ritz values according to the scaled Ritz | c | estimates. This will push all the converged ones | c | towards the front of ritz, bounds (in the case | c | when NCONV < NEV.) | c %---------------------------------------------------% c wprime = 'LM' call zsortc (wprime, .true., nev0, bounds, ritz) c c %----------------------------------------------% c | Scale the Ritz estimate back to its original | c | value. | c %----------------------------------------------% c do 40 j = 1, nev0 rtemp = max( eps23, dlapy2 ( dble (ritz(j)), & dimag (ritz(j)) ) ) bounds(j) = bounds(j)*rtemp 40 continue c c %-----------------------------------------------% c | Sort the converged Ritz values again so that | c | the "threshold" value appears at the front of | c | ritz and bound. | c %-----------------------------------------------% c call zsortc (which, .true., nconv, ritz, bounds) c if (msglvl .gt. 1) then call zvout (logfil, kplusp, ritz, ndigit, & '_naup2: Sorted eigenvalues') call zvout (logfil, kplusp, bounds, ndigit, & '_naup2: Sorted ritz estimates.') end if c c %------------------------------------% c | Max iterations have been exceeded. | c %------------------------------------% c if (iter .gt. mxiter .and. nconv .lt. nev0) info = 1 c c %---------------------% c | No shifts to apply. | c %---------------------% c if (np .eq. 0 .and. nconv .lt. nev0) info = 2 c np = nconv go to 1100 c else if ( (nconv .lt. nev0) .and. (ishift .eq. 1) ) then c c %-------------------------------------------------% c | Do not have all the requested eigenvalues yet. | c | To prevent possible stagnation, adjust the size | c | of NEV. | c %-------------------------------------------------% c nevbef = nev nev = nev + min(nconv, np/2) if (nev .eq. 1 .and. kplusp .ge. 6) then nev = kplusp / 2 else if (nev .eq. 1 .and. kplusp .gt. 3) then nev = 2 end if np = kplusp - nev c c %---------------------------------------% c | If the size of NEV was just increased | c | resort the eigenvalues. | c %---------------------------------------% c if (nevbef .lt. nev) & call zngets (ishift, which, nev, np, ritz, bounds) c end if c if (msglvl .gt. 0) then call ivout (logfil, 1, nconv, ndigit, & '_naup2: no. of "converged" Ritz values at this iter.') if (msglvl .gt. 1) then kp(1) = nev kp(2) = np call ivout (logfil, 2, kp, ndigit, & '_naup2: NEV and NP are') call zvout (logfil, nev, ritz(np+1), ndigit, & '_naup2: "wanted" Ritz values ') call zvout (logfil, nev, bounds(np+1), ndigit, & '_naup2: Ritz estimates of the "wanted" values ') end if end if c if (ishift .eq. 0) then c c %-------------------------------------------------------% c | User specified shifts: pop back out to get the shifts | c | and return them in the first 2*NP locations of WORKL. | c %-------------------------------------------------------% c ushift = .true. ido = 3 go to 9000 end if 50 continue ushift = .false. c if ( ishift .ne. 1 ) then c c %----------------------------------% c | Move the NP shifts from WORKL to | c | RITZ, to free up WORKL | c | for non-exact shift case. | c %----------------------------------% c call zcopy (np, workl, 1, ritz, 1) end if c if (msglvl .gt. 2) then call ivout (logfil, 1, np, ndigit, & '_naup2: The number of shifts to apply ') call zvout (logfil, np, ritz, ndigit, & '_naup2: values of the shifts') if ( ishift .eq. 1 ) & call zvout (logfil, np, bounds, ndigit, & '_naup2: Ritz estimates of the shifts') end if c c %---------------------------------------------------------% c | Apply the NP implicit shifts by QR bulge chasing. | c | Each shift is applied to the whole upper Hessenberg | c | matrix H. | c | The first 2*N locations of WORKD are used as workspace. | c %---------------------------------------------------------% c call znapps (n, nev, np, ritz, v, ldv, & h, ldh, resid, q, ldq, workl, workd) c c %---------------------------------------------% c | Compute the B-norm of the updated residual. | c | Keep B*RESID in WORKD(1:N) to be used in | c | the first step of the next call to znaitr . | c %---------------------------------------------% c cnorm = .true. call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call zcopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 c c %----------------------------------% c | Exit in order to compute B*RESID | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call zcopy (n, resid, 1, workd, 1) end if c 100 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(1:N) := B*RESID | c %----------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then cmpnorm = zdotc (n, resid, 1, workd, 1) rnorm = sqrt(dlapy2 (dble (cmpnorm),dimag (cmpnorm))) else if (bmat .eq. 'I') then rnorm = dznrm2 (n, resid, 1) end if cnorm = .false. c if (msglvl .gt. 2) then call dvout (logfil, 1, rnorm, ndigit, & '_naup2: B-norm of residual for compressed factorization') call zmout (logfil, nev, nev, h, ldh, ndigit, & '_naup2: Compressed upper Hessenberg matrix H') end if c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 1100 continue c mxiter = iter nev = nconv c 1200 continue ido = 99 c c %------------% c | Error Exit | c %------------% c call second (t1) tcaup2 = t1 - t0 c 9000 continue c c %---------------% c | End of znaup2 | c %---------------% c return end getdp-2.4.2-source/contrib/Arpack/cngets.f000644 001750 001750 00000012673 11266605602 022110 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: cngets c c\Description: c Given the eigenvalues of the upper Hessenberg matrix H, c computes the NP shifts AMU that are zeros of the polynomial of c degree NP which filters out components of the unwanted eigenvectors c corresponding to the AMU's based on some given criteria. c c NOTE: call this even in the case of user specified shifts in order c to sort the eigenvalues, and error bounds of H for later use. c c\Usage: c call cngets c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS ) c c\Arguments c ISHIFT Integer. (INPUT) c Method for selecting the implicit shifts at each iteration. c ISHIFT = 0: user specified shifts c ISHIFT = 1: exact shift with respect to the matrix H. c c WHICH Character*2. (INPUT) c Shift selection criteria. c 'LM' -> want the KEV eigenvalues of largest magnitude. c 'SM' -> want the KEV eigenvalues of smallest magnitude. c 'LR' -> want the KEV eigenvalues of largest REAL part. c 'SR' -> want the KEV eigenvalues of smallest REAL part. c 'LI' -> want the KEV eigenvalues of largest imaginary part. c 'SI' -> want the KEV eigenvalues of smallest imaginary part. c c KEV Integer. (INPUT) c The number of desired eigenvalues. c c NP Integer. (INPUT) c The number of shifts to compute. c c RITZ Complex array of length KEV+NP. (INPUT/OUTPUT) c On INPUT, RITZ contains the the eigenvalues of H. c On OUTPUT, RITZ are sorted so that the unwanted c eigenvalues are in the first NP locations and the wanted c portion is in the last KEV locations. When exact shifts are c selected, the unwanted part corresponds to the shifts to c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues c are further sorted so that the ones with largest Ritz values c are first. c c BOUNDS Complex array of length KEV+NP. (INPUT/OUTPUT) c Error bounds corresponding to the ordering in RITZ. c c c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex c c\Routines called: c csortc ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c cvout ARPACK utility routine that prints vectors. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ngets.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c 1. This routine does not keep complex conjugate pairs of c eigenvalues together. c c\EndLib c c----------------------------------------------------------------------- c subroutine cngets ( ishift, which, kev, np, ritz, bounds) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which integer ishift, kev, np c c %-----------------% c | Array Arguments | c %-----------------% c Complex & bounds(kev+np), ritz(kev+np) c c %------------% c | Parameters | c %------------% c Complex & one, zero parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0)) c c %---------------% c | Local Scalars | c %---------------% c integer msglvl c c %----------------------% c | External Subroutines | c %----------------------% c external cvout, csortc, second c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mcgets c call csortc (which, .true., kev+np, ritz, bounds) c if ( ishift .eq. 1 ) then c c %-------------------------------------------------------% c | Sort the unwanted Ritz values used as shifts so that | c | the ones with largest Ritz estimates are first | c | This will tend to minimize the effects of the | c | forward instability of the iteration when the shifts | c | are applied in subroutine cnapps. | c | Be careful and use 'SM' since we want to sort BOUNDS! | c %-------------------------------------------------------% c call csortc ( 'SM', .true., np, bounds, ritz ) c end if c call second (t1) tcgets = tcgets + (t1 - t0) c if (msglvl .gt. 0) then call ivout (logfil, 1, kev, ndigit, '_ngets: KEV is') call ivout (logfil, 1, np, ndigit, '_ngets: NP is') call cvout (logfil, kev+np, ritz, ndigit, & '_ngets: Eigenvalues of current H matrix ') call cvout (logfil, kev+np, bounds, ndigit, & '_ngets: Ritz estimates of the current KEV+NP Ritz values') end if c return c c %---------------% c | End of cngets | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dnconv.f000644 001750 001750 00000007765 11266605602 022122 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dnconv c c\Description: c Convergence testing for the nonsymmetric Arnoldi eigenvalue routine. c c\Usage: c call dnconv c ( N, RITZR, RITZI, BOUNDS, TOL, NCONV ) c c\Arguments c N Integer. (INPUT) c Number of Ritz values to check for convergence. c c RITZR, Double precision arrays of length N. (INPUT) c RITZI Real and imaginary parts of the Ritz values to be checked c for convergence. c BOUNDS Double precision array of length N. (INPUT) c Ritz estimates for the Ritz values in RITZR and RITZI. c c TOL Double precision scalar. (INPUT) c Desired backward error for a Ritz value to be considered c "converged". c c NCONV Integer scalar. (OUTPUT) c Number of "converged" Ritz values. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c second ARPACK utility routine for timing. c dlamch LAPACK routine that determines machine constants. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.1' c c\SCCS Information: @(#) c FILE: nconv.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c 1. xxxx c c\EndLib c c----------------------------------------------------------------------- c subroutine dnconv (n, ritzr, ritzi, bounds, tol, nconv) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer n, nconv Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% Double precision & ritzr(n), ritzi(n), bounds(n) c c %---------------% c | Local Scalars | c %---------------% c integer i Double precision & temp, eps23 c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlapy2, dlamch external dlapy2, dlamch c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------------------% c | Convergence test: unlike in the symmetric code, I am not | c | using things like refined error bounds and gap condition | c | because I don't know the exact equivalent concept. | c | | c | Instead the i-th Ritz value is considered "converged" when: | c | | c | bounds(i) .le. ( TOL * | ritz | ) | c | | c | for some appropriate choice of norm. | c %-------------------------------------------------------------% c call second (t0) c c %---------------------------------% c | Get machine dependent constant. | c %---------------------------------% c eps23 = dlamch('Epsilon-Machine') eps23 = eps23**(2.0D+0 / 3.0D+0) c nconv = 0 do 20 i = 1, n temp = max( eps23, dlapy2( ritzr(i), ritzi(i) ) ) if (bounds(i) .le. tol*temp) nconv = nconv + 1 20 continue c call second (t1) tnconv = tnconv + (t1 - t0) c return c c %---------------% c | End of dnconv | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/ssgets.f000644 001750 001750 00000016341 11266605602 022131 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: ssgets c c\Description: c Given the eigenvalues of the symmetric tridiagonal matrix H, c computes the NP shifts AMU that are zeros of the polynomial of c degree NP which filters out components of the unwanted eigenvectors c corresponding to the AMU's based on some given criteria. c c NOTE: This is called even in the case of user specified shifts in c order to sort the eigenvalues, and error bounds of H for later use. c c\Usage: c call ssgets c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS, SHIFTS ) c c\Arguments c ISHIFT Integer. (INPUT) c Method for selecting the implicit shifts at each iteration. c ISHIFT = 0: user specified shifts c ISHIFT = 1: exact shift with respect to the matrix H. c c WHICH Character*2. (INPUT) c Shift selection criteria. c 'LM' -> KEV eigenvalues of largest magnitude are retained. c 'SM' -> KEV eigenvalues of smallest magnitude are retained. c 'LA' -> KEV eigenvalues of largest value are retained. c 'SA' -> KEV eigenvalues of smallest value are retained. c 'BE' -> KEV eigenvalues, half from each end of the spectrum. c If KEV is odd, compute one more from the high end. c c KEV Integer. (INPUT) c KEV+NP is the size of the matrix H. c c NP Integer. (INPUT) c Number of implicit shifts to be computed. c c RITZ Real array of length KEV+NP. (INPUT/OUTPUT) c On INPUT, RITZ contains the eigenvalues of H. c On OUTPUT, RITZ are sorted so that the unwanted eigenvalues c are in the first NP locations and the wanted part is in c the last KEV locations. When exact shifts are selected, the c unwanted part corresponds to the shifts to be applied. c c BOUNDS Real array of length KEV+NP. (INPUT/OUTPUT) c Error bounds corresponding to the ordering in RITZ. c c SHIFTS Real array of length NP. (INPUT/OUTPUT) c On INPUT: contains the user specified shifts if ISHIFT = 0. c On OUTPUT: contains the shifts sorted into decreasing order c of magnitude with respect to the Ritz estimates contained in c BOUNDS. If ISHIFT = 0, SHIFTS is not modified on exit. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c ssortr ARPACK utility sorting routine. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c svout ARPACK utility routine that prints vectors. c scopy Level 1 BLAS that copies one vector to another. c sswap Level 1 BLAS that swaps the contents of two vectors. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/93: Version ' 2.1' c c\SCCS Information: @(#) c FILE: sgets.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 c c\Remarks c c\EndLib c c----------------------------------------------------------------------- c subroutine ssgets ( ishift, which, kev, np, ritz, bounds, shifts ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which integer ishift, kev, np c c %-----------------% c | Array Arguments | c %-----------------% c Real & bounds(kev+np), ritz(kev+np), shifts(np) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %---------------% c | Local Scalars | c %---------------% c integer kevd2, msglvl c c %----------------------% c | External Subroutines | c %----------------------% c external sswap, scopy, ssortr, second c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic max, min c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = msgets c if (which .eq. 'BE') then c c %-----------------------------------------------------% c | Both ends of the spectrum are requested. | c | Sort the eigenvalues into algebraically increasing | c | order first then swap high end of the spectrum next | c | to low end in appropriate locations. | c | NOTE: when np < floor(kev/2) be careful not to swap | c | overlapping locations. | c %-----------------------------------------------------% c call ssortr ('LA', .true., kev+np, ritz, bounds) kevd2 = kev / 2 if ( kev .gt. 1 ) then call sswap ( min(kevd2,np), ritz, 1, & ritz( max(kevd2,np)+1 ), 1) call sswap ( min(kevd2,np), bounds, 1, & bounds( max(kevd2,np)+1 ), 1) end if c else c c %----------------------------------------------------% c | LM, SM, LA, SA case. | c | Sort the eigenvalues of H into the desired order | c | and apply the resulting order to BOUNDS. | c | The eigenvalues are sorted so that the wanted part | c | are always in the last KEV locations. | c %----------------------------------------------------% c call ssortr (which, .true., kev+np, ritz, bounds) end if c if (ishift .eq. 1 .and. np .gt. 0) then c c %-------------------------------------------------------% c | Sort the unwanted Ritz values used as shifts so that | c | the ones with largest Ritz estimates are first. | c | This will tend to minimize the effects of the | c | forward instability of the iteration when the shifts | c | are applied in subroutine ssapps. | c %-------------------------------------------------------% c call ssortr ('SM', .true., np, bounds, ritz) call scopy (np, ritz, 1, shifts, 1) end if c call second (t1) tsgets = tsgets + (t1 - t0) c if (msglvl .gt. 0) then call ivout (logfil, 1, kev, ndigit, '_sgets: KEV is') call ivout (logfil, 1, np, ndigit, '_sgets: NP is') call svout (logfil, kev+np, ritz, ndigit, & '_sgets: Eigenvalues of current H matrix') call svout (logfil, kev+np, bounds, ndigit, & '_sgets: Associated Ritz estimates') end if c return c c %---------------% c | End of ssgets | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/ssaup2.f000644 001750 001750 00000076707 11266605602 022052 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: ssaup2 c c\Description: c Intermediate level interface called by ssaupd. c c\Usage: c call ssaup2 c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, c IPNTR, WORKD, INFO ) c c\Arguments c c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in ssaupd. c MODE, ISHIFT, MXITER: see the definition of IPARAM in ssaupd. c c NP Integer. (INPUT/OUTPUT) c Contains the number of implicit shifts to apply during c each Arnoldi/Lanczos iteration. c If ISHIFT=1, NP is adjusted dynamically at each iteration c to accelerate convergence and prevent stagnation. c This is also roughly equal to the number of matrix-vector c products (involving the operator OP) per Arnoldi iteration. c The logic for adjusting is contained within the current c subroutine. c If ISHIFT=0, NP is the number of shifts the user needs c to provide via reverse comunication. 0 < NP < NCV-NEV. c NP may be less than NCV-NEV since a leading block of the current c upper Tridiagonal matrix has split off and contains "unwanted" c Ritz values. c Upon termination of the IRA iteration, NP contains the number c of "converged" wanted Ritz values. c c IUPD Integer. (INPUT) c IUPD .EQ. 0: use explicit restart instead implicit update. c IUPD .NE. 0: use implicit update. c c V Real N by (NEV+NP) array. (INPUT/OUTPUT) c The Lanczos basis vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Real (NEV+NP) by 2 array. (OUTPUT) c H is used to store the generated symmetric tridiagonal matrix c The subdiagonal is stored in the first column of H starting c at H(2,1). The main diagonal is stored in the second column c of H starting at H(1,2). If ssaup2 converges store the c B-norm of the final residual vector in H(1,1). c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZ Real array of length NEV+NP. (OUTPUT) c RITZ(1:NEV) contains the computed Ritz values of OP. c c BOUNDS Real array of length NEV+NP. (OUTPUT) c BOUNDS(1:NEV) contain the error bounds corresponding to RITZ. c c Q Real (NEV+NP) by (NEV+NP) array. (WORKSPACE) c Private (replicated) work array used to accumulate the c rotation in the shift application step. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Real array of length at least 3*(NEV+NP). (INPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. It is used in the computation of the c tridiagonal eigenvalue problem, the calculation and c application of the shifts and convergence checking. c If ISHIFT .EQ. O and IDO .EQ. 3, the first NP locations c of WORKL are used in reverse communication to hold the user c supplied shifts. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORKD for c vectors used by the Lanczos iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in one of c the spectral transformation modes. X is the current c operand. c ------------------------------------------------------------- c c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Lanczos iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration !!!!!!!!!! c See Data Distribution Note in ssaupd. c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal return. c = 1: All possible eigenvalues of OP has been found. c NP returns the size of the invariant subspace c spanning the operator OP. c = 2: No shifts could be applied. c = -8: Error return from trid. eigenvalue calculation; c This should never happen. c = -9: Starting vector is zero. c = -9999: Could not build an Lanczos factorization. c Size that was built in returned in NP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, c 1980. c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", c Computer Physics Communications, 53 (1989), pp 169-179. c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to c Implement the Spectral Transformation", Math. Comp., 48 (1987), c pp 663-673. c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", c SIAM J. Matr. Anal. Apps., January (1993). c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines c for Updating the QR decomposition", ACM TOMS, December 1990, c Volume 16 Number 4, pp 369-377. c c\Routines called: c sgetv0 ARPACK initial vector generation routine. c ssaitr ARPACK Lanczos factorization routine. c ssapps ARPACK application of implicit shifts routine. c ssconv ARPACK convergence of Ritz values routine. c sseigt ARPACK compute Ritz values and error bounds routine. c ssgets ARPACK reorder Ritz values and error bounds routine. c ssortr ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c svout ARPACK utility routine that prints vectors. c slamch LAPACK routine that determines machine constants. c scopy Level 1 BLAS that copies one vector to another. c sdot Level 1 BLAS that computes the scalar product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c sscal Level 1 BLAS that scales a vector. c sswap Level 1 BLAS that swaps two vectors. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/15/93: Version ' 2.4' c xx/xx/95: Version ' 2.4'. (R.B. Lehoucq) c c\SCCS Information: @(#) c FILE: saup2.F SID: 2.7 DATE OF SID: 5/19/98 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine ssaup2 & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, & q, ldq, workl, ipntr, workd, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ishift, iupd, ldh, ldq, ldv, mxiter, & n, mode, nev, np Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Real & bounds(nev+np), h(ldh,2), q(ldq,nev+np), resid(n), & ritz(nev+np), v(ldv,nev+np), workd(3*n), & workl(3*(nev+np)) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %---------------% c | Local Scalars | c %---------------% c character wprime*2 logical cnorm, getv0, initv, update, ushift integer ierr, iter, j, kplusp, msglvl, nconv, nevbef, nev0, & np0, nptemp, nevd2, nevm2, kp(3) Real & rnorm, temp, eps23 save cnorm, getv0, initv, update, ushift, & iter, kplusp, msglvl, nconv, nev0, np0, & rnorm, eps23 c c %----------------------% c | External Subroutines | c %----------------------% c external scopy, sgetv0, ssaitr, sscal, ssconv, sseigt, ssgets, & ssapps, ssortr, svout, ivout, second, sswap c c %--------------------% c | External Functions | c %--------------------% c Real & sdot, snrm2, slamch external sdot, snrm2, slamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic min c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = msaup2 c c %---------------------------------% c | Set machine dependent constant. | c %---------------------------------% c eps23 = slamch('Epsilon-Machine') eps23 = eps23**(2.0E+0/3.0E+0) c c %-------------------------------------% c | nev0 and np0 are integer variables | c | hold the initial values of NEV & NP | c %-------------------------------------% c nev0 = nev np0 = np c c %-------------------------------------% c | kplusp is the bound on the largest | c | Lanczos factorization built. | c | nconv is the current number of | c | "converged" eigenvlues. | c | iter is the counter on the current | c | iteration step. | c %-------------------------------------% c kplusp = nev0 + np0 nconv = 0 iter = 0 c c %--------------------------------------------% c | Set flags for computing the first NEV steps | c | of the Lanczos factorization. | c %--------------------------------------------% c getv0 = .true. update = .false. ushift = .false. cnorm = .false. c if (info .ne. 0) then c c %--------------------------------------------% c | User provides the initial residual vector. | c %--------------------------------------------% c initv = .true. info = 0 else initv = .false. end if end if c c %---------------------------------------------% c | Get a possibly random starting vector and | c | force it into the range of the operator OP. | c %---------------------------------------------% c 10 continue c if (getv0) then call sgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, & ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (rnorm .eq. zero) then c c %-----------------------------------------% c | The initial vector is zero. Error exit. | c %-----------------------------------------% c info = -9 go to 1200 end if getv0 = .false. ido = 0 end if c c %------------------------------------------------------------% c | Back from reverse communication: continue with update step | c %------------------------------------------------------------% c if (update) go to 20 c c %-------------------------------------------% c | Back from computing user specified shifts | c %-------------------------------------------% c if (ushift) go to 50 c c %-------------------------------------% c | Back from computing residual norm | c | at the end of the current iteration | c %-------------------------------------% c if (cnorm) go to 100 c c %----------------------------------------------------------% c | Compute the first NEV steps of the Lanczos factorization | c %----------------------------------------------------------% c call ssaitr (ido, bmat, n, 0, nev0, mode, resid, rnorm, v, ldv, & h, ldh, ipntr, workd, info) c c %---------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP and possibly B | c %---------------------------------------------------% c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then c c %-----------------------------------------------------% c | ssaitr was unable to build an Lanczos factorization | c | of length NEV0. INFO is returned with the size of | c | the factorization built. Exit main loop. | c %-----------------------------------------------------% c np = info mxiter = iter info = -9999 go to 1200 end if c c %--------------------------------------------------------------% c | | c | M A I N LANCZOS I T E R A T I O N L O O P | c | Each iteration implicitly restarts the Lanczos | c | factorization in place. | c | | c %--------------------------------------------------------------% c 1000 continue c iter = iter + 1 c if (msglvl .gt. 0) then call ivout (logfil, 1, iter, ndigit, & '_saup2: **** Start of major iteration number ****') end if if (msglvl .gt. 1) then call ivout (logfil, 1, nev, ndigit, & '_saup2: The length of the current Lanczos factorization') call ivout (logfil, 1, np, ndigit, & '_saup2: Extend the Lanczos factorization by') end if c c %------------------------------------------------------------% c | Compute NP additional steps of the Lanczos factorization. | c %------------------------------------------------------------% c ido = 0 20 continue update = .true. c call ssaitr (ido, bmat, n, nev, np, mode, resid, rnorm, v, & ldv, h, ldh, ipntr, workd, info) c c %---------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP and possibly B | c %---------------------------------------------------% c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then c c %-----------------------------------------------------% c | ssaitr was unable to build an Lanczos factorization | c | of length NEV0+NP0. INFO is returned with the size | c | of the factorization built. Exit main loop. | c %-----------------------------------------------------% c np = info mxiter = iter info = -9999 go to 1200 end if update = .false. c if (msglvl .gt. 1) then call svout (logfil, 1, rnorm, ndigit, & '_saup2: Current B-norm of residual for factorization') end if c c %--------------------------------------------------------% c | Compute the eigenvalues and corresponding error bounds | c | of the current symmetric tridiagonal matrix. | c %--------------------------------------------------------% c call sseigt (rnorm, kplusp, h, ldh, ritz, bounds, workl, ierr) c if (ierr .ne. 0) then info = -8 go to 1200 end if c c %----------------------------------------------------% c | Make a copy of eigenvalues and corresponding error | c | bounds obtained from _seigt. | c %----------------------------------------------------% c call scopy(kplusp, ritz, 1, workl(kplusp+1), 1) call scopy(kplusp, bounds, 1, workl(2*kplusp+1), 1) c c %---------------------------------------------------% c | Select the wanted Ritz values and their bounds | c | to be used in the convergence test. | c | The selection is based on the requested number of | c | eigenvalues instead of the current NEV and NP to | c | prevent possible misconvergence. | c | * Wanted Ritz values := RITZ(NP+1:NEV+NP) | c | * Shifts := RITZ(1:NP) := WORKL(1:NP) | c %---------------------------------------------------% c nev = nev0 np = np0 call ssgets (ishift, which, nev, np, ritz, bounds, workl) c c %-------------------% c | Convergence test. | c %-------------------% c call scopy (nev, bounds(np+1), 1, workl(np+1), 1) call ssconv (nev, ritz(np+1), workl(np+1), tol, nconv) c if (msglvl .gt. 2) then kp(1) = nev kp(2) = np kp(3) = nconv call ivout (logfil, 3, kp, ndigit, & '_saup2: NEV, NP, NCONV are') call svout (logfil, kplusp, ritz, ndigit, & '_saup2: The eigenvalues of H') call svout (logfil, kplusp, bounds, ndigit, & '_saup2: Ritz estimates of the current NCV Ritz values') end if c c %---------------------------------------------------------% c | Count the number of unwanted Ritz values that have zero | c | Ritz estimates. If any Ritz estimates are equal to zero | c | then a leading block of H of order equal to at least | c | the number of Ritz values with zero Ritz estimates has | c | split off. None of these Ritz values may be removed by | c | shifting. Decrease NP the number of shifts to apply. If | c | no shifts may be applied, then prepare to exit | c %---------------------------------------------------------% c nptemp = np do 30 j=1, nptemp if (bounds(j) .eq. zero) then np = np - 1 nev = nev + 1 end if 30 continue c if ( (nconv .ge. nev0) .or. & (iter .gt. mxiter) .or. & (np .eq. 0) ) then c c %------------------------------------------------% c | Prepare to exit. Put the converged Ritz values | c | and corresponding bounds in RITZ(1:NCONV) and | c | BOUNDS(1:NCONV) respectively. Then sort. Be | c | careful when NCONV > NP since we don't want to | c | swap overlapping locations. | c %------------------------------------------------% c if (which .eq. 'BE') then c c %-----------------------------------------------------% c | Both ends of the spectrum are requested. | c | Sort the eigenvalues into algebraically decreasing | c | order first then swap low end of the spectrum next | c | to high end in appropriate locations. | c | NOTE: when np < floor(nev/2) be careful not to swap | c | overlapping locations. | c %-----------------------------------------------------% c wprime = 'SA' call ssortr (wprime, .true., kplusp, ritz, bounds) nevd2 = nev0 / 2 nevm2 = nev0 - nevd2 if ( nev .gt. 1 ) then call sswap ( min(nevd2,np), ritz(nevm2+1), 1, & ritz( max(kplusp-nevd2+1,kplusp-np+1) ), 1) call sswap ( min(nevd2,np), bounds(nevm2+1), 1, & bounds( max(kplusp-nevd2+1,kplusp-np+1)), 1) end if c else c c %--------------------------------------------------% c | LM, SM, LA, SA case. | c | Sort the eigenvalues of H into the an order that | c | is opposite to WHICH, and apply the resulting | c | order to BOUNDS. The eigenvalues are sorted so | c | that the wanted part are always within the first | c | NEV locations. | c %--------------------------------------------------% c if (which .eq. 'LM') wprime = 'SM' if (which .eq. 'SM') wprime = 'LM' if (which .eq. 'LA') wprime = 'SA' if (which .eq. 'SA') wprime = 'LA' c call ssortr (wprime, .true., kplusp, ritz, bounds) c end if c c %--------------------------------------------------% c | Scale the Ritz estimate of each Ritz value | c | by 1 / max(eps23,magnitude of the Ritz value). | c %--------------------------------------------------% c do 35 j = 1, nev0 temp = max( eps23, abs(ritz(j)) ) bounds(j) = bounds(j)/temp 35 continue c c %----------------------------------------------------% c | Sort the Ritz values according to the scaled Ritz | c | esitmates. This will push all the converged ones | c | towards the front of ritzr, ritzi, bounds | c | (in the case when NCONV < NEV.) | c %----------------------------------------------------% c wprime = 'LA' call ssortr(wprime, .true., nev0, bounds, ritz) c c %----------------------------------------------% c | Scale the Ritz estimate back to its original | c | value. | c %----------------------------------------------% c do 40 j = 1, nev0 temp = max( eps23, abs(ritz(j)) ) bounds(j) = bounds(j)*temp 40 continue c c %--------------------------------------------------% c | Sort the "converged" Ritz values again so that | c | the "threshold" values and their associated Ritz | c | estimates appear at the appropriate position in | c | ritz and bound. | c %--------------------------------------------------% c if (which .eq. 'BE') then c c %------------------------------------------------% c | Sort the "converged" Ritz values in increasing | c | order. The "threshold" values are in the | c | middle. | c %------------------------------------------------% c wprime = 'LA' call ssortr(wprime, .true., nconv, ritz, bounds) c else c c %----------------------------------------------% c | In LM, SM, LA, SA case, sort the "converged" | c | Ritz values according to WHICH so that the | c | "threshold" value appears at the front of | c | ritz. | c %----------------------------------------------% call ssortr(which, .true., nconv, ritz, bounds) c end if c c %------------------------------------------% c | Use h( 1,1 ) as storage to communicate | c | rnorm to _seupd if needed | c %------------------------------------------% c h(1,1) = rnorm c if (msglvl .gt. 1) then call svout (logfil, kplusp, ritz, ndigit, & '_saup2: Sorted Ritz values.') call svout (logfil, kplusp, bounds, ndigit, & '_saup2: Sorted ritz estimates.') end if c c %------------------------------------% c | Max iterations have been exceeded. | c %------------------------------------% c if (iter .gt. mxiter .and. nconv .lt. nev) info = 1 c c %---------------------% c | No shifts to apply. | c %---------------------% c if (np .eq. 0 .and. nconv .lt. nev0) info = 2 c np = nconv go to 1100 c else if (nconv .lt. nev .and. ishift .eq. 1) then c c %---------------------------------------------------% c | Do not have all the requested eigenvalues yet. | c | To prevent possible stagnation, adjust the number | c | of Ritz values and the shifts. | c %---------------------------------------------------% c nevbef = nev nev = nev + min (nconv, np/2) if (nev .eq. 1 .and. kplusp .ge. 6) then nev = kplusp / 2 else if (nev .eq. 1 .and. kplusp .gt. 2) then nev = 2 end if np = kplusp - nev c c %---------------------------------------% c | If the size of NEV was just increased | c | resort the eigenvalues. | c %---------------------------------------% c if (nevbef .lt. nev) & call ssgets (ishift, which, nev, np, ritz, bounds, & workl) c end if c if (msglvl .gt. 0) then call ivout (logfil, 1, nconv, ndigit, & '_saup2: no. of "converged" Ritz values at this iter.') if (msglvl .gt. 1) then kp(1) = nev kp(2) = np call ivout (logfil, 2, kp, ndigit, & '_saup2: NEV and NP are') call svout (logfil, nev, ritz(np+1), ndigit, & '_saup2: "wanted" Ritz values.') call svout (logfil, nev, bounds(np+1), ndigit, & '_saup2: Ritz estimates of the "wanted" values ') end if end if c if (ishift .eq. 0) then c c %-----------------------------------------------------% c | User specified shifts: reverse communication to | c | compute the shifts. They are returned in the first | c | NP locations of WORKL. | c %-----------------------------------------------------% c ushift = .true. ido = 3 go to 9000 end if c 50 continue c c %------------------------------------% c | Back from reverse communication; | c | User specified shifts are returned | c | in WORKL(1:*NP) | c %------------------------------------% c ushift = .false. c c c %---------------------------------------------------------% c | Move the NP shifts to the first NP locations of RITZ to | c | free up WORKL. This is for the non-exact shift case; | c | in the exact shift case, ssgets already handles this. | c %---------------------------------------------------------% c if (ishift .eq. 0) call scopy (np, workl, 1, ritz, 1) c if (msglvl .gt. 2) then call ivout (logfil, 1, np, ndigit, & '_saup2: The number of shifts to apply ') call svout (logfil, np, workl, ndigit, & '_saup2: shifts selected') if (ishift .eq. 1) then call svout (logfil, np, bounds, ndigit, & '_saup2: corresponding Ritz estimates') end if end if c c %---------------------------------------------------------% c | Apply the NP0 implicit shifts by QR bulge chasing. | c | Each shift is applied to the entire tridiagonal matrix. | c | The first 2*N locations of WORKD are used as workspace. | c | After ssapps is done, we have a Lanczos | c | factorization of length NEV. | c %---------------------------------------------------------% c call ssapps (n, nev, np, ritz, v, ldv, h, ldh, resid, q, ldq, & workd) c c %---------------------------------------------% c | Compute the B-norm of the updated residual. | c | Keep B*RESID in WORKD(1:N) to be used in | c | the first step of the next call to ssaitr. | c %---------------------------------------------% c cnorm = .true. call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call scopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 c c %----------------------------------% c | Exit in order to compute B*RESID | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd, 1) end if c 100 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(1:N) := B*RESID | c %----------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then rnorm = sdot (n, resid, 1, workd, 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = snrm2(n, resid, 1) end if cnorm = .false. 130 continue c if (msglvl .gt. 2) then call svout (logfil, 1, rnorm, ndigit, & '_saup2: B-norm of residual for NEV factorization') call svout (logfil, nev, h(1,2), ndigit, & '_saup2: main diagonal of compressed H matrix') call svout (logfil, nev-1, h(2,1), ndigit, & '_saup2: subdiagonal of compressed H matrix') end if c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 1100 continue c mxiter = iter nev = nconv c 1200 continue ido = 99 c c %------------% c | Error exit | c %------------% c call second (t1) tsaup2 = t1 - t0 c 9000 continue return c c %---------------% c | End of ssaup2 | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/sstats.f000644 001750 001750 00000002216 11266605602 022136 0ustar00geuzainegeuzaine000000 000000 c c\SCCS Information: @(#) c FILE: stats.F SID: 2.1 DATE OF SID: 4/19/96 RELEASE: 2 c %---------------------------------------------% c | Initialize statistic and timing information | c | for symmetric Arnoldi code. | c %---------------------------------------------% subroutine sstats c %--------------------------------% c | See stat.doc for documentation | c %--------------------------------% include 'stat.h' c %-----------------------% c | Executable Statements | c %-----------------------% nopx = 0 nbx = 0 nrorth = 0 nitref = 0 nrstrt = 0 tsaupd = 0.0E+0 tsaup2 = 0.0E+0 tsaitr = 0.0E+0 tseigt = 0.0E+0 tsgets = 0.0E+0 tsapps = 0.0E+0 tsconv = 0.0E+0 titref = 0.0E+0 tgetv0 = 0.0E+0 trvec = 0.0E+0 c %----------------------------------------------------% c | User time including reverse communication overhead | c %----------------------------------------------------% tmvopx = 0.0E+0 tmvbx = 0.0E+0 return c c End of sstats c end getdp-2.4.2-source/contrib/Arpack/sseigt.f000644 001750 001750 00000011755 11266605602 022123 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: sseigt c c\Description: c Compute the eigenvalues of the current symmetric tridiagonal matrix c and the corresponding error bounds given the current residual norm. c c\Usage: c call sseigt c ( RNORM, N, H, LDH, EIG, BOUNDS, WORKL, IERR ) c c\Arguments c RNORM Real scalar. (INPUT) c RNORM contains the residual norm corresponding to the current c symmetric tridiagonal matrix H. c c N Integer. (INPUT) c Size of the symmetric tridiagonal matrix H. c c H Real N by 2 array. (INPUT) c H contains the symmetric tridiagonal matrix with the c subdiagonal in the first column starting at H(2,1) and the c main diagonal in second column. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c EIG Real array of length N. (OUTPUT) c On output, EIG contains the N eigenvalues of H possibly c unsorted. The BOUNDS arrays are returned in the c same sorted order as EIG. c c BOUNDS Real array of length N. (OUTPUT) c On output, BOUNDS contains the error estimates corresponding c to the eigenvalues EIG. This is equal to RNORM times the c last components of the eigenvectors corresponding to the c eigenvalues in EIG. c c WORKL Real work array of length 3*N. (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c IERR Integer. (OUTPUT) c Error exit flag from sstqrb. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c sstqrb ARPACK routine that computes the eigenvalues and the c last components of the eigenvectors of a symmetric c and tridiagonal matrix. c second ARPACK utility routine for timing. c svout ARPACK utility routine that prints vectors. c scopy Level 1 BLAS that copies one vector to another. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.4' c c\SCCS Information: @(#) c FILE: seigt.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c None c c\EndLib c c----------------------------------------------------------------------- c subroutine sseigt & ( rnorm, n, h, ldh, eig, bounds, workl, ierr ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer ierr, ldh, n Real & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c Real & eig(n), bounds(n), h(ldh,2), workl(3*n) c c %------------% c | Parameters | c %------------% c Real & zero parameter (zero = 0.0E+0) c c %---------------% c | Local Scalars | c %---------------% c integer i, k, msglvl c c %----------------------% c | External Subroutines | c %----------------------% c external scopy, sstqrb, svout, second c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mseigt c if (msglvl .gt. 0) then call svout (logfil, n, h(1,2), ndigit, & '_seigt: main diagonal of matrix H') if (n .gt. 1) then call svout (logfil, n-1, h(2,1), ndigit, & '_seigt: sub diagonal of matrix H') end if end if c call scopy (n, h(1,2), 1, eig, 1) call scopy (n-1, h(2,1), 1, workl, 1) call sstqrb (n, eig, workl, bounds, workl(n+1), ierr) if (ierr .ne. 0) go to 9000 if (msglvl .gt. 1) then call svout (logfil, n, bounds, ndigit, & '_seigt: last row of the eigenvector matrix for H') end if c c %-----------------------------------------------% c | Finally determine the error bounds associated | c | with the n Ritz values of H. | c %-----------------------------------------------% c do 30 k = 1, n bounds(k) = rnorm*abs(bounds(k)) 30 continue c call second (t1) tseigt = tseigt + (t1 - t0) c 9000 continue return c c %---------------% c | End of sseigt | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/snaitr.f000644 001750 001750 00000073467 11266605602 022135 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: snaitr c c\Description: c Reverse communication interface for applying NP additional steps to c a K step nonsymmetric Arnoldi factorization. c c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T c c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. c c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T c c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. c c where OP and B are as in snaupd. The B-norm of r_{k+p} is also c computed and returned. c c\Usage: c call snaitr c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, c IPNTR, WORKD, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c This is for the restart phase to force the new c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y, c IPNTR(3) is the pointer into WORK for B * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c IDO = 99: done c ------------------------------------------------------------- c When the routine is used in the "shift-and-invert" mode, the c vector B * Q is already available and do not need to be c recompute in forming OP * Q. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. See snaupd. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c K Integer. (INPUT) c Current size of V and H. c c NP Integer. (INPUT) c Number of additional Arnoldi steps to take. c c NB Integer. (INPUT) c Blocksize to be used in the recurrence. c Only work for NB = 1 right now. The goal is to have a c program that implement both the block and non-block method. c c RESID Real array of length N. (INPUT/OUTPUT) c On INPUT: RESID contains the residual vector r_{k}. c On OUTPUT: RESID contains the residual vector r_{k+p}. c c RNORM Real scalar. (INPUT/OUTPUT) c B-norm of the starting residual on input. c B-norm of the updated residual r_{k+p} on output. c c V Real N by K+NP array. (INPUT/OUTPUT) c On INPUT: V contains the Arnoldi vectors in the first K c columns. c On OUTPUT: V contains the new NP Arnoldi vectors in the next c NP columns. The first K columns are unchanged. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Real (K+NP) by (K+NP) array. (INPUT/OUTPUT) c H is used to store the generated upper Hessenberg matrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORK for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The calling program should not c use WORKD as temporary workspace during the iteration !!!!!! c On input, WORKD(1:N) = B*RESID and is used to save some c computation at the first step. c c INFO Integer. (OUTPUT) c = 0: Normal exit. c > 0: Size of the spanning invariant subspace of OP found. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c sgetv0 ARPACK routine to generate the initial vector. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c smout ARPACK utility routine that prints matrices c svout ARPACK utility routine that prints vectors. c slabad LAPACK routine that computes machine constants. c slamch LAPACK routine that determines machine constants. c slascl LAPACK routine for careful scaling of a matrix. c slanhs LAPACK routine that computes various norms of a matrix. c sgemv Level 2 BLAS routine for matrix vector multiplication. c saxpy Level 1 BLAS that computes a vector triad. c sscal Level 1 BLAS that scales a vector. c scopy Level 1 BLAS that copies one vector to another . c sdot Level 1 BLAS that computes the scalar product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.4' c c\SCCS Information: @(#) c FILE: naitr.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c The algorithm implemented is: c c restart = .false. c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; c r_{k} contains the initial residual vector even for k = 0; c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already c computed by the calling program. c c betaj = rnorm ; p_{k+1} = B*r_{k} ; c For j = k+1, ..., k+np Do c 1) if ( betaj < tol ) stop or restart depending on j. c ( At present tol is zero ) c if ( restart ) generate a new starting vector. c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; c p_{j} = p_{j}/betaj c 3) r_{j} = OP*v_{j} where OP is defined as in snaupd c For shift-invert mode p_{j} = B*v_{j} is already available. c wnorm = || OP*v_{j} || c 4) Compute the j-th step residual vector. c w_{j} = V_{j}^T * B * OP * v_{j} c r_{j} = OP*v_{j} - V_{j} * w_{j} c H(:,j) = w_{j}; c H(j,j-1) = rnorm c rnorm = || r_(j) || c If (rnorm > 0.717*wnorm) accept step and go back to 1) c 5) Re-orthogonalization step: c s = V_{j}'*B*r_{j} c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || c alphaj = alphaj + s_{j}; c 6) Iterative refinement step: c If (rnorm1 > 0.717*rnorm) then c rnorm = rnorm1 c accept step and go back to 1) c Else c rnorm = rnorm1 c If this is the first time in step 6), go to 5) c Else r_{j} lies in the span of V_{j} numerically. c Set r_{j} = 0 and rnorm = 0; go to 1) c EndIf c End Do c c\EndLib c c----------------------------------------------------------------------- c subroutine snaitr & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, & ipntr, workd, info) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 integer ido, info, k, ldh, ldv, n, nb, np Real & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Real & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %---------------% c | Local Scalars | c %---------------% c logical first, orth1, orth2, rstart, step3, step4 integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, & jj Real & betaj, ovfl, temp1, rnorm1, smlnum, tst1, ulp, unfl, & wnorm save first, orth1, orth2, rstart, step3, step4, & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, & betaj, rnorm1, smlnum, ulp, unfl, wnorm c c %-----------------------% c | Local Array Arguments | c %-----------------------% c Real & xtemp(2) c c %----------------------% c | External Subroutines | c %----------------------% c external saxpy, scopy, sscal, sgemv, sgetv0, slabad, & svout, smout, ivout, second c c %--------------------% c | External Functions | c %--------------------% c Real & sdot, snrm2, slanhs, slamch external sdot, snrm2, slanhs, slamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs, sqrt c c %-----------------% c | Data statements | c %-----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then c c %-----------------------------------------% c | Set machine-dependent constants for the | c | the splitting and deflation criterion. | c | If norm(H) <= sqrt(OVFL), | c | overflow should not occur. | c | REFERENCE: LAPACK subroutine slahqr | c %-----------------------------------------% c unfl = slamch( 'safe minimum' ) ovfl = one / unfl call slabad( unfl, ovfl ) ulp = slamch( 'precision' ) smlnum = unfl*( n / ulp ) first = .false. end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mnaitr c c %------------------------------% c | Initial call to this routine | c %------------------------------% c info = 0 step3 = .false. step4 = .false. rstart = .false. orth1 = .false. orth2 = .false. j = k + 1 ipj = 1 irj = ipj + n ivj = irj + n end if c c %-------------------------------------------------% c | When in reverse communication mode one of: | c | STEP3, STEP4, ORTH1, ORTH2, RSTART | c | will be .true. when .... | c | STEP3: return from computing OP*v_{j}. | c | STEP4: return from computing B-norm of OP*v_{j} | c | ORTH1: return from computing B-norm of r_{j+1} | c | ORTH2: return from computing B-norm of | c | correction to the residual vector. | c | RSTART: return from OP computations needed by | c | sgetv0. | c %-------------------------------------------------% c if (step3) go to 50 if (step4) go to 60 if (orth1) go to 70 if (orth2) go to 90 if (rstart) go to 30 c c %-----------------------------% c | Else this is the first step | c %-----------------------------% c c %--------------------------------------------------------------% c | | c | A R N O L D I I T E R A T I O N L O O P | c | | c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | c %--------------------------------------------------------------% 1000 continue c if (msglvl .gt. 1) then call ivout (logfil, 1, j, ndigit, & '_naitr: generating Arnoldi vector number') call svout (logfil, 1, rnorm, ndigit, & '_naitr: B-norm of the current residual is') end if c c %---------------------------------------------------% c | STEP 1: Check if the B norm of j-th residual | c | vector is zero. Equivalent to determing whether | c | an exact j-step Arnoldi factorization is present. | c %---------------------------------------------------% c betaj = rnorm if (rnorm .gt. zero) go to 40 c c %---------------------------------------------------% c | Invariant subspace found, generate a new starting | c | vector which is orthogonal to the current Arnoldi | c | basis and continue the iteration. | c %---------------------------------------------------% c if (msglvl .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_naitr: ****** RESTART AT STEP ******') end if c c %---------------------------------------------% c | ITRY is the loop variable that controls the | c | maximum amount of times that a restart is | c | attempted. NRSTRT is used by stat.h | c %---------------------------------------------% c betaj = zero nrstrt = nrstrt + 1 itry = 1 20 continue rstart = .true. ido = 0 30 continue c c %--------------------------------------% c | If in reverse communication mode and | c | RSTART = .true. flow returns here. | c %--------------------------------------% c call sgetv0 (ido, bmat, itry, .false., n, j, v, ldv, & resid, rnorm, ipntr, workd, ierr) if (ido .ne. 99) go to 9000 if (ierr .lt. 0) then itry = itry + 1 if (itry .le. 3) go to 20 c c %------------------------------------------------% c | Give up after several restart attempts. | c | Set INFO to the size of the invariant subspace | c | which spans OP and exit. | c %------------------------------------------------% c info = j - 1 call second (t1) tnaitr = tnaitr + (t1 - t0) ido = 99 go to 9000 end if c 40 continue c c %---------------------------------------------------------% c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | c | when reciprocating a small RNORM, test against lower | c | machine bound. | c %---------------------------------------------------------% c call scopy (n, resid, 1, v(1,j), 1) if (rnorm .ge. unfl) then temp1 = one / rnorm call sscal (n, temp1, v(1,j), 1) call sscal (n, temp1, workd(ipj), 1) else c c %-----------------------------------------% c | To scale both v_{j} and p_{j} carefully | c | use LAPACK routine SLASCL | c %-----------------------------------------% c call slascl ('General', i, i, rnorm, one, n, 1, & v(1,j), n, infol) call slascl ('General', i, i, rnorm, one, n, 1, & workd(ipj), n, infol) end if c c %------------------------------------------------------% c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | c | Note that this is not quite yet r_{j}. See STEP 4 | c %------------------------------------------------------% c step3 = .true. nopx = nopx + 1 call second (t2) call scopy (n, v(1,j), 1, workd(ivj), 1) ipntr(1) = ivj ipntr(2) = irj ipntr(3) = ipj ido = 1 c c %-----------------------------------% c | Exit in order to compute OP*v_{j} | c %-----------------------------------% c go to 9000 50 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | c | if step3 = .true. | c %----------------------------------% c call second (t3) tmvopx = tmvopx + (t3 - t2) step3 = .false. c c %------------------------------------------% c | Put another copy of OP*v_{j} into RESID. | c %------------------------------------------% c call scopy (n, workd(irj), 1, resid, 1) c c %---------------------------------------% c | STEP 4: Finish extending the Arnoldi | c | factorization to length j. | c %---------------------------------------% c call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 step4 = .true. ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-------------------------------------% c | Exit in order to compute B*OP*v_{j} | c %-------------------------------------% c go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd(ipj), 1) end if 60 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | c | if step4 = .true. | c %----------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c step4 = .false. c c %-------------------------------------% c | The following is needed for STEP 5. | c | Compute the B-norm of OP*v_{j}. | c %-------------------------------------% c if (bmat .eq. 'G') then wnorm = sdot (n, resid, 1, workd(ipj), 1) wnorm = sqrt(abs(wnorm)) else if (bmat .eq. 'I') then wnorm = snrm2(n, resid, 1) end if c c %-----------------------------------------% c | Compute the j-th residual corresponding | c | to the j step factorization. | c | Use Classical Gram Schmidt and compute: | c | w_{j} <- V_{j}^T * B * OP * v_{j} | c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | c %-----------------------------------------% c c c %------------------------------------------% c | Compute the j Fourier coefficients w_{j} | c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | c %------------------------------------------% c call sgemv ('T', n, j, one, v, ldv, workd(ipj), 1, & zero, h(1,j), 1) c c %--------------------------------------% c | Orthogonalize r_{j} against V_{j}. | c | RESID contains OP*v_{j}. See STEP 3. | c %--------------------------------------% c call sgemv ('N', n, j, -one, v, ldv, h(1,j), 1, & one, resid, 1) c if (j .gt. 1) h(j,j-1) = betaj c call second (t4) c orth1 = .true. c call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call scopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %----------------------------------% c | Exit in order to compute B*r_{j} | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd(ipj), 1) end if 70 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH1 = .true. | c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c orth1 = .false. c c %------------------------------% c | Compute the B-norm of r_{j}. | c %------------------------------% c if (bmat .eq. 'G') then rnorm = sdot (n, resid, 1, workd(ipj), 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = snrm2(n, resid, 1) end if c c %-----------------------------------------------------------% c | STEP 5: Re-orthogonalization / Iterative refinement phase | c | Maximum NITER_ITREF tries. | c | | c | s = V_{j}^T * B * r_{j} | c | r_{j} = r_{j} - V_{j}*s | c | alphaj = alphaj + s_{j} | c | | c | The stopping criteria used for iterative refinement is | c | discussed in Parlett's book SEP, page 107 and in Gragg & | c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | c | Determine if we need to correct the residual. The goal is | c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | c | The following test determines whether the sine of the | c | angle between OP*x and the computed residual is less | c | than or equal to 0.717. | c %-----------------------------------------------------------% c if (rnorm .gt. 0.717*wnorm) go to 100 iter = 0 nrorth = nrorth + 1 c c %---------------------------------------------------% c | Enter the Iterative refinement phase. If further | c | refinement is necessary, loop back here. The loop | c | variable is ITER. Perform a step of Classical | c | Gram-Schmidt using all the Arnoldi vectors V_{j} | c %---------------------------------------------------% c 80 continue c if (msglvl .gt. 2) then xtemp(1) = wnorm xtemp(2) = rnorm call svout (logfil, 2, xtemp, ndigit, & '_naitr: re-orthonalization; wnorm and rnorm are') call svout (logfil, j, h(1,j), ndigit, & '_naitr: j-th column of H') end if c c %----------------------------------------------------% c | Compute V_{j}^T * B * r_{j}. | c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | c %----------------------------------------------------% c call sgemv ('T', n, j, one, v, ldv, workd(ipj), 1, & zero, workd(irj), 1) c c %---------------------------------------------% c | Compute the correction to the residual: | c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | c | The correction to H is v(:,1:J)*H(1:J,1:J) | c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | c %---------------------------------------------% c call sgemv ('N', n, j, -one, v, ldv, workd(irj), 1, & one, resid, 1) call saxpy (j, one, workd(irj), 1, h(1,j), 1) c orth2 = .true. call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call scopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-----------------------------------% c | Exit in order to compute B*r_{j}. | c | r_{j} is the corrected residual. | c %-----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd(ipj), 1) end if 90 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH2 = .true. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c c %-----------------------------------------------------% c | Compute the B-norm of the corrected residual r_{j}. | c %-----------------------------------------------------% c if (bmat .eq. 'G') then rnorm1 = sdot (n, resid, 1, workd(ipj), 1) rnorm1 = sqrt(abs(rnorm1)) else if (bmat .eq. 'I') then rnorm1 = snrm2(n, resid, 1) end if c if (msglvl .gt. 0 .and. iter .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_naitr: Iterative refinement for Arnoldi residual') if (msglvl .gt. 2) then xtemp(1) = rnorm xtemp(2) = rnorm1 call svout (logfil, 2, xtemp, ndigit, & '_naitr: iterative refinement ; rnorm and rnorm1 are') end if end if c c %-----------------------------------------% c | Determine if we need to perform another | c | step of re-orthogonalization. | c %-----------------------------------------% c if (rnorm1 .gt. 0.717*rnorm) then c c %---------------------------------------% c | No need for further refinement. | c | The cosine of the angle between the | c | corrected residual vector and the old | c | residual vector is greater than 0.717 | c | In other words the corrected residual | c | and the old residual vector share an | c | angle of less than arcCOS(0.717) | c %---------------------------------------% c rnorm = rnorm1 c else c c %-------------------------------------------% c | Another step of iterative refinement step | c | is required. NITREF is used by stat.h | c %-------------------------------------------% c nitref = nitref + 1 rnorm = rnorm1 iter = iter + 1 if (iter .le. 1) go to 80 c c %-------------------------------------------------% c | Otherwise RESID is numerically in the span of V | c %-------------------------------------------------% c do 95 jj = 1, n resid(jj) = zero 95 continue rnorm = zero end if c c %----------------------------------------------% c | Branch here directly if iterative refinement | c | wasn't necessary or after at most NITER_REF | c | steps of iterative refinement. | c %----------------------------------------------% c 100 continue c rstart = .false. orth2 = .false. c call second (t5) titref = titref + (t5 - t4) c c %------------------------------------% c | STEP 6: Update j = j+1; Continue | c %------------------------------------% c j = j + 1 if (j .gt. k+np) then call second (t1) tnaitr = tnaitr + (t1 - t0) ido = 99 do 110 i = max(1,k), k+np-1 c c %--------------------------------------------% c | Check for splitting and deflation. | c | Use a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine slahqr | c %--------------------------------------------% c tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) if( tst1.eq.zero ) & tst1 = slanhs( '1', k+np, h, ldh, workd(n+1) ) if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 110 continue c if (msglvl .gt. 2) then call smout (logfil, k+np, k+np, h, ldh, ndigit, & '_naitr: Final upper Hessenberg matrix H of order K+NP') end if c go to 9000 end if c c %--------------------------------------------------------% c | Loop back to extend the factorization by another step. | c %--------------------------------------------------------% c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 9000 continue return c c %---------------% c | End of snaitr | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/cnapps.f000644 001750 001750 00000042206 11266605602 022104 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: cnapps c c\Description: c Given the Arnoldi factorization c c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, c c apply NP implicit shifts resulting in c c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q c c where Q is an orthogonal matrix which is the product of rotations c and reflections resulting from the NP bulge change sweeps. c The updated Arnoldi factorization becomes: c c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. c c\Usage: c call cnapps c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, c WORKL, WORKD ) c c\Arguments c N Integer. (INPUT) c Problem size, i.e. size of matrix A. c c KEV Integer. (INPUT/OUTPUT) c KEV+NP is the size of the input matrix H. c KEV is the size of the updated matrix HNEW. c c NP Integer. (INPUT) c Number of implicit shifts to be applied. c c SHIFT Complex array of length NP. (INPUT) c The shifts to be applied. c c V Complex N by (KEV+NP) array. (INPUT/OUTPUT) c On INPUT, V contains the current KEV+NP Arnoldi vectors. c On OUTPUT, V contains the updated KEV Arnoldi vectors c in the first KEV columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Complex (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) c On INPUT, H contains the current KEV+NP by KEV+NP upper c Hessenberg matrix of the Arnoldi factorization. c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg c matrix in the KEV leading submatrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RESID Complex array of length N. (INPUT/OUTPUT) c On INPUT, RESID contains the the residual vector r_{k+p}. c On OUTPUT, RESID is the update residual vector rnew_{k} c in the first KEV locations. c c Q Complex KEV+NP by KEV+NP work array. (WORKSPACE) c Work array used to accumulate the rotations and reflections c during the bulge chase sweep. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Complex work array of length (KEV+NP). (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c WORKD Complex work array of length 2*N. (WORKSPACE) c Distributed array used in the application of the accumulated c orthogonal matrix Q. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c c\Routines called: c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c cmout ARPACK utility routine that prints matrices c cvout ARPACK utility routine that prints vectors. c clacpy LAPACK matrix copy routine. c clanhs LAPACK routine that computes various norms of a matrix. c clartg LAPACK Givens rotation construction routine. c claset LAPACK matrix initialization routine. c slabad LAPACK routine for defining the underflow and overflow c limits. c slamch LAPACK routine that determines machine constants. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c cgemv Level 2 BLAS routine for matrix vector multiplication. c caxpy Level 1 BLAS that computes a vector triad. c ccopy Level 1 BLAS that copies one vector to another. c cscal Level 1 BLAS that scales a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: napps.F SID: 2.3 DATE OF SID: 3/28/97 RELEASE: 2 c c\Remarks c 1. In this version, each shift is applied to all the sublocks of c the Hessenberg matrix H and not just to the submatrix that it c comes from. Deflation as in LAPACK routine clahqr (QR algorithm c for upper Hessenberg matrices ) is used. c Upon output, the subdiagonals of H are enforced to be non-negative c real numbers. c c\EndLib c c----------------------------------------------------------------------- c subroutine cnapps & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, & workl, workd ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer kev, ldh, ldq, ldv, n, np c c %-----------------% c | Array Arguments | c %-----------------% c Complex & h(ldh,kev+np), resid(n), shift(np), & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) c c %------------% c | Parameters | c %------------% c Complex & one, zero Real & rzero parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0), & rzero = 0.0E+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c integer i, iend, istart, j, jj, kplusp, msglvl logical first Complex & cdum, f, g, h11, h21, r, s, sigma, t Real & c, ovfl, smlnum, ulp, unfl, tst1 save first, ovfl, smlnum, ulp, unfl c c %----------------------% c | External Subroutines | c %----------------------% c external caxpy, ccopy, cgemv, cscal, clacpy, clartg, & cvout, claset, slabad, cmout, second, ivout c c %--------------------% c | External Functions | c %--------------------% c Real & clanhs, slamch, slapy2 external clanhs, slamch, slapy2 c c %----------------------% c | Intrinsics Functions | c %----------------------% c intrinsic abs, aimag, conjg, cmplx, max, min, real c c %---------------------% c | Statement Functions | c %---------------------% c Real & cabs1 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) ) c c %----------------% c | Data statments | c %----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then c c %-----------------------------------------------% c | Set machine-dependent constants for the | c | stopping criterion. If norm(H) <= sqrt(OVFL), | c | overflow should not occur. | c | REFERENCE: LAPACK subroutine clahqr | c %-----------------------------------------------% c unfl = slamch( 'safe minimum' ) ovfl = real(one / unfl) call slabad( unfl, ovfl ) ulp = slamch( 'precision' ) smlnum = unfl*( n / ulp ) first = .false. end if c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mcapps c kplusp = kev + np c c %--------------------------------------------% c | Initialize Q to the identity to accumulate | c | the rotations and reflections | c %--------------------------------------------% c call claset ('All', kplusp, kplusp, zero, one, q, ldq) c c %----------------------------------------------% c | Quick return if there are no shifts to apply | c %----------------------------------------------% c if (np .eq. 0) go to 9000 c c %----------------------------------------------% c | Chase the bulge with the application of each | c | implicit shift. Each shift is applied to the | c | whole matrix including each block. | c %----------------------------------------------% c do 110 jj = 1, np sigma = shift(jj) c if (msglvl .gt. 2 ) then call ivout (logfil, 1, jj, ndigit, & '_napps: shift number.') call cvout (logfil, 1, sigma, ndigit, & '_napps: Value of the shift ') end if c istart = 1 20 continue c do 30 i = istart, kplusp-1 c c %----------------------------------------% c | Check for splitting and deflation. Use | c | a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine clahqr | c %----------------------------------------% c tst1 = cabs1( h( i, i ) ) + cabs1( h( i+1, i+1 ) ) if( tst1.eq.rzero ) & tst1 = clanhs( '1', kplusp-jj+1, h, ldh, workl ) if ( abs(real(h(i+1,i))) & .le. max(ulp*tst1, smlnum) ) then if (msglvl .gt. 0) then call ivout (logfil, 1, i, ndigit, & '_napps: matrix splitting at row/column no.') call ivout (logfil, 1, jj, ndigit, & '_napps: matrix splitting with shift number.') call cvout (logfil, 1, h(i+1,i), ndigit, & '_napps: off diagonal element.') end if iend = i h(i+1,i) = zero go to 40 end if 30 continue iend = kplusp 40 continue c if (msglvl .gt. 2) then call ivout (logfil, 1, istart, ndigit, & '_napps: Start of current block ') call ivout (logfil, 1, iend, ndigit, & '_napps: End of current block ') end if c c %------------------------------------------------% c | No reason to apply a shift to block of order 1 | c | or if the current block starts after the point | c | of compression since we'll discard this stuff | c %------------------------------------------------% c if ( istart .eq. iend .or. istart .gt. kev) go to 100 c h11 = h(istart,istart) h21 = h(istart+1,istart) f = h11 - sigma g = h21 c do 80 i = istart, iend-1 c c %------------------------------------------------------% c | Construct the plane rotation G to zero out the bulge | c %------------------------------------------------------% c call clartg (f, g, c, s, r) if (i .gt. istart) then h(i,i-1) = r h(i+1,i-1) = zero end if c c %---------------------------------------------% c | Apply rotation to the left of H; H <- G'*H | c %---------------------------------------------% c do 50 j = i, kplusp t = c*h(i,j) + s*h(i+1,j) h(i+1,j) = -conjg(s)*h(i,j) + c*h(i+1,j) h(i,j) = t 50 continue c c %---------------------------------------------% c | Apply rotation to the right of H; H <- H*G | c %---------------------------------------------% c do 60 j = 1, min(i+2,iend) t = c*h(j,i) + conjg(s)*h(j,i+1) h(j,i+1) = -s*h(j,i) + c*h(j,i+1) h(j,i) = t 60 continue c c %-----------------------------------------------------% c | Accumulate the rotation in the matrix Q; Q <- Q*G' | c %-----------------------------------------------------% c do 70 j = 1, min(i+jj, kplusp) t = c*q(j,i) + conjg(s)*q(j,i+1) q(j,i+1) = - s*q(j,i) + c*q(j,i+1) q(j,i) = t 70 continue c c %---------------------------% c | Prepare for next rotation | c %---------------------------% c if (i .lt. iend-1) then f = h(i+1,i) g = h(i+2,i) end if 80 continue c c %-------------------------------% c | Finished applying the shift. | c %-------------------------------% c 100 continue c c %---------------------------------------------------------% c | Apply the same shift to the next block if there is any. | c %---------------------------------------------------------% c istart = iend + 1 if (iend .lt. kplusp) go to 20 c c %---------------------------------------------% c | Loop back to the top to get the next shift. | c %---------------------------------------------% c 110 continue c c %---------------------------------------------------% c | Perform a similarity transformation that makes | c | sure that the compressed H will have non-negative | c | real subdiagonal elements. | c %---------------------------------------------------% c do 120 j=1,kev if ( real( h(j+1,j) ) .lt. rzero .or. & aimag( h(j+1,j) ) .ne. rzero ) then t = h(j+1,j) / slapy2(real(h(j+1,j)),aimag(h(j+1,j))) call cscal( kplusp-j+1, conjg(t), h(j+1,j), ldh ) call cscal( min(j+2, kplusp), t, h(1,j+1), 1 ) call cscal( min(j+np+1,kplusp), t, q(1,j+1), 1 ) h(j+1,j) = cmplx( real( h(j+1,j) ), rzero ) end if 120 continue c do 130 i = 1, kev c c %--------------------------------------------% c | Final check for splitting and deflation. | c | Use a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine clahqr. | c | Note: Since the subdiagonals of the | c | compressed H are nonnegative real numbers, | c | we take advantage of this. | c %--------------------------------------------% c tst1 = cabs1( h( i, i ) ) + cabs1( h( i+1, i+1 ) ) if( tst1 .eq. rzero ) & tst1 = clanhs( '1', kev, h, ldh, workl ) if( real( h( i+1,i ) ) .le. max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 130 continue c c %-------------------------------------------------% c | Compute the (kev+1)-st column of (V*Q) and | c | temporarily store the result in WORKD(N+1:2*N). | c | This is needed in the residual update since we | c | cannot GUARANTEE that the corresponding entry | c | of H would be zero as in exact arithmetic. | c %-------------------------------------------------% c if ( real( h(kev+1,kev) ) .gt. rzero ) & call cgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, & workd(n+1), 1) c c %----------------------------------------------------------% c | Compute column 1 to kev of (V*Q) in backward order | c | taking advantage of the upper Hessenberg structure of Q. | c %----------------------------------------------------------% c do 140 i = 1, kev call cgemv ('N', n, kplusp-i+1, one, v, ldv, & q(1,kev-i+1), 1, zero, workd, 1) call ccopy (n, workd, 1, v(1,kplusp-i+1), 1) 140 continue c c %-------------------------------------------------% c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | c %-------------------------------------------------% c call clacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv) c c %--------------------------------------------------------------% c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | c %--------------------------------------------------------------% c if ( real( h(kev+1,kev) ) .gt. rzero ) & call ccopy (n, workd(n+1), 1, v(1,kev+1), 1) c c %-------------------------------------% c | Update the residual vector: | c | r <- sigmak*r + betak*v(:,kev+1) | c | where | c | sigmak = (e_{kev+p}'*Q)*e_{kev} | c | betak = e_{kev+1}'*H*e_{kev} | c %-------------------------------------% c call cscal (n, q(kplusp,kev), resid, 1) if ( real( h(kev+1,kev) ) .gt. rzero ) & call caxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) c if (msglvl .gt. 1) then call cvout (logfil, 1, q(kplusp,kev), ndigit, & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') call cvout (logfil, 1, h(kev+1,kev), ndigit, & '_napps: betak = e_{kev+1}^T*H*e_{kev}') call ivout (logfil, 1, kev, ndigit, & '_napps: Order of the final Hessenberg matrix ') if (msglvl .gt. 2) then call cmout (logfil, kev, kev, h, ldh, ndigit, & '_napps: updated Hessenberg matrix H for next iteration') end if c end if c 9000 continue call second (t1) tcapps = tcapps + (t1 - t0) c return c c %---------------% c | End of cnapps | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/zstatn.f000644 001750 001750 00000002305 11266605602 022137 0ustar00geuzainegeuzaine000000 000000 c c\SCCS Information: @(#) c FILE: statn.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 c c %---------------------------------------------% c | Initialize statistic and timing information | c | for complex nonsymmetric Arnoldi code. | c %---------------------------------------------% subroutine zstatn c c %--------------------------------% c | See stat.doc for documentation | c %--------------------------------% c include 'stat.h' c %-----------------------% c | Executable Statements | c %-----------------------% nopx = 0 nbx = 0 nrorth = 0 nitref = 0 nrstrt = 0 tcaupd = 0.0D+0 tcaup2 = 0.0D+0 tcaitr = 0.0D+0 tceigh = 0.0D+0 tcgets = 0.0D+0 tcapps = 0.0D+0 tcconv = 0.0D+0 titref = 0.0D+0 tgetv0 = 0.0D+0 trvec = 0.0D+0 c %----------------------------------------------------% c | User time including reverse communication overhead | c %----------------------------------------------------% tmvopx = 0.0D+0 tmvbx = 0.0D+0 return c c %---------------% c | End of zstatn | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/ssortc.f000644 001750 001750 00000021752 11266605602 022140 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: ssortc c c\Description: c Sorts the complex array in XREAL and XIMAG into the order c specified by WHICH and optionally applies the permutation to the c real array Y. It is assumed that if an element of XIMAG is c nonzero, then its negative is also an element. In other words, c both members of a complex conjugate pair are to be sorted and the c pairs are kept adjacent to each other. c c\Usage: c call ssortc c ( WHICH, APPLY, N, XREAL, XIMAG, Y ) c c\Arguments c WHICH Character*2. (Input) c 'LM' -> sort XREAL,XIMAG into increasing order of magnitude. c 'SM' -> sort XREAL,XIMAG into decreasing order of magnitude. c 'LR' -> sort XREAL into increasing order of algebraic. c 'SR' -> sort XREAL into decreasing order of algebraic. c 'LI' -> sort XIMAG into increasing order of magnitude. c 'SI' -> sort XIMAG into decreasing order of magnitude. c NOTE: If an element of XIMAG is non-zero, then its negative c is also an element. c c APPLY Logical. (Input) c APPLY = .TRUE. -> apply the sorted order to array Y. c APPLY = .FALSE. -> do not apply the sorted order to array Y. c c N Integer. (INPUT) c Size of the arrays. c c XREAL, Real array of length N. (INPUT/OUTPUT) c XIMAG Real and imaginary part of the array to be sorted. c c Y Real array of length N. (INPUT/OUTPUT) c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.1' c Adapted from the sort routine in LANSO. c c\SCCS Information: @(#) c FILE: sortc.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine ssortc (which, apply, n, xreal, ximag, y) c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which logical apply integer n c c %-----------------% c | Array Arguments | c %-----------------% c Real & xreal(0:n-1), ximag(0:n-1), y(0:n-1) c c %---------------% c | Local Scalars | c %---------------% c integer i, igap, j Real & temp, temp1, temp2 c c %--------------------% c | External Functions | c %--------------------% c Real & slapy2 external slapy2 c c %-----------------------% c | Executable Statements | c %-----------------------% c igap = n / 2 c if (which .eq. 'LM') then c c %------------------------------------------------------% c | Sort XREAL,XIMAG into increasing order of magnitude. | c %------------------------------------------------------% c 10 continue if (igap .eq. 0) go to 9000 c do 30 i = igap, n-1 j = i-igap 20 continue c if (j.lt.0) go to 30 c temp1 = slapy2(xreal(j),ximag(j)) temp2 = slapy2(xreal(j+igap),ximag(j+igap)) c if (temp1.gt.temp2) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 30 end if j = j-igap go to 20 30 continue igap = igap / 2 go to 10 c else if (which .eq. 'SM') then c c %------------------------------------------------------% c | Sort XREAL,XIMAG into decreasing order of magnitude. | c %------------------------------------------------------% c 40 continue if (igap .eq. 0) go to 9000 c do 60 i = igap, n-1 j = i-igap 50 continue c if (j .lt. 0) go to 60 c temp1 = slapy2(xreal(j),ximag(j)) temp2 = slapy2(xreal(j+igap),ximag(j+igap)) c if (temp1.lt.temp2) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 60 endif j = j-igap go to 50 60 continue igap = igap / 2 go to 40 c else if (which .eq. 'LR') then c c %------------------------------------------------% c | Sort XREAL into increasing order of algebraic. | c %------------------------------------------------% c 70 continue if (igap .eq. 0) go to 9000 c do 90 i = igap, n-1 j = i-igap 80 continue c if (j.lt.0) go to 90 c if (xreal(j).gt.xreal(j+igap)) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 90 endif j = j-igap go to 80 90 continue igap = igap / 2 go to 70 c else if (which .eq. 'SR') then c c %------------------------------------------------% c | Sort XREAL into decreasing order of algebraic. | c %------------------------------------------------% c 100 continue if (igap .eq. 0) go to 9000 do 120 i = igap, n-1 j = i-igap 110 continue c if (j.lt.0) go to 120 c if (xreal(j).lt.xreal(j+igap)) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 120 endif j = j-igap go to 110 120 continue igap = igap / 2 go to 100 c else if (which .eq. 'LI') then c c %------------------------------------------------% c | Sort XIMAG into increasing order of magnitude. | c %------------------------------------------------% c 130 continue if (igap .eq. 0) go to 9000 do 150 i = igap, n-1 j = i-igap 140 continue c if (j.lt.0) go to 150 c if (abs(ximag(j)).gt.abs(ximag(j+igap))) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 150 endif j = j-igap go to 140 150 continue igap = igap / 2 go to 130 c else if (which .eq. 'SI') then c c %------------------------------------------------% c | Sort XIMAG into decreasing order of magnitude. | c %------------------------------------------------% c 160 continue if (igap .eq. 0) go to 9000 do 180 i = igap, n-1 j = i-igap 170 continue c if (j.lt.0) go to 180 c if (abs(ximag(j)).lt.abs(ximag(j+igap))) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 180 endif j = j-igap go to 170 180 continue igap = igap / 2 go to 160 end if c 9000 continue return c c %---------------% c | End of ssortc | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/znaitr.f000644 001750 001750 00000074633 11266605602 022140 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: znaitr c c\Description: c Reverse communication interface for applying NP additional steps to c a K step nonsymmetric Arnoldi factorization. c c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T c c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. c c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T c c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. c c where OP and B are as in znaupd. The B-norm of r_{k+p} is also c computed and returned. c c\Usage: c call znaitr c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, c IPNTR, WORKD, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c This is for the restart phase to force the new c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y, c IPNTR(3) is the pointer into WORK for B * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c IDO = 99: done c ------------------------------------------------------------- c When the routine is used in the "shift-and-invert" mode, the c vector B * Q is already available and do not need to be c recomputed in forming OP * Q. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. See znaupd. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c K Integer. (INPUT) c Current size of V and H. c c NP Integer. (INPUT) c Number of additional Arnoldi steps to take. c c NB Integer. (INPUT) c Blocksize to be used in the recurrence. c Only work for NB = 1 right now. The goal is to have a c program that implement both the block and non-block method. c c RESID Complex*16 array of length N. (INPUT/OUTPUT) c On INPUT: RESID contains the residual vector r_{k}. c On OUTPUT: RESID contains the residual vector r_{k+p}. c c RNORM Double precision scalar. (INPUT/OUTPUT) c B-norm of the starting residual on input. c B-norm of the updated residual r_{k+p} on output. c c V Complex*16 N by K+NP array. (INPUT/OUTPUT) c On INPUT: V contains the Arnoldi vectors in the first K c columns. c On OUTPUT: V contains the new NP Arnoldi vectors in the next c NP columns. The first K columns are unchanged. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Complex*16 (K+NP) by (K+NP) array. (INPUT/OUTPUT) c H is used to store the generated upper Hessenberg matrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORK for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Complex*16 work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The calling program should not c use WORKD as temporary workspace during the iteration !!!!!! c On input, WORKD(1:N) = B*RESID and is used to save some c computation at the first step. c c INFO Integer. (OUTPUT) c = 0: Normal exit. c > 0: Size of the spanning invariant subspace of OP found. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex*16 c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c zgetv0 ARPACK routine to generate the initial vector. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c zmout ARPACK utility routine that prints matrices c zvout ARPACK utility routine that prints vectors. c zlanhs LAPACK routine that computes various norms of a matrix. c zlascl LAPACK routine for careful scaling of a matrix. c dlabad LAPACK routine for defining the underflow and overflow c limits. c dlamch LAPACK routine that determines machine constants. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c zgemv Level 2 BLAS routine for matrix vector multiplication. c zaxpy Level 1 BLAS that computes a vector triad. c zcopy Level 1 BLAS that copies one vector to another . c zdotc Level 1 BLAS that computes the scalar product of two vectors. c zscal Level 1 BLAS that scales a vector. c zdscal Level 1 BLAS that scales a complex vector by a real number. c dznrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: naitr.F SID: 2.3 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c The algorithm implemented is: c c restart = .false. c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; c r_{k} contains the initial residual vector even for k = 0; c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already c computed by the calling program. c c betaj = rnorm ; p_{k+1} = B*r_{k} ; c For j = k+1, ..., k+np Do c 1) if ( betaj < tol ) stop or restart depending on j. c ( At present tol is zero ) c if ( restart ) generate a new starting vector. c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; c p_{j} = p_{j}/betaj c 3) r_{j} = OP*v_{j} where OP is defined as in znaupd c For shift-invert mode p_{j} = B*v_{j} is already available. c wnorm = || OP*v_{j} || c 4) Compute the j-th step residual vector. c w_{j} = V_{j}^T * B * OP * v_{j} c r_{j} = OP*v_{j} - V_{j} * w_{j} c H(:,j) = w_{j}; c H(j,j-1) = rnorm c rnorm = || r_(j) || c If (rnorm > 0.717*wnorm) accept step and go back to 1) c 5) Re-orthogonalization step: c s = V_{j}'*B*r_{j} c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || c alphaj = alphaj + s_{j}; c 6) Iterative refinement step: c If (rnorm1 > 0.717*rnorm) then c rnorm = rnorm1 c accept step and go back to 1) c Else c rnorm = rnorm1 c If this is the first time in step 6), go to 5) c Else r_{j} lies in the span of V_{j} numerically. c Set r_{j} = 0 and rnorm = 0; go to 1) c EndIf c End Do c c\EndLib c c----------------------------------------------------------------------- c subroutine znaitr & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, & ipntr, workd, info) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 integer ido, info, k, ldh, ldv, n, nb, np Double precision & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Complex*16 & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero Double precision & rone, rzero parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0), & rone = 1.0D+0, rzero = 0.0D+0) c c %--------------% c | Local Arrays | c %--------------% c Double precision & rtemp(2) c c %---------------% c | Local Scalars | c %---------------% c logical first, orth1, orth2, rstart, step3, step4 integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, & jj Double precision & ovfl, smlnum, tst1, ulp, unfl, betaj, & temp1, rnorm1, wnorm Complex*16 & cnorm c save first, orth1, orth2, rstart, step3, step4, & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, & betaj, rnorm1, smlnum, ulp, unfl, wnorm c c %----------------------% c | External Subroutines | c %----------------------% c external zaxpy, zcopy, zscal, zdscal, zgemv, zgetv0, & dlabad, zvout, zmout, ivout, second c c %--------------------% c | External Functions | c %--------------------% c Complex*16 & zdotc Double precision & dlamch, dznrm2, zlanhs, dlapy2 external zdotc, dznrm2, zlanhs, dlamch, dlapy2 c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic dimag, dble, max, sqrt c c %-----------------% c | Data statements | c %-----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then c c %-----------------------------------------% c | Set machine-dependent constants for the | c | the splitting and deflation criterion. | c | If norm(H) <= sqrt(OVFL), | c | overflow should not occur. | c | REFERENCE: LAPACK subroutine zlahqr | c %-----------------------------------------% c unfl = dlamch( 'safe minimum' ) ovfl = dble(one / unfl) call dlabad( unfl, ovfl ) ulp = dlamch( 'precision' ) smlnum = unfl*( n / ulp ) first = .false. end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mcaitr c c %------------------------------% c | Initial call to this routine | c %------------------------------% c info = 0 step3 = .false. step4 = .false. rstart = .false. orth1 = .false. orth2 = .false. j = k + 1 ipj = 1 irj = ipj + n ivj = irj + n end if c c %-------------------------------------------------% c | When in reverse communication mode one of: | c | STEP3, STEP4, ORTH1, ORTH2, RSTART | c | will be .true. when .... | c | STEP3: return from computing OP*v_{j}. | c | STEP4: return from computing B-norm of OP*v_{j} | c | ORTH1: return from computing B-norm of r_{j+1} | c | ORTH2: return from computing B-norm of | c | correction to the residual vector. | c | RSTART: return from OP computations needed by | c | zgetv0. | c %-------------------------------------------------% c if (step3) go to 50 if (step4) go to 60 if (orth1) go to 70 if (orth2) go to 90 if (rstart) go to 30 c c %-----------------------------% c | Else this is the first step | c %-----------------------------% c c %--------------------------------------------------------------% c | | c | A R N O L D I I T E R A T I O N L O O P | c | | c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | c %--------------------------------------------------------------% 1000 continue c if (msglvl .gt. 1) then call ivout (logfil, 1, j, ndigit, & '_naitr: generating Arnoldi vector number') call dvout (logfil, 1, rnorm, ndigit, & '_naitr: B-norm of the current residual is') end if c c %---------------------------------------------------% c | STEP 1: Check if the B norm of j-th residual | c | vector is zero. Equivalent to determine whether | c | an exact j-step Arnoldi factorization is present. | c %---------------------------------------------------% c betaj = rnorm if (rnorm .gt. rzero) go to 40 c c %---------------------------------------------------% c | Invariant subspace found, generate a new starting | c | vector which is orthogonal to the current Arnoldi | c | basis and continue the iteration. | c %---------------------------------------------------% c if (msglvl .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_naitr: ****** RESTART AT STEP ******') end if c c %---------------------------------------------% c | ITRY is the loop variable that controls the | c | maximum amount of times that a restart is | c | attempted. NRSTRT is used by stat.h | c %---------------------------------------------% c betaj = rzero nrstrt = nrstrt + 1 itry = 1 20 continue rstart = .true. ido = 0 30 continue c c %--------------------------------------% c | If in reverse communication mode and | c | RSTART = .true. flow returns here. | c %--------------------------------------% c call zgetv0 (ido, bmat, itry, .false., n, j, v, ldv, & resid, rnorm, ipntr, workd, ierr) if (ido .ne. 99) go to 9000 if (ierr .lt. 0) then itry = itry + 1 if (itry .le. 3) go to 20 c c %------------------------------------------------% c | Give up after several restart attempts. | c | Set INFO to the size of the invariant subspace | c | which spans OP and exit. | c %------------------------------------------------% c info = j - 1 call second (t1) tcaitr = tcaitr + (t1 - t0) ido = 99 go to 9000 end if c 40 continue c c %---------------------------------------------------------% c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | c | when reciprocating a small RNORM, test against lower | c | machine bound. | c %---------------------------------------------------------% c call zcopy (n, resid, 1, v(1,j), 1) if ( rnorm .ge. unfl) then temp1 = rone / rnorm call zdscal (n, temp1, v(1,j), 1) call zdscal (n, temp1, workd(ipj), 1) else c c %-----------------------------------------% c | To scale both v_{j} and p_{j} carefully | c | use LAPACK routine zlascl | c %-----------------------------------------% c call zlascl ('General', i, i, rnorm, rone, & n, 1, v(1,j), n, infol) call zlascl ('General', i, i, rnorm, rone, & n, 1, workd(ipj), n, infol) end if c c %------------------------------------------------------% c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | c | Note that this is not quite yet r_{j}. See STEP 4 | c %------------------------------------------------------% c step3 = .true. nopx = nopx + 1 call second (t2) call zcopy (n, v(1,j), 1, workd(ivj), 1) ipntr(1) = ivj ipntr(2) = irj ipntr(3) = ipj ido = 1 c c %-----------------------------------% c | Exit in order to compute OP*v_{j} | c %-----------------------------------% c go to 9000 50 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | c | if step3 = .true. | c %----------------------------------% c call second (t3) tmvopx = tmvopx + (t3 - t2) step3 = .false. c c %------------------------------------------% c | Put another copy of OP*v_{j} into RESID. | c %------------------------------------------% c call zcopy (n, workd(irj), 1, resid, 1) c c %---------------------------------------% c | STEP 4: Finish extending the Arnoldi | c | factorization to length j. | c %---------------------------------------% c call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 step4 = .true. ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-------------------------------------% c | Exit in order to compute B*OP*v_{j} | c %-------------------------------------% c go to 9000 else if (bmat .eq. 'I') then call zcopy (n, resid, 1, workd(ipj), 1) end if 60 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | c | if step4 = .true. | c %----------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c step4 = .false. c c %-------------------------------------% c | The following is needed for STEP 5. | c | Compute the B-norm of OP*v_{j}. | c %-------------------------------------% c if (bmat .eq. 'G') then cnorm = zdotc (n, resid, 1, workd(ipj), 1) wnorm = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) ) else if (bmat .eq. 'I') then wnorm = dznrm2(n, resid, 1) end if c c %-----------------------------------------% c | Compute the j-th residual corresponding | c | to the j step factorization. | c | Use Classical Gram Schmidt and compute: | c | w_{j} <- V_{j}^T * B * OP * v_{j} | c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | c %-----------------------------------------% c c c %------------------------------------------% c | Compute the j Fourier coefficients w_{j} | c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | c %------------------------------------------% c call zgemv ('C', n, j, one, v, ldv, workd(ipj), 1, & zero, h(1,j), 1) c c %--------------------------------------% c | Orthogonalize r_{j} against V_{j}. | c | RESID contains OP*v_{j}. See STEP 3. | c %--------------------------------------% c call zgemv ('N', n, j, -one, v, ldv, h(1,j), 1, & one, resid, 1) c if (j .gt. 1) h(j,j-1) = dcmplx(betaj, rzero) c call second (t4) c orth1 = .true. c call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call zcopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %----------------------------------% c | Exit in order to compute B*r_{j} | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call zcopy (n, resid, 1, workd(ipj), 1) end if 70 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH1 = .true. | c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c orth1 = .false. c c %------------------------------% c | Compute the B-norm of r_{j}. | c %------------------------------% c if (bmat .eq. 'G') then cnorm = zdotc (n, resid, 1, workd(ipj), 1) rnorm = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) ) else if (bmat .eq. 'I') then rnorm = dznrm2(n, resid, 1) end if c c %-----------------------------------------------------------% c | STEP 5: Re-orthogonalization / Iterative refinement phase | c | Maximum NITER_ITREF tries. | c | | c | s = V_{j}^T * B * r_{j} | c | r_{j} = r_{j} - V_{j}*s | c | alphaj = alphaj + s_{j} | c | | c | The stopping criteria used for iterative refinement is | c | discussed in Parlett's book SEP, page 107 and in Gragg & | c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | c | Determine if we need to correct the residual. The goal is | c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | c | The following test determines whether the sine of the | c | angle between OP*x and the computed residual is less | c | than or equal to 0.717. | c %-----------------------------------------------------------% c if ( rnorm .gt. 0.717*wnorm ) go to 100 c iter = 0 nrorth = nrorth + 1 c c %---------------------------------------------------% c | Enter the Iterative refinement phase. If further | c | refinement is necessary, loop back here. The loop | c | variable is ITER. Perform a step of Classical | c | Gram-Schmidt using all the Arnoldi vectors V_{j} | c %---------------------------------------------------% c 80 continue c if (msglvl .gt. 2) then rtemp(1) = wnorm rtemp(2) = rnorm call dvout (logfil, 2, rtemp, ndigit, & '_naitr: re-orthogonalization; wnorm and rnorm are') call zvout (logfil, j, h(1,j), ndigit, & '_naitr: j-th column of H') end if c c %----------------------------------------------------% c | Compute V_{j}^T * B * r_{j}. | c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | c %----------------------------------------------------% c call zgemv ('C', n, j, one, v, ldv, workd(ipj), 1, & zero, workd(irj), 1) c c %---------------------------------------------% c | Compute the correction to the residual: | c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | c | The correction to H is v(:,1:J)*H(1:J,1:J) | c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | c %---------------------------------------------% c call zgemv ('N', n, j, -one, v, ldv, workd(irj), 1, & one, resid, 1) call zaxpy (j, one, workd(irj), 1, h(1,j), 1) c orth2 = .true. call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call zcopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-----------------------------------% c | Exit in order to compute B*r_{j}. | c | r_{j} is the corrected residual. | c %-----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call zcopy (n, resid, 1, workd(ipj), 1) end if 90 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH2 = .true. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c c %-----------------------------------------------------% c | Compute the B-norm of the corrected residual r_{j}. | c %-----------------------------------------------------% c if (bmat .eq. 'G') then cnorm = zdotc (n, resid, 1, workd(ipj), 1) rnorm1 = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) ) else if (bmat .eq. 'I') then rnorm1 = dznrm2(n, resid, 1) end if c if (msglvl .gt. 0 .and. iter .gt. 0 ) then call ivout (logfil, 1, j, ndigit, & '_naitr: Iterative refinement for Arnoldi residual') if (msglvl .gt. 2) then rtemp(1) = rnorm rtemp(2) = rnorm1 call dvout (logfil, 2, rtemp, ndigit, & '_naitr: iterative refinement ; rnorm and rnorm1 are') end if end if c c %-----------------------------------------% c | Determine if we need to perform another | c | step of re-orthogonalization. | c %-----------------------------------------% c if ( rnorm1 .gt. 0.717*rnorm ) then c c %---------------------------------------% c | No need for further refinement. | c | The cosine of the angle between the | c | corrected residual vector and the old | c | residual vector is greater than 0.717 | c | In other words the corrected residual | c | and the old residual vector share an | c | angle of less than arcCOS(0.717) | c %---------------------------------------% c rnorm = rnorm1 c else c c %-------------------------------------------% c | Another step of iterative refinement step | c | is required. NITREF is used by stat.h | c %-------------------------------------------% c nitref = nitref + 1 rnorm = rnorm1 iter = iter + 1 if (iter .le. 1) go to 80 c c %-------------------------------------------------% c | Otherwise RESID is numerically in the span of V | c %-------------------------------------------------% c do 95 jj = 1, n resid(jj) = zero 95 continue rnorm = rzero end if c c %----------------------------------------------% c | Branch here directly if iterative refinement | c | wasn't necessary or after at most NITER_REF | c | steps of iterative refinement. | c %----------------------------------------------% c 100 continue c rstart = .false. orth2 = .false. c call second (t5) titref = titref + (t5 - t4) c c %------------------------------------% c | STEP 6: Update j = j+1; Continue | c %------------------------------------% c j = j + 1 if (j .gt. k+np) then call second (t1) tcaitr = tcaitr + (t1 - t0) ido = 99 do 110 i = max(1,k), k+np-1 c c %--------------------------------------------% c | Check for splitting and deflation. | c | Use a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine zlahqr | c %--------------------------------------------% c tst1 = dlapy2(dble(h(i,i)),dimag(h(i,i))) & + dlapy2(dble(h(i+1,i+1)), dimag(h(i+1,i+1))) if( tst1.eq.dble(zero) ) & tst1 = zlanhs( '1', k+np, h, ldh, workd(n+1) ) if( dlapy2(dble(h(i+1,i)),dimag(h(i+1,i))) .le. & max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 110 continue c if (msglvl .gt. 2) then call zmout (logfil, k+np, k+np, h, ldh, ndigit, & '_naitr: Final upper Hessenberg matrix H of order K+NP') end if c go to 9000 end if c c %--------------------------------------------------------% c | Loop back to extend the factorization by another step. | c %--------------------------------------------------------% c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 9000 continue return c c %---------------% c | End of znaitr | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/cmout.f000644 001750 001750 00000021063 11266605602 021745 0ustar00geuzainegeuzaine000000 000000 * * Routine: CMOUT * * Purpose: Complex matrix output routine. * * Usage: CALL CMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) * * Arguments * M - Number of rows of A. (Input) * N - Number of columns of A. (Input) * A - Complex M by N matrix to be printed. (Input) * LDA - Leading dimension of A exactly as specified in the * dimension statement of the calling program. (Input) * IFMT - Format to be used in printing matrix A. (Input) * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) * If IDIGIT .LT. 0, printing is done with 72 columns. * If IDIGIT .GT. 0, printing is done with 132 columns. * *\SCCS Information: @(#) * FILE: cmout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2 * *----------------------------------------------------------------------- * SUBROUTINE CMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) * ... * ... SPECIFICATIONS FOR ARGUMENTS INTEGER M, N, IDIGIT, LDA, LOUT Complex & A( LDA, * ) CHARACTER IFMT*( * ) * ... * ... SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I, J, NDIGIT, K1, K2, LLL CHARACTER*1 ICOL( 3 ) CHARACTER*80 LINE * ... * ... SPECIFICATIONS INTRINSICS INTRINSIC MIN * DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', $ 'l' / * ... * ... FIRST EXECUTABLE STATEMENT * LLL = MIN( LEN( IFMT ), 80 ) DO 10 I = 1, LLL LINE( I: I ) = '-' 10 CONTINUE * DO 20 I = LLL + 1, 80 LINE( I: I ) = ' ' 20 CONTINUE * WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) 9999 FORMAT( / 1X, A / 1X, A ) * IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) $ RETURN NDIGIT = IDIGIT IF( IDIGIT.EQ.0 ) $ NDIGIT = 4 * *======================================================================= * CODE FOR OUTPUT USING 72 COLUMNS FORMAT *======================================================================= * IF( IDIGIT.LT.0 ) THEN NDIGIT = -IDIGIT IF( NDIGIT.LE.4 ) THEN DO 40 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) DO 30 I = 1, M IF (K1.NE.N) THEN WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 ) ELSE WRITE( LOUT, 9984 )I, ( A( I, J ), J = K1, K2 ) END IF 30 CONTINUE 40 CONTINUE * ELSE IF( NDIGIT.LE.6 ) THEN DO 60 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) DO 50 I = 1, M IF (K1.NE.N) THEN WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 ) ELSE WRITE( LOUT, 9983 )I, ( A( I, J ), J = K1, K2 ) END IF 50 CONTINUE 60 CONTINUE * ELSE IF( NDIGIT.LE.8 ) THEN DO 80 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) DO 70 I = 1, M IF (K1.NE.N) THEN WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 ) ELSE WRITE( LOUT, 9982 )I, ( A( I, J ), J = K1, K2 ) END IF 70 CONTINUE 80 CONTINUE * ELSE DO 100 K1 = 1, N WRITE( LOUT, 9995 ) ICOL, K1 DO 90 I = 1, M WRITE( LOUT, 9991 )I, A( I, K1 ) 90 CONTINUE 100 CONTINUE END IF * *======================================================================= * CODE FOR OUTPUT USING 132 COLUMNS FORMAT *======================================================================= * ELSE IF( NDIGIT.LE.4 ) THEN DO 120 K1 = 1, N, 4 K2 = MIN0( N, K1+3 ) WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) DO 110 I = 1, M IF ((K1+3).LE.N) THEN WRITE( LOUT, 9974 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+3-N).EQ.1) THEN WRITE( LOUT, 9964 )I, ( A( I, J ), J = k1, K2 ) ELSE IF ((K1+3-N).EQ.2) THEN WRITE( LOUT, 9954 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+3-N).EQ.3) THEN WRITE( LOUT, 9944 )I, ( A( I, J ), J = K1, K2 ) END IF 110 CONTINUE 120 CONTINUE * ELSE IF( NDIGIT.LE.6 ) THEN DO 140 K1 = 1, N, 3 K2 = MIN0( N, K1+ 2) WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) DO 130 I = 1, M IF ((K1+2).LE.N) THEN WRITE( LOUT, 9973 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+2-N).EQ.1) THEN WRITE( LOUT, 9963 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+2-N).EQ.2) THEN WRITE( LOUT, 9953 )I, ( A( I, J ), J = K1, K2 ) END IF 130 CONTINUE 140 CONTINUE * ELSE IF( NDIGIT.LE.8 ) THEN DO 160 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) DO 150 I = 1, M IF ((K1+2).LE.N) THEN WRITE( LOUT, 9972 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+2-N).EQ.1) THEN WRITE( LOUT, 9962 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+2-N).EQ.2) THEN WRITE( LOUT, 9952 )I, ( A( I, J ), J = K1, K2 ) END IF 150 CONTINUE 160 CONTINUE * ELSE DO 180 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 ) DO 170 I = 1, M IF ((K1+1).LE.N) THEN WRITE( LOUT, 9971 )I, ( A( I, J ), J = K1, K2 ) ELSE WRITE( LOUT, 9961 )I, ( A( I, J ), J = K1, K2 ) END IF 170 CONTINUE 180 CONTINUE END IF END IF WRITE( LOUT, 9990 ) * 9998 FORMAT( 11X, 4( 9X, 3A1, I4, 9X ) ) 9997 FORMAT( 10X, 4( 11X, 3A1, I4, 11X ) ) 9996 FORMAT( 10X, 3( 13X, 3A1, I4, 13X ) ) 9995 FORMAT( 12X, 2( 18x, 3A1, I4, 18X ) ) * *======================================================== * FORMAT FOR 72 COLUMN *======================================================== * * DISPLAY 4 SIGNIFICANT DIGITS * 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E10.3,',',E10.3,') ') ) 9984 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E10.3,',',E10.3,') ') ) * * DISPLAY 6 SIGNIFICANT DIGITS * 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E12.5,',',E12.5,') ') ) 9983 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E12.5,',',E12.5,') ') ) * * DISPLAY 8 SIGNIFICANT DIGITS * 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E14.7,',',E14.7,') ') ) 9982 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E14.7,',',E14.7,') ') ) * * DISPLAY 13 SIGNIFICANT DIGITS * 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E20.13,',',E20.13,')') ) 9990 FORMAT( 1X, ' ' ) * * *======================================================== * FORMAT FOR 132 COLUMN *======================================================== * * DISPLAY 4 SIGNIFICANT DIGIT * 9974 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,4('(',E10.3,',',E10.3,') ') ) 9964 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',E10.3,',',E10.3,') ') ) 9954 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E10.3,',',E10.3,') ') ) 9944 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E10.3,',',E10.3,') ') ) * * DISPLAY 6 SIGNIFICANT DIGIT * 9973 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',E12.5,',',E12.5,') ') ) 9963 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E12.5,',',E12.5,') ') ) 9953 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E12.5,',',E12.5,') ') ) * * DISPLAY 8 SIGNIFICANT DIGIT * 9972 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',E14.7,',',E14.7,') ') ) 9962 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E14.7,',',E14.7,') ') ) 9952 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E14.7,',',E14.7,') ') ) * * DISPLAY 13 SIGNIFICANT DIGIT * 9971 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E20.13,',',E20.13, & ') ')) 9961 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E20.13,',',E20.13, & ') ')) * * * * RETURN END getdp-2.4.2-source/contrib/Arpack/dstats.f000644 001750 001750 00000002216 11266605602 022117 0ustar00geuzainegeuzaine000000 000000 c c\SCCS Information: @(#) c FILE: stats.F SID: 2.1 DATE OF SID: 4/19/96 RELEASE: 2 c %---------------------------------------------% c | Initialize statistic and timing information | c | for symmetric Arnoldi code. | c %---------------------------------------------% subroutine dstats c %--------------------------------% c | See stat.doc for documentation | c %--------------------------------% include 'stat.h' c %-----------------------% c | Executable Statements | c %-----------------------% nopx = 0 nbx = 0 nrorth = 0 nitref = 0 nrstrt = 0 tsaupd = 0.0D+0 tsaup2 = 0.0D+0 tsaitr = 0.0D+0 tseigt = 0.0D+0 tsgets = 0.0D+0 tsapps = 0.0D+0 tsconv = 0.0D+0 titref = 0.0D+0 tgetv0 = 0.0D+0 trvec = 0.0D+0 c %----------------------------------------------------% c | User time including reverse communication overhead | c %----------------------------------------------------% tmvopx = 0.0D+0 tmvbx = 0.0D+0 return c c End of dstats c end getdp-2.4.2-source/contrib/Arpack/ssaitr.f000644 001750 001750 00000073727 11266605602 022141 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: ssaitr c c\Description: c Reverse communication interface for applying NP additional steps to c a K step symmetric Arnoldi factorization. c c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T c c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. c c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T c c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. c c where OP and B are as in ssaupd. The B-norm of r_{k+p} is also c computed and returned. c c\Usage: c call ssaitr c ( IDO, BMAT, N, K, NP, MODE, RESID, RNORM, V, LDV, H, LDH, c IPNTR, WORKD, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c This is for the restart phase to force the new c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y, c IPNTR(3) is the pointer into WORK for B * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c IDO = 99: done c ------------------------------------------------------------- c When the routine is used in the "shift-and-invert" mode, the c vector B * Q is already available and does not need to be c recomputed in forming OP * Q. c c BMAT Character*1. (INPUT) c BMAT specifies the type of matrix B that defines the c semi-inner product for the operator OP. See ssaupd. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*M*x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c K Integer. (INPUT) c Current order of H and the number of columns of V. c c NP Integer. (INPUT) c Number of additional Arnoldi steps to take. c c MODE Integer. (INPUT) c Signifies which form for "OP". If MODE=2 then c a reduction in the number of B matrix vector multiplies c is possible since the B-norm of OP*x is equivalent to c the inv(B)-norm of A*x. c c RESID Real array of length N. (INPUT/OUTPUT) c On INPUT: RESID contains the residual vector r_{k}. c On OUTPUT: RESID contains the residual vector r_{k+p}. c c RNORM Real scalar. (INPUT/OUTPUT) c On INPUT the B-norm of r_{k}. c On OUTPUT the B-norm of the updated residual r_{k+p}. c c V Real N by K+NP array. (INPUT/OUTPUT) c On INPUT: V contains the Arnoldi vectors in the first K c columns. c On OUTPUT: V contains the new NP Arnoldi vectors in the next c NP columns. The first K columns are unchanged. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Real (K+NP) by 2 array. (INPUT/OUTPUT) c H is used to store the generated symmetric tridiagonal matrix c with the subdiagonal in the first column starting at H(2,1) c and the main diagonal in the second column. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORK for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The calling program should not c use WORKD as temporary workspace during the iteration !!!!!! c On INPUT, WORKD(1:N) = B*RESID where RESID is associated c with the K step Arnoldi factorization. Used to save some c computation at the first step. c On OUTPUT, WORKD(1:N) = B*RESID where RESID is associated c with the K+NP step Arnoldi factorization. c c INFO Integer. (OUTPUT) c = 0: Normal exit. c > 0: Size of an invariant subspace of OP is found that is c less than K + NP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c sgetv0 ARPACK routine to generate the initial vector. c ivout ARPACK utility routine that prints integers. c smout ARPACK utility routine that prints matrices. c svout ARPACK utility routine that prints vectors. c slamch LAPACK routine that determines machine constants. c slascl LAPACK routine for careful scaling of a matrix. c sgemv Level 2 BLAS routine for matrix vector multiplication. c saxpy Level 1 BLAS that computes a vector triad. c sscal Level 1 BLAS that scales a vector. c scopy Level 1 BLAS that copies one vector to another . c sdot Level 1 BLAS that computes the scalar product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/93: Version ' 2.4' c c\SCCS Information: @(#) c FILE: saitr.F SID: 2.6 DATE OF SID: 8/28/96 RELEASE: 2 c c\Remarks c The algorithm implemented is: c c restart = .false. c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; c r_{k} contains the initial residual vector even for k = 0; c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already c computed by the calling program. c c betaj = rnorm ; p_{k+1} = B*r_{k} ; c For j = k+1, ..., k+np Do c 1) if ( betaj < tol ) stop or restart depending on j. c if ( restart ) generate a new starting vector. c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; c p_{j} = p_{j}/betaj c 3) r_{j} = OP*v_{j} where OP is defined as in ssaupd c For shift-invert mode p_{j} = B*v_{j} is already available. c wnorm = || OP*v_{j} || c 4) Compute the j-th step residual vector. c w_{j} = V_{j}^T * B * OP * v_{j} c r_{j} = OP*v_{j} - V_{j} * w_{j} c alphaj <- j-th component of w_{j} c rnorm = || r_{j} || c betaj+1 = rnorm c If (rnorm > 0.717*wnorm) accept step and go back to 1) c 5) Re-orthogonalization step: c s = V_{j}'*B*r_{j} c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || c alphaj = alphaj + s_{j}; c 6) Iterative refinement step: c If (rnorm1 > 0.717*rnorm) then c rnorm = rnorm1 c accept step and go back to 1) c Else c rnorm = rnorm1 c If this is the first time in step 6), go to 5) c Else r_{j} lies in the span of V_{j} numerically. c Set r_{j} = 0 and rnorm = 0; go to 1) c EndIf c End Do c c\EndLib c c----------------------------------------------------------------------- c subroutine ssaitr & (ido, bmat, n, k, np, mode, resid, rnorm, v, ldv, h, ldh, & ipntr, workd, info) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 integer ido, info, k, ldh, ldv, n, mode, np Real & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Real & h(ldh,2), resid(n), v(ldv,k+np), workd(3*n) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %---------------% c | Local Scalars | c %---------------% c logical first, orth1, orth2, rstart, step3, step4 integer i, ierr, ipj, irj, ivj, iter, itry, j, msglvl, & infol, jj Real & rnorm1, wnorm, safmin, temp1 save orth1, orth2, rstart, step3, step4, & ierr, ipj, irj, ivj, iter, itry, j, msglvl, & rnorm1, safmin, wnorm c c %-----------------------% c | Local Array Arguments | c %-----------------------% c Real & xtemp(2) c c %----------------------% c | External Subroutines | c %----------------------% c external saxpy, scopy, sscal, sgemv, sgetv0, svout, smout, & slascl, ivout, second c c %--------------------% c | External Functions | c %--------------------% c Real & sdot, snrm2, slamch external sdot, snrm2, slamch c c %-----------------% c | Data statements | c %-----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then first = .false. c c %--------------------------------% c | safmin = safe minimum is such | c | that 1/sfmin does not overflow | c %--------------------------------% c safmin = slamch('safmin') end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = msaitr c c %------------------------------% c | Initial call to this routine | c %------------------------------% c info = 0 step3 = .false. step4 = .false. rstart = .false. orth1 = .false. orth2 = .false. c c %--------------------------------% c | Pointer to the current step of | c | the factorization to build | c %--------------------------------% c j = k + 1 c c %------------------------------------------% c | Pointers used for reverse communication | c | when using WORKD. | c %------------------------------------------% c ipj = 1 irj = ipj + n ivj = irj + n end if c c %-------------------------------------------------% c | When in reverse communication mode one of: | c | STEP3, STEP4, ORTH1, ORTH2, RSTART | c | will be .true. | c | STEP3: return from computing OP*v_{j}. | c | STEP4: return from computing B-norm of OP*v_{j} | c | ORTH1: return from computing B-norm of r_{j+1} | c | ORTH2: return from computing B-norm of | c | correction to the residual vector. | c | RSTART: return from OP computations needed by | c | sgetv0. | c %-------------------------------------------------% c if (step3) go to 50 if (step4) go to 60 if (orth1) go to 70 if (orth2) go to 90 if (rstart) go to 30 c c %------------------------------% c | Else this is the first step. | c %------------------------------% c c %--------------------------------------------------------------% c | | c | A R N O L D I I T E R A T I O N L O O P | c | | c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | c %--------------------------------------------------------------% c 1000 continue c if (msglvl .gt. 2) then call ivout (logfil, 1, j, ndigit, & '_saitr: generating Arnoldi vector no.') call svout (logfil, 1, rnorm, ndigit, & '_saitr: B-norm of the current residual =') end if c c %---------------------------------------------------------% c | Check for exact zero. Equivalent to determing whether a | c | j-step Arnoldi factorization is present. | c %---------------------------------------------------------% c if (rnorm .gt. zero) go to 40 c c %---------------------------------------------------% c | Invariant subspace found, generate a new starting | c | vector which is orthogonal to the current Arnoldi | c | basis and continue the iteration. | c %---------------------------------------------------% c if (msglvl .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_saitr: ****** restart at step ******') end if c c %---------------------------------------------% c | ITRY is the loop variable that controls the | c | maximum amount of times that a restart is | c | attempted. NRSTRT is used by stat.h | c %---------------------------------------------% c nrstrt = nrstrt + 1 itry = 1 20 continue rstart = .true. ido = 0 30 continue c c %--------------------------------------% c | If in reverse communication mode and | c | RSTART = .true. flow returns here. | c %--------------------------------------% c call sgetv0 (ido, bmat, itry, .false., n, j, v, ldv, & resid, rnorm, ipntr, workd, ierr) if (ido .ne. 99) go to 9000 if (ierr .lt. 0) then itry = itry + 1 if (itry .le. 3) go to 20 c c %------------------------------------------------% c | Give up after several restart attempts. | c | Set INFO to the size of the invariant subspace | c | which spans OP and exit. | c %------------------------------------------------% c info = j - 1 call second (t1) tsaitr = tsaitr + (t1 - t0) ido = 99 go to 9000 end if c 40 continue c c %---------------------------------------------------------% c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | c | when reciprocating a small RNORM, test against lower | c | machine bound. | c %---------------------------------------------------------% c call scopy (n, resid, 1, v(1,j), 1) if (rnorm .ge. safmin) then temp1 = one / rnorm call sscal (n, temp1, v(1,j), 1) call sscal (n, temp1, workd(ipj), 1) else c c %-----------------------------------------% c | To scale both v_{j} and p_{j} carefully | c | use LAPACK routine SLASCL | c %-----------------------------------------% c call slascl ('General', i, i, rnorm, one, n, 1, & v(1,j), n, infol) call slascl ('General', i, i, rnorm, one, n, 1, & workd(ipj), n, infol) end if c c %------------------------------------------------------% c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | c | Note that this is not quite yet r_{j}. See STEP 4 | c %------------------------------------------------------% c step3 = .true. nopx = nopx + 1 call second (t2) call scopy (n, v(1,j), 1, workd(ivj), 1) ipntr(1) = ivj ipntr(2) = irj ipntr(3) = ipj ido = 1 c c %-----------------------------------% c | Exit in order to compute OP*v_{j} | c %-----------------------------------% c go to 9000 50 continue c c %-----------------------------------% c | Back from reverse communication; | c | WORKD(IRJ:IRJ+N-1) := OP*v_{j}. | c %-----------------------------------% c call second (t3) tmvopx = tmvopx + (t3 - t2) c step3 = .false. c c %------------------------------------------% c | Put another copy of OP*v_{j} into RESID. | c %------------------------------------------% c call scopy (n, workd(irj), 1, resid, 1) c c %-------------------------------------------% c | STEP 4: Finish extending the symmetric | c | Arnoldi to length j. If MODE = 2 | c | then B*OP = B*inv(B)*A = A and | c | we don't need to compute B*OP. | c | NOTE: If MODE = 2 WORKD(IVJ:IVJ+N-1) is | c | assumed to have A*v_{j}. | c %-------------------------------------------% c if (mode .eq. 2) go to 65 call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 step4 = .true. ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-------------------------------------% c | Exit in order to compute B*OP*v_{j} | c %-------------------------------------% c go to 9000 else if (bmat .eq. 'I') then call scopy(n, resid, 1 , workd(ipj), 1) end if 60 continue c c %-----------------------------------% c | Back from reverse communication; | c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j}. | c %-----------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c step4 = .false. c c %-------------------------------------% c | The following is needed for STEP 5. | c | Compute the B-norm of OP*v_{j}. | c %-------------------------------------% c 65 continue if (mode .eq. 2) then c c %----------------------------------% c | Note that the B-norm of OP*v_{j} | c | is the inv(B)-norm of A*v_{j}. | c %----------------------------------% c wnorm = sdot (n, resid, 1, workd(ivj), 1) wnorm = sqrt(abs(wnorm)) else if (bmat .eq. 'G') then wnorm = sdot (n, resid, 1, workd(ipj), 1) wnorm = sqrt(abs(wnorm)) else if (bmat .eq. 'I') then wnorm = snrm2(n, resid, 1) end if c c %-----------------------------------------% c | Compute the j-th residual corresponding | c | to the j step factorization. | c | Use Classical Gram Schmidt and compute: | c | w_{j} <- V_{j}^T * B * OP * v_{j} | c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | c %-----------------------------------------% c c c %------------------------------------------% c | Compute the j Fourier coefficients w_{j} | c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | c %------------------------------------------% c if (mode .ne. 2 ) then call sgemv('T', n, j, one, v, ldv, workd(ipj), 1, zero, & workd(irj), 1) else if (mode .eq. 2) then call sgemv('T', n, j, one, v, ldv, workd(ivj), 1, zero, & workd(irj), 1) end if c c %--------------------------------------% c | Orthgonalize r_{j} against V_{j}. | c | RESID contains OP*v_{j}. See STEP 3. | c %--------------------------------------% c call sgemv('N', n, j, -one, v, ldv, workd(irj), 1, one, & resid, 1) c c %--------------------------------------% c | Extend H to have j rows and columns. | c %--------------------------------------% c h(j,2) = workd(irj + j - 1) if (j .eq. 1 .or. rstart) then h(j,1) = zero else h(j,1) = rnorm end if call second (t4) c orth1 = .true. iter = 0 c call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call scopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %----------------------------------% c | Exit in order to compute B*r_{j} | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd(ipj), 1) end if 70 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH1 = .true. | c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c orth1 = .false. c c %------------------------------% c | Compute the B-norm of r_{j}. | c %------------------------------% c if (bmat .eq. 'G') then rnorm = sdot (n, resid, 1, workd(ipj), 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = snrm2(n, resid, 1) end if c c %-----------------------------------------------------------% c | STEP 5: Re-orthogonalization / Iterative refinement phase | c | Maximum NITER_ITREF tries. | c | | c | s = V_{j}^T * B * r_{j} | c | r_{j} = r_{j} - V_{j}*s | c | alphaj = alphaj + s_{j} | c | | c | The stopping criteria used for iterative refinement is | c | discussed in Parlett's book SEP, page 107 and in Gragg & | c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | c | Determine if we need to correct the residual. The goal is | c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | c %-----------------------------------------------------------% c if (rnorm .gt. 0.717*wnorm) go to 100 nrorth = nrorth + 1 c c %---------------------------------------------------% c | Enter the Iterative refinement phase. If further | c | refinement is necessary, loop back here. The loop | c | variable is ITER. Perform a step of Classical | c | Gram-Schmidt using all the Arnoldi vectors V_{j} | c %---------------------------------------------------% c 80 continue c if (msglvl .gt. 2) then xtemp(1) = wnorm xtemp(2) = rnorm call svout (logfil, 2, xtemp, ndigit, & '_saitr: re-orthonalization ; wnorm and rnorm are') end if c c %----------------------------------------------------% c | Compute V_{j}^T * B * r_{j}. | c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | c %----------------------------------------------------% c call sgemv ('T', n, j, one, v, ldv, workd(ipj), 1, & zero, workd(irj), 1) c c %----------------------------------------------% c | Compute the correction to the residual: | c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | c | The correction to H is v(:,1:J)*H(1:J,1:J) + | c | v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j, but only | c | H(j,j) is updated. | c %----------------------------------------------% c call sgemv ('N', n, j, -one, v, ldv, workd(irj), 1, & one, resid, 1) c if (j .eq. 1 .or. rstart) h(j,1) = zero h(j,2) = h(j,2) + workd(irj + j - 1) c orth2 = .true. call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call scopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-----------------------------------% c | Exit in order to compute B*r_{j}. | c | r_{j} is the corrected residual. | c %-----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd(ipj), 1) end if 90 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH2 = .true. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c c %-----------------------------------------------------% c | Compute the B-norm of the corrected residual r_{j}. | c %-----------------------------------------------------% c if (bmat .eq. 'G') then rnorm1 = sdot (n, resid, 1, workd(ipj), 1) rnorm1 = sqrt(abs(rnorm1)) else if (bmat .eq. 'I') then rnorm1 = snrm2(n, resid, 1) end if c if (msglvl .gt. 0 .and. iter .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_saitr: Iterative refinement for Arnoldi residual') if (msglvl .gt. 2) then xtemp(1) = rnorm xtemp(2) = rnorm1 call svout (logfil, 2, xtemp, ndigit, & '_saitr: iterative refinement ; rnorm and rnorm1 are') end if end if c c %-----------------------------------------% c | Determine if we need to perform another | c | step of re-orthogonalization. | c %-----------------------------------------% c if (rnorm1 .gt. 0.717*rnorm) then c c %--------------------------------% c | No need for further refinement | c %--------------------------------% c rnorm = rnorm1 c else c c %-------------------------------------------% c | Another step of iterative refinement step | c | is required. NITREF is used by stat.h | c %-------------------------------------------% c nitref = nitref + 1 rnorm = rnorm1 iter = iter + 1 if (iter .le. 1) go to 80 c c %-------------------------------------------------% c | Otherwise RESID is numerically in the span of V | c %-------------------------------------------------% c do 95 jj = 1, n resid(jj) = zero 95 continue rnorm = zero end if c c %----------------------------------------------% c | Branch here directly if iterative refinement | c | wasn't necessary or after at most NITER_REF | c | steps of iterative refinement. | c %----------------------------------------------% c 100 continue c rstart = .false. orth2 = .false. c call second (t5) titref = titref + (t5 - t4) c c %----------------------------------------------------------% c | Make sure the last off-diagonal element is non negative | c | If not perform a similarity transformation on H(1:j,1:j) | c | and scale v(:,j) by -1. | c %----------------------------------------------------------% c if (h(j,1) .lt. zero) then h(j,1) = -h(j,1) if ( j .lt. k+np) then call sscal(n, -one, v(1,j+1), 1) else call sscal(n, -one, resid, 1) end if end if c c %------------------------------------% c | STEP 6: Update j = j+1; Continue | c %------------------------------------% c j = j + 1 if (j .gt. k+np) then call second (t1) tsaitr = tsaitr + (t1 - t0) ido = 99 c if (msglvl .gt. 1) then call svout (logfil, k+np, h(1,2), ndigit, & '_saitr: main diagonal of matrix H of step K+NP.') if (k+np .gt. 1) then call svout (logfil, k+np-1, h(2,1), ndigit, & '_saitr: sub diagonal of matrix H of step K+NP.') end if end if c go to 9000 end if c c %--------------------------------------------------------% c | Loop back to extend the factorization by another step. | c %--------------------------------------------------------% c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 9000 continue return c c %---------------% c | End of ssaitr | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dsortc.f000644 001750 001750 00000022046 11266605602 022116 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dsortc c c\Description: c Sorts the complex array in XREAL and XIMAG into the order c specified by WHICH and optionally applies the permutation to the c real array Y. It is assumed that if an element of XIMAG is c nonzero, then its negative is also an element. In other words, c both members of a complex conjugate pair are to be sorted and the c pairs are kept adjacent to each other. c c\Usage: c call dsortc c ( WHICH, APPLY, N, XREAL, XIMAG, Y ) c c\Arguments c WHICH Character*2. (Input) c 'LM' -> sort XREAL,XIMAG into increasing order of magnitude. c 'SM' -> sort XREAL,XIMAG into decreasing order of magnitude. c 'LR' -> sort XREAL into increasing order of algebraic. c 'SR' -> sort XREAL into decreasing order of algebraic. c 'LI' -> sort XIMAG into increasing order of magnitude. c 'SI' -> sort XIMAG into decreasing order of magnitude. c NOTE: If an element of XIMAG is non-zero, then its negative c is also an element. c c APPLY Logical. (Input) c APPLY = .TRUE. -> apply the sorted order to array Y. c APPLY = .FALSE. -> do not apply the sorted order to array Y. c c N Integer. (INPUT) c Size of the arrays. c c XREAL, Double precision array of length N. (INPUT/OUTPUT) c XIMAG Real and imaginary part of the array to be sorted. c c Y Double precision array of length N. (INPUT/OUTPUT) c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.1' c Adapted from the sort routine in LANSO. c c\SCCS Information: @(#) c FILE: sortc.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine dsortc (which, apply, n, xreal, ximag, y) c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which logical apply integer n c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & xreal(0:n-1), ximag(0:n-1), y(0:n-1) c c %---------------% c | Local Scalars | c %---------------% c integer i, igap, j Double precision & temp, temp1, temp2 c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlapy2 external dlapy2 c c %-----------------------% c | Executable Statements | c %-----------------------% c igap = n / 2 c if (which .eq. 'LM') then c c %------------------------------------------------------% c | Sort XREAL,XIMAG into increasing order of magnitude. | c %------------------------------------------------------% c 10 continue if (igap .eq. 0) go to 9000 c do 30 i = igap, n-1 j = i-igap 20 continue c if (j.lt.0) go to 30 c temp1 = dlapy2(xreal(j),ximag(j)) temp2 = dlapy2(xreal(j+igap),ximag(j+igap)) c if (temp1.gt.temp2) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 30 end if j = j-igap go to 20 30 continue igap = igap / 2 go to 10 c else if (which .eq. 'SM') then c c %------------------------------------------------------% c | Sort XREAL,XIMAG into decreasing order of magnitude. | c %------------------------------------------------------% c 40 continue if (igap .eq. 0) go to 9000 c do 60 i = igap, n-1 j = i-igap 50 continue c if (j .lt. 0) go to 60 c temp1 = dlapy2(xreal(j),ximag(j)) temp2 = dlapy2(xreal(j+igap),ximag(j+igap)) c if (temp1.lt.temp2) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 60 endif j = j-igap go to 50 60 continue igap = igap / 2 go to 40 c else if (which .eq. 'LR') then c c %------------------------------------------------% c | Sort XREAL into increasing order of algebraic. | c %------------------------------------------------% c 70 continue if (igap .eq. 0) go to 9000 c do 90 i = igap, n-1 j = i-igap 80 continue c if (j.lt.0) go to 90 c if (xreal(j).gt.xreal(j+igap)) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 90 endif j = j-igap go to 80 90 continue igap = igap / 2 go to 70 c else if (which .eq. 'SR') then c c %------------------------------------------------% c | Sort XREAL into decreasing order of algebraic. | c %------------------------------------------------% c 100 continue if (igap .eq. 0) go to 9000 do 120 i = igap, n-1 j = i-igap 110 continue c if (j.lt.0) go to 120 c if (xreal(j).lt.xreal(j+igap)) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 120 endif j = j-igap go to 110 120 continue igap = igap / 2 go to 100 c else if (which .eq. 'LI') then c c %------------------------------------------------% c | Sort XIMAG into increasing order of magnitude. | c %------------------------------------------------% c 130 continue if (igap .eq. 0) go to 9000 do 150 i = igap, n-1 j = i-igap 140 continue c if (j.lt.0) go to 150 c if (abs(ximag(j)).gt.abs(ximag(j+igap))) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 150 endif j = j-igap go to 140 150 continue igap = igap / 2 go to 130 c else if (which .eq. 'SI') then c c %------------------------------------------------% c | Sort XIMAG into decreasing order of magnitude. | c %------------------------------------------------% c 160 continue if (igap .eq. 0) go to 9000 do 180 i = igap, n-1 j = i-igap 170 continue c if (j.lt.0) go to 180 c if (abs(ximag(j)).lt.abs(ximag(j+igap))) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 180 endif j = j-igap go to 170 180 continue igap = igap / 2 go to 160 end if c 9000 continue return c c %---------------% c | End of dsortc | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dsaupd.f000644 001750 001750 00000070607 11266605602 022106 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dsaupd c c\Description: c c Reverse communication interface for the Implicitly Restarted Arnoldi c Iteration. For symmetric problems this reduces to a variant of the Lanczos c method. This method has been designed to compute approximations to a c few eigenpairs of a linear operator OP that is real and symmetric c with respect to a real positive semi-definite symmetric matrix B, c i.e. c c B*OP = (OP`)*B. c c Another way to express this condition is c c < x,OPy > = < OPx,y > where < z,w > = z`Bw . c c In the standard eigenproblem B is the identity matrix. c ( A` denotes transpose of A) c c The computed approximate eigenvalues are called Ritz values and c the corresponding approximate eigenvectors are called Ritz vectors. c c dsaupd is usually called iteratively to solve one of the c following problems: c c Mode 1: A*x = lambda*x, A symmetric c ===> OP = A and B = I. c c Mode 2: A*x = lambda*M*x, A symmetric, M symmetric positive definite c ===> OP = inv[M]*A and B = M. c ===> (If M can be factored see remark 3 below) c c Mode 3: K*x = lambda*M*x, K symmetric, M symmetric positive semi-definite c ===> OP = (inv[K - sigma*M])*M and B = M. c ===> Shift-and-Invert mode c c Mode 4: K*x = lambda*KG*x, K symmetric positive semi-definite, c KG symmetric indefinite c ===> OP = (inv[K - sigma*KG])*K and B = K. c ===> Buckling mode c c Mode 5: A*x = lambda*M*x, A symmetric, M symmetric positive semi-definite c ===> OP = inv[A - sigma*M]*[A + sigma*M] and B = M. c ===> Cayley transformed mode c c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v c should be accomplished either by a direct method c using a sparse matrix factorization and solving c c [A - sigma*M]*w = v or M*w = v, c c or through an iterative method for solving these c systems. If an iterative method is used, the c convergence test must be more stringent than c the accuracy requirements for the eigenvalue c approximations. c c\Usage: c call dsaupd c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, c IPNTR, WORKD, WORKL, LWORKL, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to dsaupd . IDO will be set internally to c indicate the type of operation to be performed. Control is c then given back to the calling routine which has the c responsibility to carry out the requested operation and call c dsaupd with the result. The operand is given in c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). c (If Mode = 2 see remark 5 below) c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c In mode 3,4 and 5, the vector B * X is already c available in WORKD(ipntr(3)). It does not c need to be recomputed in forming OP * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 3: compute the IPARAM(8) shifts where c IPNTR(11) is the pointer into WORKL for c placing the shifts. See remark 6 below. c IDO = 99: done c ------------------------------------------------------------- c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c WHICH Character*2. (INPUT) c Specify which of the Ritz values of OP to compute. c c 'LA' - compute the NEV largest (algebraic) eigenvalues. c 'SA' - compute the NEV smallest (algebraic) eigenvalues. c 'LM' - compute the NEV largest (in magnitude) eigenvalues. c 'SM' - compute the NEV smallest (in magnitude) eigenvalues. c 'BE' - compute NEV eigenvalues, half from each end of the c spectrum. When NEV is odd, compute one more from the c high end than from the low end. c (see remark 1 below) c c NEV Integer. (INPUT) c Number of eigenvalues of OP to be computed. 0 < NEV < N. c c TOL Double precision scalar. (INPUT) c Stopping criterion: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)). c If TOL .LE. 0. is passed a default is set: c DEFAULT = DLAMCH ('EPS') (machine precision as computed c by the LAPACK auxiliary subroutine DLAMCH ). c c RESID Double precision array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V (less than or equal to N). c This will indicate how many Lanczos vectors are generated c at each iteration. After the startup phase in which NEV c Lanczos vectors are generated, the algorithm generates c NCV-NEV Lanczos vectors at each subsequent update iteration. c Most of the cost in generating each Lanczos vector is in the c matrix-vector product OP*x. (See remark 4 below). c c V Double precision N by NCV array. (OUTPUT) c The NCV columns of V contain the Lanczos basis vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. c The shifts selected at each iteration are used to restart c the Arnoldi iteration in an implicit fashion. c ------------------------------------------------------------- c ISHIFT = 0: the shifts are provided by the user via c reverse communication. The NCV eigenvalues of c the current tridiagonal matrix T are returned in c the part of WORKL array corresponding to RITZ. c See remark 6 below. c ISHIFT = 1: exact shifts with respect to the reduced c tridiagonal matrix T. This is equivalent to c restarting the iteration with a starting vector c that is a linear combination of Ritz vectors c associated with the "wanted" Ritz values. c ------------------------------------------------------------- c c IPARAM(2) = LEVEC c No longer referenced. See remark 2 below. c c IPARAM(3) = MXITER c On INPUT: maximum number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" Ritz values. c This represents the number of Ritz values that satisfy c the convergence criterion. c c IPARAM(6) = IUPD c No longer referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = MODE c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2,3,4,5; See under \Description of dsaupd for the c five modes available. c c IPARAM(8) = NP c When ido = 3 and the user provides shifts through reverse c communication (IPARAM(1)=0), dsaupd returns NP, the number c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark c 6 below. c c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, c OUTPUT: NUMOP = total number of OP*x operations, c NUMOPB = total number of B*x operations if BMAT='G', c NUMREO = total number of steps of re-orthogonalization. c c IPNTR Integer array of length 11. (OUTPUT) c Pointer to mark the starting locations in the WORKD and WORKL c arrays for matrices/vectors used by the Lanczos iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X in WORKD. c IPNTR(2): pointer to the current result vector Y in WORKD. c IPNTR(3): pointer to the vector B * X in WORKD when used in c the shift-and-invert mode. c IPNTR(4): pointer to the next available location in WORKL c that is untouched by the program. c IPNTR(5): pointer to the NCV by 2 tridiagonal matrix T in WORKL. c IPNTR(6): pointer to the NCV RITZ values array in WORKL. c IPNTR(7): pointer to the Ritz estimates in array WORKL associated c with the Ritz values located in RITZ in WORKL. c IPNTR(11): pointer to the NP shifts in WORKL. See Remark 6 below. c c Note: IPNTR(8:10) is only referenced by dseupd . See Remark 2. c IPNTR(8): pointer to the NCV RITZ values of the original system. c IPNTR(9): pointer to the NCV corresponding error bounds. c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors c of the tridiagonal matrix T. Only referenced by c dseupd if RVEC = .TRUE. See Remarks. c ------------------------------------------------------------- c c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration. Upon termination c WORKD(1:N) contains B*RESID(1:N). If the Ritz vectors are desired c subroutine dseupd uses this output. c See Data Distribution Note below. c c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. See Data Distribution Note below. c c LWORKL Integer. (INPUT) c LWORKL must be at least NCV**2 + 8*NCV . c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal exit. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. IPARAM(5) c returns the number of wanted converged Ritz values. c = 2: No longer an informational error. Deprecated starting c with release 2 of ARPACK. c = 3: No shifts could be applied during a cycle of the c Implicitly restarted Arnoldi iteration. One possibility c is to increase the size of NCV relative to NEV. c See remark 4 below. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV must be greater than NEV and less than or equal to N. c = -4: The maximum number of Arnoldi update iterations allowed c must be greater than zero. c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work array WORKL is not sufficient. c = -8: Error return from trid. eigenvalue calculation; c Informatinal error from LAPACK routine dsteqr . c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3,4,5. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable. c = -12: IPARAM(1) must be equal to 0 or 1. c = -13: NEV and WHICH = 'BE' are incompatable. c = -9999: Could not build an Arnoldi factorization. c IPARAM(5) returns the size of the current Arnoldi c factorization. The user is advised to check that c enough workspace and array storage has been allocated. c c c\Remarks c 1. The converged Ritz values are always returned in ascending c algebraic order. The computed Ritz values are approximate c eigenvalues of OP. The selection of WHICH should be made c with this in mind when Mode = 3,4,5. After convergence, c approximate eigenvalues of the original problem may be obtained c with the ARPACK subroutine dseupd . c c 2. If the Ritz vectors corresponding to the converged Ritz values c are needed, the user must call dseupd immediately following completion c of dsaupd . This is new starting with version 2.1 of ARPACK. c c 3. If M can be factored into a Cholesky factorization M = LL` c then Mode = 2 should not be selected. Instead one should use c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular c linear systems should be solved with L and L` rather c than computing inverses. After convergence, an approximate c eigenvector z of the original problem is recovered by solving c L`z = x where x is a Ritz vector of OP. c c 4. At present there is no a-priori analysis to guide the selection c of NCV relative to NEV. The only formal requrement is that NCV > NEV. c However, it is recommended that NCV .ge. 2*NEV. If many problems of c the same type are to be solved, one should experiment with increasing c NCV while keeping NEV fixed for a given test problem. This will c usually decrease the required number of OP*x operations but it c also increases the work and storage required to maintain the orthogonal c basis vectors. The optimal "cross-over" with respect to CPU time c is problem dependent and must be determined empirically. c c 5. If IPARAM(7) = 2 then in the Reverse commuication interface the user c must do the following. When IDO = 1, Y = OP * X is to be computed. c When IPARAM(7) = 2 OP = inv(B)*A. After computing A*X the user c must overwrite X with A*X. Y is then the solution to the linear set c of equations B*Y = A*X. c c 6. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the c NP = IPARAM(8) shifts in locations: c 1 WORKL(IPNTR(11)) c 2 WORKL(IPNTR(11)+1) c . c . c . c NP WORKL(IPNTR(11)+NP-1). c c The eigenvalues of the current tridiagonal matrix are located in c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are in the c order defined by WHICH. The associated Ritz estimates are located in c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). c c----------------------------------------------------------------------- c c\Data Distribution Note: c c Fortran-D syntax: c ================ c REAL RESID(N), V(LDV,NCV), WORKD(3*N), WORKL(LWORKL) c DECOMPOSE D1(N), D2(N,NCV) c ALIGN RESID(I) with D1(I) c ALIGN V(I,J) with D2(I,J) c ALIGN WORKD(I) with D1(I) range (1:N) c ALIGN WORKD(I) with D1(I-N) range (N+1:2*N) c ALIGN WORKD(I) with D1(I-2*N) range (2*N+1:3*N) c DISTRIBUTE D1(BLOCK), D2(BLOCK,:) c REPLICATED WORKL(LWORKL) c c Cray MPP syntax: c =============== c REAL RESID(N), V(LDV,NCV), WORKD(N,3), WORKL(LWORKL) c SHARED RESID(BLOCK), V(BLOCK,:), WORKD(BLOCK,:) c REPLICATED WORKL(LWORKL) c c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, c 1980. c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", c Computer Physics Communications, 53 (1989), pp 169-179. c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to c Implement the Spectral Transformation", Math. Comp., 48 (1987), c pp 663-673. c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", c SIAM J. Matr. Anal. Apps., January (1993). c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines c for Updating the QR decomposition", ACM TOMS, December 1990, c Volume 16 Number 4, pp 369-377. c 8. R.B. Lehoucq, D.C. Sorensen, "Implementation of Some Spectral c Transformations in a k-Step Arnoldi Method". In Preparation. c c\Routines called: c dsaup2 ARPACK routine that implements the Implicitly Restarted c Arnoldi Iteration. c dstats ARPACK routine that initialize timing and other statistics c variables. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c dvout ARPACK utility routine that prints vectors. c dlamch LAPACK routine that determines machine constants. c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/15/93: Version ' 2.4' c c\SCCS Information: @(#) c FILE: saupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c subroutine dsaupd & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, & ipntr, workd, workl, lworkl, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ldv, lworkl, n, ncv, nev Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(11) Double precision & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0 , zero = 0.0D+0 ) c c %---------------% c | Local Scalars | c %---------------% c integer bounds, ierr, ih, iq, ishift, iupd, iw, & ldh, ldq, msglvl, mxiter, mode, nb, & nev0, next, np, ritz, j save bounds, ierr, ih, iq, ishift, iupd, iw, & ldh, ldq, msglvl, mxiter, mode, nb, & nev0, next, np, ritz c c %----------------------% c | External Subroutines | c %----------------------% c external dsaup2 , dvout , ivout, second, dstats c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlamch external dlamch c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call dstats call second (t0) msglvl = msaupd c ierr = 0 ishift = iparam(1) mxiter = iparam(3) c nb = iparam(4) nb = 1 c c %--------------------------------------------% c | Revision 2 performs only implicit restart. | c %--------------------------------------------% c iupd = 1 mode = iparam(7) c c %----------------% c | Error checking | c %----------------% c if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev .or. ncv .gt. n) then ierr = -3 end if c c %----------------------------------------------% c | NP is the number of additional steps to | c | extend the length NEV Lanczos factorization. | c %----------------------------------------------% c np = ncv - nev c if (mxiter .le. 0) ierr = -4 if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LA' .and. & which .ne. 'SA' .and. & which .ne. 'BE') ierr = -5 if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 c if (lworkl .lt. ncv**2 + 8*ncv) ierr = -7 if (mode .lt. 1 .or. mode .gt. 5) then ierr = -10 else if (mode .eq. 1 .and. bmat .eq. 'G') then ierr = -11 else if (ishift .lt. 0 .or. ishift .gt. 1) then ierr = -12 else if (nev .eq. 1 .and. which .eq. 'BE') then ierr = -13 end if c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr ido = 99 go to 9000 end if c c %------------------------% c | Set default parameters | c %------------------------% c if (nb .le. 0) nb = 1 if (tol .le. zero) tol = dlamch ('EpsMach') c c %----------------------------------------------% c | NP is the number of additional steps to | c | extend the length NEV Lanczos factorization. | c | NEV0 is the local variable designating the | c | size of the invariant subspace desired. | c %----------------------------------------------% c np = ncv - nev nev0 = nev c c %-----------------------------% c | Zero out internal workspace | c %-----------------------------% c do 10 j = 1, ncv**2 + 8*ncv workl(j) = zero 10 continue c c %-------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:2*ncv) := generated tridiagonal matrix | c | workl(2*ncv+1:2*ncv+ncv) := ritz values | c | workl(3*ncv+1:3*ncv+ncv) := computed error bounds | c | workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q | c | workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace | c %-------------------------------------------------------% c ldh = ncv ldq = ncv ih = 1 ritz = ih + 2*ldh bounds = ritz + ncv iq = bounds + ncv iw = iq + ncv**2 next = iw + 3*ncv c ipntr(4) = next ipntr(5) = ih ipntr(6) = ritz ipntr(7) = bounds ipntr(11) = iw end if c c %-------------------------------------------------------% c | Carry out the Implicitly restarted Lanczos Iteration. | c %-------------------------------------------------------% c call dsaup2 & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), & workl(bounds), workl(iq), ldq, workl(iw), ipntr, workd, & info ) c c %--------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP or shifts. | c %--------------------------------------------------% c if (ido .eq. 3) iparam(8) = np if (ido .ne. 99) go to 9000 c iparam(3) = mxiter iparam(5) = np iparam(9) = nopx iparam(10) = nbx iparam(11) = nrorth c c %------------------------------------% c | Exit if there was an informational | c | error within dsaup2 . | c %------------------------------------% c if (info .lt. 0) go to 9000 if (info .eq. 2) info = 3 c if (msglvl .gt. 0) then call ivout (logfil, 1, mxiter, ndigit, & '_saupd: number of update iterations taken') call ivout (logfil, 1, np, ndigit, & '_saupd: number of "converged" Ritz values') call dvout (logfil, np, workl(Ritz), ndigit, & '_saupd: final Ritz values') call dvout (logfil, np, workl(Bounds), ndigit, & '_saupd: corresponding error bounds') end if c call second (t1) tsaupd = t1 - t0 c if (msglvl .gt. 0) then c c %--------------------------------------------------------% c | Version Number & Version Date are defined in version.h | c %--------------------------------------------------------% c write (6,1000) write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, & tmvopx, tmvbx, tsaupd, tsaup2, tsaitr, titref, & tgetv0, tseigt, tsgets, tsapps, tsconv 1000 format (//, & 5x, '==========================================',/ & 5x, '= Symmetric implicit Arnoldi update code =',/ & 5x, '= Version Number:', ' 2.4' , 19x, ' =',/ & 5x, '= Version Date: ', ' 07/31/96' , 14x, ' =',/ & 5x, '==========================================',/ & 5x, '= Summary of timing statistics =',/ & 5x, '==========================================',//) 1100 format ( & 5x, 'Total number update iterations = ', i5,/ & 5x, 'Total number of OP*x operations = ', i5,/ & 5x, 'Total number of B*x operations = ', i5,/ & 5x, 'Total number of reorthogonalization steps = ', i5,/ & 5x, 'Total number of iterative refinement steps = ', i5,/ & 5x, 'Total number of restart steps = ', i5,/ & 5x, 'Total time in user OP*x operation = ', f12.6,/ & 5x, 'Total time in user B*x operation = ', f12.6,/ & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ & 5x, 'Total time in saup2 routine = ', f12.6,/ & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ & 5x, 'Total time in (re)start vector generation = ', f12.6,/ & 5x, 'Total time in trid eigenvalue subproblem = ', f12.6,/ & 5x, 'Total time in getting the shifts = ', f12.6,/ & 5x, 'Total time in applying the shifts = ', f12.6,/ & 5x, 'Total time in convergence testing = ', f12.6) end if c 9000 continue c return c c %---------------% c | End of dsaupd | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/csortc.f000644 001750 001750 00000017575 11266605602 022130 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: csortc c c\Description: c Sorts the Complex array in X into the order c specified by WHICH and optionally applies the permutation to the c Real array Y. c c\Usage: c call csortc c ( WHICH, APPLY, N, X, Y ) c c\Arguments c WHICH Character*2. (Input) c 'LM' -> sort X into increasing order of magnitude. c 'SM' -> sort X into decreasing order of magnitude. c 'LR' -> sort X with real(X) in increasing algebraic order c 'SR' -> sort X with real(X) in decreasing algebraic order c 'LI' -> sort X with imag(X) in increasing algebraic order c 'SI' -> sort X with imag(X) in decreasing algebraic order c c APPLY Logical. (Input) c APPLY = .TRUE. -> apply the sorted order to array Y. c APPLY = .FALSE. -> do not apply the sorted order to array Y. c c N Integer. (INPUT) c Size of the arrays. c c X Complex array of length N. (INPUT/OUTPUT) c This is the array to be sorted. c c Y Complex array of length N. (INPUT/OUTPUT) c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Routines called: c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c Adapted from the sort routine in LANSO. c c\SCCS Information: @(#) c FILE: sortc.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine csortc (which, apply, n, x, y) c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which logical apply integer n c c %-----------------% c | Array Arguments | c %-----------------% c Complex & x(0:n-1), y(0:n-1) c c %---------------% c | Local Scalars | c %---------------% c integer i, igap, j Complex & temp Real & temp1, temp2 c c %--------------------% c | External functions | c %--------------------% c Real & slapy2 c c %--------------------% c | Intrinsic Functions | c %--------------------% Intrinsic & real, aimag c c %-----------------------% c | Executable Statements | c %-----------------------% c igap = n / 2 c if (which .eq. 'LM') then c c %--------------------------------------------% c | Sort X into increasing order of magnitude. | c %--------------------------------------------% c 10 continue if (igap .eq. 0) go to 9000 c do 30 i = igap, n-1 j = i-igap 20 continue c if (j.lt.0) go to 30 c temp1 = slapy2(real(x(j)),aimag(x(j))) temp2 = slapy2(real(x(j+igap)),aimag(x(j+igap))) c if (temp1.gt.temp2) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 30 end if j = j-igap go to 20 30 continue igap = igap / 2 go to 10 c else if (which .eq. 'SM') then c c %--------------------------------------------% c | Sort X into decreasing order of magnitude. | c %--------------------------------------------% c 40 continue if (igap .eq. 0) go to 9000 c do 60 i = igap, n-1 j = i-igap 50 continue c if (j .lt. 0) go to 60 c temp1 = slapy2(real(x(j)),aimag(x(j))) temp2 = slapy2(real(x(j+igap)),aimag(x(j+igap))) c if (temp1.lt.temp2) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 60 endif j = j-igap go to 50 60 continue igap = igap / 2 go to 40 c else if (which .eq. 'LR') then c c %------------------------------------------------% c | Sort XREAL into increasing order of algebraic. | c %------------------------------------------------% c 70 continue if (igap .eq. 0) go to 9000 c do 90 i = igap, n-1 j = i-igap 80 continue c if (j.lt.0) go to 90 c if (real(x(j)).gt.real(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 90 endif j = j-igap go to 80 90 continue igap = igap / 2 go to 70 c else if (which .eq. 'SR') then c c %------------------------------------------------% c | Sort XREAL into decreasing order of algebraic. | c %------------------------------------------------% c 100 continue if (igap .eq. 0) go to 9000 do 120 i = igap, n-1 j = i-igap 110 continue c if (j.lt.0) go to 120 c if (real(x(j)).lt.real(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 120 endif j = j-igap go to 110 120 continue igap = igap / 2 go to 100 c else if (which .eq. 'LI') then c c %--------------------------------------------% c | Sort XIMAG into increasing algebraic order | c %--------------------------------------------% c 130 continue if (igap .eq. 0) go to 9000 do 150 i = igap, n-1 j = i-igap 140 continue c if (j.lt.0) go to 150 c if (aimag(x(j)).gt.aimag(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 150 endif j = j-igap go to 140 150 continue igap = igap / 2 go to 130 c else if (which .eq. 'SI') then c c %---------------------------------------------% c | Sort XIMAG into decreasing algebraic order | c %---------------------------------------------% c 160 continue if (igap .eq. 0) go to 9000 do 180 i = igap, n-1 j = i-igap 170 continue c if (j.lt.0) go to 180 c if (aimag(x(j)).lt.aimag(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 180 endif j = j-igap go to 170 180 continue igap = igap / 2 go to 160 end if c 9000 continue return c c %---------------% c | End of csortc | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/zsortc.f000644 001750 001750 00000017660 11266605602 022152 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: zsortc c c\Description: c Sorts the Complex*16 array in X into the order c specified by WHICH and optionally applies the permutation to the c Double precision array Y. c c\Usage: c call zsortc c ( WHICH, APPLY, N, X, Y ) c c\Arguments c WHICH Character*2. (Input) c 'LM' -> sort X into increasing order of magnitude. c 'SM' -> sort X into decreasing order of magnitude. c 'LR' -> sort X with real(X) in increasing algebraic order c 'SR' -> sort X with real(X) in decreasing algebraic order c 'LI' -> sort X with imag(X) in increasing algebraic order c 'SI' -> sort X with imag(X) in decreasing algebraic order c c APPLY Logical. (Input) c APPLY = .TRUE. -> apply the sorted order to array Y. c APPLY = .FALSE. -> do not apply the sorted order to array Y. c c N Integer. (INPUT) c Size of the arrays. c c X Complex*16 array of length N. (INPUT/OUTPUT) c This is the array to be sorted. c c Y Complex*16 array of length N. (INPUT/OUTPUT) c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Routines called: c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c Adapted from the sort routine in LANSO. c c\SCCS Information: @(#) c FILE: sortc.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine zsortc (which, apply, n, x, y) c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which logical apply integer n c c %-----------------% c | Array Arguments | c %-----------------% c Complex*16 & x(0:n-1), y(0:n-1) c c %---------------% c | Local Scalars | c %---------------% c integer i, igap, j Complex*16 & temp Double precision & temp1, temp2 c c %--------------------% c | External functions | c %--------------------% c Double precision & dlapy2 c c %--------------------% c | Intrinsic Functions | c %--------------------% Intrinsic & dble, dimag c c %-----------------------% c | Executable Statements | c %-----------------------% c igap = n / 2 c if (which .eq. 'LM') then c c %--------------------------------------------% c | Sort X into increasing order of magnitude. | c %--------------------------------------------% c 10 continue if (igap .eq. 0) go to 9000 c do 30 i = igap, n-1 j = i-igap 20 continue c if (j.lt.0) go to 30 c temp1 = dlapy2(dble(x(j)),dimag(x(j))) temp2 = dlapy2(dble(x(j+igap)),dimag(x(j+igap))) c if (temp1.gt.temp2) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 30 end if j = j-igap go to 20 30 continue igap = igap / 2 go to 10 c else if (which .eq. 'SM') then c c %--------------------------------------------% c | Sort X into decreasing order of magnitude. | c %--------------------------------------------% c 40 continue if (igap .eq. 0) go to 9000 c do 60 i = igap, n-1 j = i-igap 50 continue c if (j .lt. 0) go to 60 c temp1 = dlapy2(dble(x(j)),dimag(x(j))) temp2 = dlapy2(dble(x(j+igap)),dimag(x(j+igap))) c if (temp1.lt.temp2) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 60 endif j = j-igap go to 50 60 continue igap = igap / 2 go to 40 c else if (which .eq. 'LR') then c c %------------------------------------------------% c | Sort XREAL into increasing order of algebraic. | c %------------------------------------------------% c 70 continue if (igap .eq. 0) go to 9000 c do 90 i = igap, n-1 j = i-igap 80 continue c if (j.lt.0) go to 90 c if (dble(x(j)).gt.dble(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 90 endif j = j-igap go to 80 90 continue igap = igap / 2 go to 70 c else if (which .eq. 'SR') then c c %------------------------------------------------% c | Sort XREAL into decreasing order of algebraic. | c %------------------------------------------------% c 100 continue if (igap .eq. 0) go to 9000 do 120 i = igap, n-1 j = i-igap 110 continue c if (j.lt.0) go to 120 c if (dble(x(j)).lt.dble(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 120 endif j = j-igap go to 110 120 continue igap = igap / 2 go to 100 c else if (which .eq. 'LI') then c c %--------------------------------------------% c | Sort XIMAG into increasing algebraic order | c %--------------------------------------------% c 130 continue if (igap .eq. 0) go to 9000 do 150 i = igap, n-1 j = i-igap 140 continue c if (j.lt.0) go to 150 c if (dimag(x(j)).gt.dimag(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 150 endif j = j-igap go to 140 150 continue igap = igap / 2 go to 130 c else if (which .eq. 'SI') then c c %---------------------------------------------% c | Sort XIMAG into decreasing algebraic order | c %---------------------------------------------% c 160 continue if (igap .eq. 0) go to 9000 do 180 i = igap, n-1 j = i-igap 170 continue c if (j.lt.0) go to 180 c if (dimag(x(j)).lt.dimag(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 180 endif j = j-igap go to 170 180 continue igap = igap / 2 go to 160 end if c 9000 continue return c c %---------------% c | End of zsortc | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/ssortr.f000644 001750 001750 00000012274 11266605602 022156 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: ssortr c c\Description: c Sort the array X1 in the order specified by WHICH and optionally c applies the permutation to the array X2. c c\Usage: c call ssortr c ( WHICH, APPLY, N, X1, X2 ) c c\Arguments c WHICH Character*2. (Input) c 'LM' -> X1 is sorted into increasing order of magnitude. c 'SM' -> X1 is sorted into decreasing order of magnitude. c 'LA' -> X1 is sorted into increasing order of algebraic. c 'SA' -> X1 is sorted into decreasing order of algebraic. c c APPLY Logical. (Input) c APPLY = .TRUE. -> apply the sorted order to X2. c APPLY = .FALSE. -> do not apply the sorted order to X2. c c N Integer. (INPUT) c Size of the arrays. c c X1 Real array of length N. (INPUT/OUTPUT) c The array to be sorted. c c X2 Real array of length N. (INPUT/OUTPUT) c Only referenced if APPLY = .TRUE. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/16/93: Version ' 2.1'. c Adapted from the sort routine in LANSO. c c\SCCS Information: @(#) c FILE: sortr.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine ssortr (which, apply, n, x1, x2) c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which logical apply integer n c c %-----------------% c | Array Arguments | c %-----------------% c Real & x1(0:n-1), x2(0:n-1) c c %---------------% c | Local Scalars | c %---------------% c integer i, igap, j Real & temp c c %-----------------------% c | Executable Statements | c %-----------------------% c igap = n / 2 c if (which .eq. 'SA') then c c X1 is sorted into decreasing order of algebraic. c 10 continue if (igap .eq. 0) go to 9000 do 30 i = igap, n-1 j = i-igap 20 continue c if (j.lt.0) go to 30 c if (x1(j).lt.x1(j+igap)) then temp = x1(j) x1(j) = x1(j+igap) x1(j+igap) = temp if (apply) then temp = x2(j) x2(j) = x2(j+igap) x2(j+igap) = temp end if else go to 30 endif j = j-igap go to 20 30 continue igap = igap / 2 go to 10 c else if (which .eq. 'SM') then c c X1 is sorted into decreasing order of magnitude. c 40 continue if (igap .eq. 0) go to 9000 do 60 i = igap, n-1 j = i-igap 50 continue c if (j.lt.0) go to 60 c if (abs(x1(j)).lt.abs(x1(j+igap))) then temp = x1(j) x1(j) = x1(j+igap) x1(j+igap) = temp if (apply) then temp = x2(j) x2(j) = x2(j+igap) x2(j+igap) = temp end if else go to 60 endif j = j-igap go to 50 60 continue igap = igap / 2 go to 40 c else if (which .eq. 'LA') then c c X1 is sorted into increasing order of algebraic. c 70 continue if (igap .eq. 0) go to 9000 do 90 i = igap, n-1 j = i-igap 80 continue c if (j.lt.0) go to 90 c if (x1(j).gt.x1(j+igap)) then temp = x1(j) x1(j) = x1(j+igap) x1(j+igap) = temp if (apply) then temp = x2(j) x2(j) = x2(j+igap) x2(j+igap) = temp end if else go to 90 endif j = j-igap go to 80 90 continue igap = igap / 2 go to 70 c else if (which .eq. 'LM') then c c X1 is sorted into increasing order of magnitude. c 100 continue if (igap .eq. 0) go to 9000 do 120 i = igap, n-1 j = i-igap 110 continue c if (j.lt.0) go to 120 c if (abs(x1(j)).gt.abs(x1(j+igap))) then temp = x1(j) x1(j) = x1(j+igap) x1(j+igap) = temp if (apply) then temp = x2(j) x2(j) = x2(j+igap) x2(j+igap) = temp end if else go to 120 endif j = j-igap go to 110 120 continue igap = igap / 2 go to 100 end if c 9000 continue return c c %---------------% c | End of ssortr | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/version.h000644 001750 001750 00000002346 11266605602 022310 0ustar00geuzainegeuzaine000000 000000 /* In the current version, the parameter KAPPA in the Kahan's test for orthogonality is set to 0.717, the same as used by Gragg & Reichel. However computational experience indicates that this is a little too strict and will frequently force reorthogonalization when it is not necessary to do so. Also the "moving boundary" idea is not currently activated in the nonsymmetric code since it is not conclusive that it's the right thing to do all the time. Requires further investigation. As of 02/01/93 Richard Lehoucq assumes software control of the codes from Phuong Vu. On 03/01/93 all the *.F files were migrated SCCS. The 1.1 version of codes are those received from Phuong Vu. The frozen version of 07/08/92 is now considered version 1.1. Version 2.1 contains two new symmetric routines, sesrt and seupd. Changes as well as bug fixes for version 1.1 codes that were only corrected for programming bugs are version 1.2. These 1.2 versions will also be in version 2.1. Subroutine [d,s]saupd now requires slightly more workspace. See [d,s]saupd for the details. \SCCS Information: @(#) FILE: version.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */ #define VERSION_NUMBER ' 2.1' #define VERSION_DATE ' 11/15/95' getdp-2.4.2-source/contrib/Arpack/dnaup2.f000644 001750 001750 00000075365 11266605602 022025 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: dnaup2 c c\Description: c Intermediate level interface called by dnaupd. c c\Usage: c call dnaup2 c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, c ISHIFT, MXITER, V, LDV, H, LDH, RITZR, RITZI, BOUNDS, c Q, LDQ, WORKL, IPNTR, WORKD, INFO ) c c\Arguments c c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in dnaupd. c MODE, ISHIFT, MXITER: see the definition of IPARAM in dnaupd. c c NP Integer. (INPUT/OUTPUT) c Contains the number of implicit shifts to apply during c each Arnoldi iteration. c If ISHIFT=1, NP is adjusted dynamically at each iteration c to accelerate convergence and prevent stagnation. c This is also roughly equal to the number of matrix-vector c products (involving the operator OP) per Arnoldi iteration. c The logic for adjusting is contained within the current c subroutine. c If ISHIFT=0, NP is the number of shifts the user needs c to provide via reverse comunication. 0 < NP < NCV-NEV. c NP may be less than NCV-NEV for two reasons. The first, is c to keep complex conjugate pairs of "wanted" Ritz values c together. The second, is that a leading block of the current c upper Hessenberg matrix has split off and contains "unwanted" c Ritz values. c Upon termination of the IRA iteration, NP contains the number c of "converged" wanted Ritz values. c c IUPD Integer. (INPUT) c IUPD .EQ. 0: use explicit restart instead implicit update. c IUPD .NE. 0: use implicit update. c c V Double precision N by (NEV+NP) array. (INPUT/OUTPUT) c The Arnoldi basis vectors are returned in the first NEV c columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Double precision (NEV+NP) by (NEV+NP) array. (OUTPUT) c H is used to store the generated upper Hessenberg matrix c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZR, Double precision arrays of length NEV+NP. (OUTPUT) c RITZI RITZR(1:NEV) (resp. RITZI(1:NEV)) contains the real (resp. c imaginary) part of the computed Ritz values of OP. c c BOUNDS Double precision array of length NEV+NP. (OUTPUT) c BOUNDS(1:NEV) contain the error bounds corresponding to c the computed Ritz values. c c Q Double precision (NEV+NP) by (NEV+NP) array. (WORKSPACE) c Private (replicated) work array used to accumulate the c rotation in the shift application step. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Double precision work array of length at least c (NEV+NP)**2 + 3*(NEV+NP). (INPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. It is used in shifts calculation, shifts c application and convergence checking. c c On exit, the last 3*(NEV+NP) locations of WORKL contain c the Ritz values (real,imaginary) and associated Ritz c estimates of the current Hessenberg matrix. They are c listed in the same order as returned from dneigh. c c If ISHIFT .EQ. O and IDO .EQ. 3, the first 2*NP locations c of WORKL are used in reverse communication to hold the user c supplied shifts. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORKD for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Double precision work array of length 3*N. (WORKSPACE) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration !!!!!!!!!! c See Data Distribution Note in DNAUPD. c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal return. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. c NP returns the number of converged Ritz values. c = 2: No shifts could be applied. c = -8: Error return from LAPACK eigenvalue calculation; c This should never happen. c = -9: Starting vector is zero. c = -9999: Could not build an Arnoldi factorization. c Size that was built in returned in NP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c dgetv0 ARPACK initial vector generation routine. c dnaitr ARPACK Arnoldi factorization routine. c dnapps ARPACK application of implicit shifts routine. c dnconv ARPACK convergence of Ritz values routine. c dneigh ARPACK compute Ritz values and error bounds routine. c dngets ARPACK reorder Ritz values and error bounds routine. c dsortc ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c dmout ARPACK utility routine that prints matrices c dvout ARPACK utility routine that prints vectors. c dlamch LAPACK routine that determines machine constants. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dcopy Level 1 BLAS that copies one vector to another . c ddot Level 1 BLAS that computes the scalar product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dswap Level 1 BLAS that swaps two vectors. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: naup2.F SID: 2.8 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c subroutine dnaup2 & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, h, ldh, ritzr, ritzi, bounds, & q, ldq, workl, ipntr, workd, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, & n, nev, np Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(13) Double precision & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), resid(n), & ritzi(nev+np), ritzr(nev+np), v(ldv,nev+np), & workd(3*n), workl( (nev+np)*(nev+np+3) ) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %---------------% c | Local Scalars | c %---------------% c character wprime*2 logical cnorm , getv0, initv, update, ushift integer ierr , iter , j , kplusp, msglvl, nconv, & nevbef, nev0 , np0 , nptemp, numcnv Double precision & rnorm , temp , eps23 save cnorm , getv0, initv, update, ushift, & rnorm , iter , eps23, kplusp, msglvl, nconv , & nevbef, nev0 , np0 , numcnv c c %-----------------------% c | Local array arguments | c %-----------------------% c integer kp(4) c c %----------------------% c | External Subroutines | c %----------------------% c external dcopy , dgetv0, dnaitr, dnconv, dneigh, & dngets, dnapps, dvout , ivout , second c c %--------------------% c | External Functions | c %--------------------% c Double precision & ddot, dnrm2, dlapy2, dlamch external ddot, dnrm2, dlapy2, dlamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic min, max, abs, sqrt c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c call second (t0) c msglvl = mnaup2 c c %-------------------------------------% c | Get the machine dependent constant. | c %-------------------------------------% c eps23 = dlamch('Epsilon-Machine') eps23 = eps23**(2.0D+0 / 3.0D+0) c nev0 = nev np0 = np c c %-------------------------------------% c | kplusp is the bound on the largest | c | Lanczos factorization built. | c | nconv is the current number of | c | "converged" eigenvlues. | c | iter is the counter on the current | c | iteration step. | c %-------------------------------------% c kplusp = nev + np nconv = 0 iter = 0 c c %---------------------------------------% c | Set flags for computing the first NEV | c | steps of the Arnoldi factorization. | c %---------------------------------------% c getv0 = .true. update = .false. ushift = .false. cnorm = .false. c if (info .ne. 0) then c c %--------------------------------------------% c | User provides the initial residual vector. | c %--------------------------------------------% c initv = .true. info = 0 else initv = .false. end if end if c c %---------------------------------------------% c | Get a possibly random starting vector and | c | force it into the range of the operator OP. | c %---------------------------------------------% c 10 continue c if (getv0) then call dgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, & ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (rnorm .eq. zero) then c c %-----------------------------------------% c | The initial vector is zero. Error exit. | c %-----------------------------------------% c info = -9 go to 1100 end if getv0 = .false. ido = 0 end if c c %-----------------------------------% c | Back from reverse communication : | c | continue with update step | c %-----------------------------------% c if (update) go to 20 c c %-------------------------------------------% c | Back from computing user specified shifts | c %-------------------------------------------% c if (ushift) go to 50 c c %-------------------------------------% c | Back from computing residual norm | c | at the end of the current iteration | c %-------------------------------------% c if (cnorm) go to 100 c c %----------------------------------------------------------% c | Compute the first NEV steps of the Arnoldi factorization | c %----------------------------------------------------------% c call dnaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, & h, ldh, ipntr, workd, info) c c %---------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP and possibly B | c %---------------------------------------------------% c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then np = info mxiter = iter info = -9999 go to 1200 end if c c %--------------------------------------------------------------% c | | c | M A I N ARNOLDI I T E R A T I O N L O O P | c | Each iteration implicitly restarts the Arnoldi | c | factorization in place. | c | | c %--------------------------------------------------------------% c 1000 continue c iter = iter + 1 c if (msglvl .gt. 0) then call ivout (logfil, 1, iter, ndigit, & '_naup2: **** Start of major iteration number ****') end if c c %-----------------------------------------------------------% c | Compute NP additional steps of the Arnoldi factorization. | c | Adjust NP since NEV might have been updated by last call | c | to the shift application routine dnapps. | c %-----------------------------------------------------------% c np = kplusp - nev c if (msglvl .gt. 1) then call ivout (logfil, 1, nev, ndigit, & '_naup2: The length of the current Arnoldi factorization') call ivout (logfil, 1, np, ndigit, & '_naup2: Extend the Arnoldi factorization by') end if c c %-----------------------------------------------------------% c | Compute NP additional steps of the Arnoldi factorization. | c %-----------------------------------------------------------% c ido = 0 20 continue update = .true. c call dnaitr (ido , bmat, n , nev, np , mode , resid, & rnorm, v , ldv, h , ldh, ipntr, workd, & info) c c %---------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP and possibly B | c %---------------------------------------------------% c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then np = info mxiter = iter info = -9999 go to 1200 end if update = .false. c if (msglvl .gt. 1) then call dvout (logfil, 1, rnorm, ndigit, & '_naup2: Corresponding B-norm of the residual') end if c c %--------------------------------------------------------% c | Compute the eigenvalues and corresponding error bounds | c | of the current upper Hessenberg matrix. | c %--------------------------------------------------------% c call dneigh (rnorm, kplusp, h, ldh, ritzr, ritzi, bounds, & q, ldq, workl, ierr) c if (ierr .ne. 0) then info = -8 go to 1200 end if c c %----------------------------------------------------% c | Make a copy of eigenvalues and corresponding error | c | bounds obtained from dneigh. | c %----------------------------------------------------% c call dcopy(kplusp, ritzr, 1, workl(kplusp**2+1), 1) call dcopy(kplusp, ritzi, 1, workl(kplusp**2+kplusp+1), 1) call dcopy(kplusp, bounds, 1, workl(kplusp**2+2*kplusp+1), 1) c c %---------------------------------------------------% c | Select the wanted Ritz values and their bounds | c | to be used in the convergence test. | c | The wanted part of the spectrum and corresponding | c | error bounds are in the last NEV loc. of RITZR, | c | RITZI and BOUNDS respectively. The variables NEV | c | and NP may be updated if the NEV-th wanted Ritz | c | value has a non zero imaginary part. In this case | c | NEV is increased by one and NP decreased by one. | c | NOTE: The last two arguments of dngets are no | c | longer used as of version 2.1. | c %---------------------------------------------------% c nev = nev0 np = np0 numcnv = nev call dngets (ishift, which, nev, np, ritzr, ritzi, & bounds, workl, workl(np+1)) if (nev .eq. nev0+1) numcnv = nev0+1 c c %-------------------% c | Convergence test. | c %-------------------% c call dcopy (nev, bounds(np+1), 1, workl(2*np+1), 1) call dnconv (nev, ritzr(np+1), ritzi(np+1), workl(2*np+1), & tol, nconv) c if (msglvl .gt. 2) then kp(1) = nev kp(2) = np kp(3) = numcnv kp(4) = nconv call ivout (logfil, 4, kp, ndigit, & '_naup2: NEV, NP, NUMCNV, NCONV are') call dvout (logfil, kplusp, ritzr, ndigit, & '_naup2: Real part of the eigenvalues of H') call dvout (logfil, kplusp, ritzi, ndigit, & '_naup2: Imaginary part of the eigenvalues of H') call dvout (logfil, kplusp, bounds, ndigit, & '_naup2: Ritz estimates of the current NCV Ritz values') end if c c %---------------------------------------------------------% c | Count the number of unwanted Ritz values that have zero | c | Ritz estimates. If any Ritz estimates are equal to zero | c | then a leading block of H of order equal to at least | c | the number of Ritz values with zero Ritz estimates has | c | split off. None of these Ritz values may be removed by | c | shifting. Decrease NP the number of shifts to apply. If | c | no shifts may be applied, then prepare to exit | c %---------------------------------------------------------% c nptemp = np do 30 j=1, nptemp if (bounds(j) .eq. zero) then np = np - 1 nev = nev + 1 end if 30 continue c if ( (nconv .ge. numcnv) .or. & (iter .gt. mxiter) .or. & (np .eq. 0) ) then c if (msglvl .gt. 4) then call dvout(logfil, kplusp, workl(kplusp**2+1), ndigit, & '_naup2: Real part of the eig computed by _neigh:') call dvout(logfil, kplusp, workl(kplusp**2+kplusp+1), & ndigit, & '_naup2: Imag part of the eig computed by _neigh:') call dvout(logfil, kplusp, workl(kplusp**2+kplusp*2+1), & ndigit, & '_naup2: Ritz eistmates computed by _neigh:') end if c c %------------------------------------------------% c | Prepare to exit. Put the converged Ritz values | c | and corresponding bounds in RITZ(1:NCONV) and | c | BOUNDS(1:NCONV) respectively. Then sort. Be | c | careful when NCONV > NP | c %------------------------------------------------% c c %------------------------------------------% c | Use h( 3,1 ) as storage to communicate | c | rnorm to _neupd if needed | c %------------------------------------------% h(3,1) = rnorm c c %----------------------------------------------% c | To be consistent with dngets, we first do a | c | pre-processing sort in order to keep complex | c | conjugate pairs together. This is similar | c | to the pre-processing sort used in dngets | c | except that the sort is done in the opposite | c | order. | c %----------------------------------------------% c if (which .eq. 'LM') wprime = 'SR' if (which .eq. 'SM') wprime = 'LR' if (which .eq. 'LR') wprime = 'SM' if (which .eq. 'SR') wprime = 'LM' if (which .eq. 'LI') wprime = 'SM' if (which .eq. 'SI') wprime = 'LM' c call dsortc (wprime, .true., kplusp, ritzr, ritzi, bounds) c c %----------------------------------------------% c | Now sort Ritz values so that converged Ritz | c | values appear within the first NEV locations | c | of ritzr, ritzi and bounds, and the most | c | desired one appears at the front. | c %----------------------------------------------% c if (which .eq. 'LM') wprime = 'SM' if (which .eq. 'SM') wprime = 'LM' if (which .eq. 'LR') wprime = 'SR' if (which .eq. 'SR') wprime = 'LR' if (which .eq. 'LI') wprime = 'SI' if (which .eq. 'SI') wprime = 'LI' c call dsortc(wprime, .true., kplusp, ritzr, ritzi, bounds) c c %--------------------------------------------------% c | Scale the Ritz estimate of each Ritz value | c | by 1 / max(eps23,magnitude of the Ritz value). | c %--------------------------------------------------% c do 35 j = 1, numcnv temp = max(eps23,dlapy2(ritzr(j), & ritzi(j))) bounds(j) = bounds(j)/temp 35 continue c c %----------------------------------------------------% c | Sort the Ritz values according to the scaled Ritz | c | esitmates. This will push all the converged ones | c | towards the front of ritzr, ritzi, bounds | c | (in the case when NCONV < NEV.) | c %----------------------------------------------------% c wprime = 'LR' call dsortc(wprime, .true., numcnv, bounds, ritzr, ritzi) c c %----------------------------------------------% c | Scale the Ritz estimate back to its original | c | value. | c %----------------------------------------------% c do 40 j = 1, numcnv temp = max(eps23, dlapy2(ritzr(j), & ritzi(j))) bounds(j) = bounds(j)*temp 40 continue c c %------------------------------------------------% c | Sort the converged Ritz values again so that | c | the "threshold" value appears at the front of | c | ritzr, ritzi and bound. | c %------------------------------------------------% c call dsortc(which, .true., nconv, ritzr, ritzi, bounds) c if (msglvl .gt. 1) then call dvout (logfil, kplusp, ritzr, ndigit, & '_naup2: Sorted real part of the eigenvalues') call dvout (logfil, kplusp, ritzi, ndigit, & '_naup2: Sorted imaginary part of the eigenvalues') call dvout (logfil, kplusp, bounds, ndigit, & '_naup2: Sorted ritz estimates.') end if c c %------------------------------------% c | Max iterations have been exceeded. | c %------------------------------------% c if (iter .gt. mxiter .and. nconv .lt. numcnv) info = 1 c c %---------------------% c | No shifts to apply. | c %---------------------% c if (np .eq. 0 .and. nconv .lt. numcnv) info = 2 c np = nconv go to 1100 c else if ( (nconv .lt. numcnv) .and. (ishift .eq. 1) ) then c c %-------------------------------------------------% c | Do not have all the requested eigenvalues yet. | c | To prevent possible stagnation, adjust the size | c | of NEV. | c %-------------------------------------------------% c nevbef = nev nev = nev + min(nconv, np/2) if (nev .eq. 1 .and. kplusp .ge. 6) then nev = kplusp / 2 else if (nev .eq. 1 .and. kplusp .gt. 3) then nev = 2 end if np = kplusp - nev c c %---------------------------------------% c | If the size of NEV was just increased | c | resort the eigenvalues. | c %---------------------------------------% c if (nevbef .lt. nev) & call dngets (ishift, which, nev, np, ritzr, ritzi, & bounds, workl, workl(np+1)) c end if c if (msglvl .gt. 0) then call ivout (logfil, 1, nconv, ndigit, & '_naup2: no. of "converged" Ritz values at this iter.') if (msglvl .gt. 1) then kp(1) = nev kp(2) = np call ivout (logfil, 2, kp, ndigit, & '_naup2: NEV and NP are') call dvout (logfil, nev, ritzr(np+1), ndigit, & '_naup2: "wanted" Ritz values -- real part') call dvout (logfil, nev, ritzi(np+1), ndigit, & '_naup2: "wanted" Ritz values -- imag part') call dvout (logfil, nev, bounds(np+1), ndigit, & '_naup2: Ritz estimates of the "wanted" values ') end if end if c if (ishift .eq. 0) then c c %-------------------------------------------------------% c | User specified shifts: reverse comminucation to | c | compute the shifts. They are returned in the first | c | 2*NP locations of WORKL. | c %-------------------------------------------------------% c ushift = .true. ido = 3 go to 9000 end if c 50 continue c c %------------------------------------% c | Back from reverse communication; | c | User specified shifts are returned | c | in WORKL(1:2*NP) | c %------------------------------------% c ushift = .false. c if ( ishift .eq. 0 ) then c c %----------------------------------% c | Move the NP shifts from WORKL to | c | RITZR, RITZI to free up WORKL | c | for non-exact shift case. | c %----------------------------------% c call dcopy (np, workl, 1, ritzr, 1) call dcopy (np, workl(np+1), 1, ritzi, 1) end if c if (msglvl .gt. 2) then call ivout (logfil, 1, np, ndigit, & '_naup2: The number of shifts to apply ') call dvout (logfil, np, ritzr, ndigit, & '_naup2: Real part of the shifts') call dvout (logfil, np, ritzi, ndigit, & '_naup2: Imaginary part of the shifts') if ( ishift .eq. 1 ) & call dvout (logfil, np, bounds, ndigit, & '_naup2: Ritz estimates of the shifts') end if c c %---------------------------------------------------------% c | Apply the NP implicit shifts by QR bulge chasing. | c | Each shift is applied to the whole upper Hessenberg | c | matrix H. | c | The first 2*N locations of WORKD are used as workspace. | c %---------------------------------------------------------% c call dnapps (n, nev, np, ritzr, ritzi, v, ldv, & h, ldh, resid, q, ldq, workl, workd) c c %---------------------------------------------% c | Compute the B-norm of the updated residual. | c | Keep B*RESID in WORKD(1:N) to be used in | c | the first step of the next call to dnaitr. | c %---------------------------------------------% c cnorm = .true. call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call dcopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 c c %----------------------------------% c | Exit in order to compute B*RESID | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd, 1) end if c 100 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(1:N) := B*RESID | c %----------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then rnorm = ddot (n, resid, 1, workd, 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = dnrm2(n, resid, 1) end if cnorm = .false. c if (msglvl .gt. 2) then call dvout (logfil, 1, rnorm, ndigit, & '_naup2: B-norm of residual for compressed factorization') call dmout (logfil, nev, nev, h, ldh, ndigit, & '_naup2: Compressed upper Hessenberg matrix H') end if c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 1100 continue c mxiter = iter nev = numcnv c 1200 continue ido = 99 c c %------------% c | Error Exit | c %------------% c call second (t1) tnaup2 = t1 - t0 c 9000 continue c c %---------------% c | End of dnaup2 | c %---------------% c return end getdp-2.4.2-source/contrib/Arpack/dneigh.f000644 001750 001750 00000024241 11266605602 022055 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dneigh c c\Description: c Compute the eigenvalues of the current upper Hessenberg matrix c and the corresponding Ritz estimates given the current residual norm. c c\Usage: c call dneigh c ( RNORM, N, H, LDH, RITZR, RITZI, BOUNDS, Q, LDQ, WORKL, IERR ) c c\Arguments c RNORM Double precision scalar. (INPUT) c Residual norm corresponding to the current upper Hessenberg c matrix H. c c N Integer. (INPUT) c Size of the matrix H. c c H Double precision N by N array. (INPUT) c H contains the current upper Hessenberg matrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZR, Double precision arrays of length N. (OUTPUT) c RITZI On output, RITZR(1:N) (resp. RITZI(1:N)) contains the real c (respectively imaginary) parts of the eigenvalues of H. c c BOUNDS Double precision array of length N. (OUTPUT) c On output, BOUNDS contains the Ritz estimates associated with c the eigenvalues RITZR and RITZI. This is equal to RNORM c times the last components of the eigenvectors corresponding c to the eigenvalues in RITZR and RITZI. c c Q Double precision N by N array. (WORKSPACE) c Workspace needed to store the eigenvectors of H. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Double precision work array of length N**2 + 3*N. (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. This is needed to keep the full Schur form c of H and also in the calculation of the eigenvectors of H. c c IERR Integer. (OUTPUT) c Error exit flag from dlaqrb or dtrevc. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c dlaqrb ARPACK routine to compute the real Schur form of an c upper Hessenberg matrix and last row of the Schur vectors. c second ARPACK utility routine for timing. c dmout ARPACK utility routine that prints matrices c dvout ARPACK utility routine that prints vectors. c dlacpy LAPACK matrix copy routine. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dtrevc LAPACK routine to compute the eigenvectors of a matrix c in upper quasi-triangular form c dgemv Level 2 BLAS routine for matrix vector multiplication. c dcopy Level 1 BLAS that copies one vector to another . c dnrm2 Level 1 BLAS that computes the norm of a vector. c dscal Level 1 BLAS that scales a vector. c c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.1' c c\SCCS Information: @(#) c FILE: neigh.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c None c c\EndLib c c----------------------------------------------------------------------- c subroutine dneigh (rnorm, n, h, ldh, ritzr, ritzi, bounds, & q, ldq, workl, ierr) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer ierr, n, ldh, ldq Double precision & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & bounds(n), h(ldh,n), q(ldq,n), ritzi(n), ritzr(n), & workl(n*(n+3)) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c logical select(1) integer i, iconj, msglvl Double precision & temp, vl(1) c c %----------------------% c | External Subroutines | c %----------------------% c external dcopy, dlacpy, dlaqrb, dtrevc, dvout, second c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlapy2, dnrm2 external dlapy2, dnrm2 c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mneigh c if (msglvl .gt. 2) then call dmout (logfil, n, n, h, ldh, ndigit, & '_neigh: Entering upper Hessenberg matrix H ') end if c c %-----------------------------------------------------------% c | 1. Compute the eigenvalues, the last components of the | c | corresponding Schur vectors and the full Schur form T | c | of the current upper Hessenberg matrix H. | c | dlaqrb returns the full Schur form of H in WORKL(1:N**2) | c | and the last components of the Schur vectors in BOUNDS. | c %-----------------------------------------------------------% c call dlacpy ('All', n, n, h, ldh, workl, n) call dlaqrb (.true., n, 1, n, workl, n, ritzr, ritzi, bounds, & ierr) if (ierr .ne. 0) go to 9000 c if (msglvl .gt. 1) then call dvout (logfil, n, bounds, ndigit, & '_neigh: last row of the Schur matrix for H') end if c c %-----------------------------------------------------------% c | 2. Compute the eigenvectors of the full Schur form T and | c | apply the last components of the Schur vectors to get | c | the last components of the corresponding eigenvectors. | c | Remember that if the i-th and (i+1)-st eigenvalues are | c | complex conjugate pairs, then the real & imaginary part | c | of the eigenvector components are split across adjacent | c | columns of Q. | c %-----------------------------------------------------------% c call dtrevc ('R', 'A', select, n, workl, n, vl, n, q, ldq, & n, n, workl(n*n+1), ierr) c if (ierr .ne. 0) go to 9000 c c %------------------------------------------------% c | Scale the returning eigenvectors so that their | c | euclidean norms are all one. LAPACK subroutine | c | dtrevc returns each eigenvector normalized so | c | that the element of largest magnitude has | c | magnitude 1; here the magnitude of a complex | c | number (x,y) is taken to be |x| + |y|. | c %------------------------------------------------% c iconj = 0 do 10 i=1, n if ( abs( ritzi(i) ) .le. zero ) then c c %----------------------% c | Real eigenvalue case | c %----------------------% c temp = dnrm2( n, q(1,i), 1 ) call dscal ( n, one / temp, q(1,i), 1 ) else c c %-------------------------------------------% c | Complex conjugate pair case. Note that | c | since the real and imaginary part of | c | the eigenvector are stored in consecutive | c | columns, we further normalize by the | c | square root of two. | c %-------------------------------------------% c if (iconj .eq. 0) then temp = dlapy2( dnrm2( n, q(1,i), 1 ), & dnrm2( n, q(1,i+1), 1 ) ) call dscal ( n, one / temp, q(1,i), 1 ) call dscal ( n, one / temp, q(1,i+1), 1 ) iconj = 1 else iconj = 0 end if end if 10 continue c call dgemv ('T', n, n, one, q, ldq, bounds, 1, zero, workl, 1) c if (msglvl .gt. 1) then call dvout (logfil, n, workl, ndigit, & '_neigh: Last row of the eigenvector matrix for H') end if c c %----------------------------% c | Compute the Ritz estimates | c %----------------------------% c iconj = 0 do 20 i = 1, n if ( abs( ritzi(i) ) .le. zero ) then c c %----------------------% c | Real eigenvalue case | c %----------------------% c bounds(i) = rnorm * abs( workl(i) ) else c c %-------------------------------------------% c | Complex conjugate pair case. Note that | c | since the real and imaginary part of | c | the eigenvector are stored in consecutive | c | columns, we need to take the magnitude | c | of the last components of the two vectors | c %-------------------------------------------% c if (iconj .eq. 0) then bounds(i) = rnorm * dlapy2( workl(i), workl(i+1) ) bounds(i+1) = bounds(i) iconj = 1 else iconj = 0 end if end if 20 continue c if (msglvl .gt. 2) then call dvout (logfil, n, ritzr, ndigit, & '_neigh: Real part of the eigenvalues of H') call dvout (logfil, n, ritzi, ndigit, & '_neigh: Imaginary part of the eigenvalues of H') call dvout (logfil, n, bounds, ndigit, & '_neigh: Ritz estimates for the eigenvalues of H') end if c call second (t1) tneigh = tneigh + (t1 - t0) c 9000 continue return c c %---------------% c | End of dneigh | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/snconv.f000644 001750 001750 00000007641 11266605602 022132 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: snconv c c\Description: c Convergence testing for the nonsymmetric Arnoldi eigenvalue routine. c c\Usage: c call snconv c ( N, RITZR, RITZI, BOUNDS, TOL, NCONV ) c c\Arguments c N Integer. (INPUT) c Number of Ritz values to check for convergence. c c RITZR, Real arrays of length N. (INPUT) c RITZI Real and imaginary parts of the Ritz values to be checked c for convergence. c BOUNDS Real array of length N. (INPUT) c Ritz estimates for the Ritz values in RITZR and RITZI. c c TOL Real scalar. (INPUT) c Desired backward error for a Ritz value to be considered c "converged". c c NCONV Integer scalar. (OUTPUT) c Number of "converged" Ritz values. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c second ARPACK utility routine for timing. c slamch LAPACK routine that determines machine constants. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.1' c c\SCCS Information: @(#) c FILE: nconv.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c 1. xxxx c c\EndLib c c----------------------------------------------------------------------- c subroutine snconv (n, ritzr, ritzi, bounds, tol, nconv) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer n, nconv Real & tol c c %-----------------% c | Array Arguments | c %-----------------% Real & ritzr(n), ritzi(n), bounds(n) c c %---------------% c | Local Scalars | c %---------------% c integer i Real & temp, eps23 c c %--------------------% c | External Functions | c %--------------------% c Real & slapy2, slamch external slapy2, slamch c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------------------% c | Convergence test: unlike in the symmetric code, I am not | c | using things like refined error bounds and gap condition | c | because I don't know the exact equivalent concept. | c | | c | Instead the i-th Ritz value is considered "converged" when: | c | | c | bounds(i) .le. ( TOL * | ritz | ) | c | | c | for some appropriate choice of norm. | c %-------------------------------------------------------------% c call second (t0) c c %---------------------------------% c | Get machine dependent constant. | c %---------------------------------% c eps23 = slamch('Epsilon-Machine') eps23 = eps23**(2.0E+0 / 3.0E+0) c nconv = 0 do 20 i = 1, n temp = max( eps23, slapy2( ritzr(i), ritzi(i) ) ) if (bounds(i) .le. tol*temp) nconv = nconv + 1 20 continue c call second (t1) tnconv = tnconv + (t1 - t0) c return c c %---------------% c | End of snconv | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dstqrb.f000644 001750 001750 00000040624 11266605602 022121 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dstqrb c c\Description: c Computes all eigenvalues and the last component of the eigenvectors c of a symmetric tridiagonal matrix using the implicit QL or QR method. c c This is mostly a modification of the LAPACK routine dsteqr. c See Remarks. c c\Usage: c call dstqrb c ( N, D, E, Z, WORK, INFO ) c c\Arguments c N Integer. (INPUT) c The number of rows and columns in the matrix. N >= 0. c c D Double precision array, dimension (N). (INPUT/OUTPUT) c On entry, D contains the diagonal elements of the c tridiagonal matrix. c On exit, D contains the eigenvalues, in ascending order. c If an error exit is made, the eigenvalues are correct c for indices 1,2,...,INFO-1, but they are unordered and c may not be the smallest eigenvalues of the matrix. c c E Double precision array, dimension (N-1). (INPUT/OUTPUT) c On entry, E contains the subdiagonal elements of the c tridiagonal matrix in positions 1 through N-1. c On exit, E has been destroyed. c c Z Double precision array, dimension (N). (OUTPUT) c On exit, Z contains the last row of the orthonormal c eigenvector matrix of the symmetric tridiagonal matrix. c If an error exit is made, Z contains the last row of the c eigenvector matrix associated with the stored eigenvalues. c c WORK Double precision array, dimension (max(1,2*N-2)). (WORKSPACE) c Workspace used in accumulating the transformation for c computing the last components of the eigenvectors. c c INFO Integer. (OUTPUT) c = 0: normal return. c < 0: if INFO = -i, the i-th argument had an illegal value. c > 0: if INFO = +i, the i-th eigenvalue has not converged c after a total of 30*N iterations. c c\Remarks c 1. None. c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c daxpy Level 1 BLAS that computes a vector triad. c dcopy Level 1 BLAS that copies one vector to another. c dswap Level 1 BLAS that swaps the contents of two vectors. c lsame LAPACK character comparison routine. c dlae2 LAPACK routine that computes the eigenvalues of a 2-by-2 c symmetric matrix. c dlaev2 LAPACK routine that eigendecomposition of a 2-by-2 symmetric c matrix. c dlamch LAPACK routine that determines machine constants. c dlanst LAPACK routine that computes the norm of a matrix. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlartg LAPACK Givens rotation construction routine. c dlascl LAPACK routine for careful scaling of a matrix. c dlaset LAPACK matrix initialization routine. c dlasr LAPACK routine that applies an orthogonal transformation to c a matrix. c dlasrt LAPACK sorting routine. c dsteqr LAPACK routine that computes eigenvalues and eigenvectors c of a symmetric tridiagonal matrix. c xerbla LAPACK error handler routine. c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: stqrb.F SID: 2.5 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c 1. Starting with version 2.5, this routine is a modified version c of LAPACK version 2.0 subroutine SSTEQR. No lines are deleted, c only commeted out and new lines inserted. c All lines commented out have "c$$$" at the beginning. c Note that the LAPACK version 1.0 subroutine SSTEQR contained c bugs. c c\EndLib c c----------------------------------------------------------------------- c subroutine dstqrb ( n, d, e, z, work, info ) c c %------------------% c | Scalar Arguments | c %------------------% c integer info, n c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & d( n ), e( n-1 ), z( n ), work( 2*n-2 ) c c .. parameters .. Double precision & zero, one, two, three parameter ( zero = 0.0D+0, one = 1.0D+0, & two = 2.0D+0, three = 3.0D+0 ) integer maxit parameter ( maxit = 30 ) c .. c .. local scalars .. integer i, icompz, ii, iscale, j, jtot, k, l, l1, lend, & lendm1, lendp1, lendsv, lm1, lsv, m, mm, mm1, & nm1, nmaxit Double precision & anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, & s, safmax, safmin, ssfmax, ssfmin, tst c .. c .. external functions .. logical lsame Double precision & dlamch, dlanst, dlapy2 external lsame, dlamch, dlanst, dlapy2 c .. c .. external subroutines .. external dlae2, dlaev2, dlartg, dlascl, dlaset, dlasr, & dlasrt, dswap, xerbla c .. c .. intrinsic functions .. intrinsic abs, max, sign, sqrt c .. c .. executable statements .. c c test the input parameters. c info = 0 c c$$$ IF( LSAME( COMPZ, 'N' ) ) THEN c$$$ ICOMPZ = 0 c$$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN c$$$ ICOMPZ = 1 c$$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN c$$$ ICOMPZ = 2 c$$$ ELSE c$$$ ICOMPZ = -1 c$$$ END IF c$$$ IF( ICOMPZ.LT.0 ) THEN c$$$ INFO = -1 c$$$ ELSE IF( N.LT.0 ) THEN c$$$ INFO = -2 c$$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, c$$$ $ N ) ) ) THEN c$$$ INFO = -6 c$$$ END IF c$$$ IF( INFO.NE.0 ) THEN c$$$ CALL XERBLA( 'SSTEQR', -INFO ) c$$$ RETURN c$$$ END IF c c *** New starting with version 2.5 *** c icompz = 2 c ************************************* c c quick return if possible c if( n.eq.0 ) $ return c if( n.eq.1 ) then if( icompz.eq.2 ) z( 1 ) = one return end if c c determine the unit roundoff and over/underflow thresholds. c eps = dlamch( 'e' ) eps2 = eps**2 safmin = dlamch( 's' ) safmax = one / safmin ssfmax = sqrt( safmax ) / three ssfmin = sqrt( safmin ) / eps2 c c compute the eigenvalues and eigenvectors of the tridiagonal c matrix. c c$$ if( icompz.eq.2 ) c$$$ $ call dlaset( 'full', n, n, zero, one, z, ldz ) c c *** New starting with version 2.5 *** c if ( icompz .eq. 2 ) then do 5 j = 1, n-1 z(j) = zero 5 continue z( n ) = one end if c ************************************* c nmaxit = n*maxit jtot = 0 c c determine where the matrix splits and choose ql or qr iteration c for each block, according to whether top or bottom diagonal c element is smaller. c l1 = 1 nm1 = n - 1 c 10 continue if( l1.gt.n ) $ go to 160 if( l1.gt.1 ) $ e( l1-1 ) = zero if( l1.le.nm1 ) then do 20 m = l1, nm1 tst = abs( e( m ) ) if( tst.eq.zero ) $ go to 30 if( tst.le.( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+ $ 1 ) ) ) )*eps ) then e( m ) = zero go to 30 end if 20 continue end if m = n c 30 continue l = l1 lsv = l lend = m lendsv = lend l1 = m + 1 if( lend.eq.l ) $ go to 10 c c scale submatrix in rows and columns l to lend c anorm = dlanst( 'i', lend-l+1, d( l ), e( l ) ) iscale = 0 if( anorm.eq.zero ) $ go to 10 if( anorm.gt.ssfmax ) then iscale = 1 call dlascl( 'g', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n, $ info ) call dlascl( 'g', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n, $ info ) else if( anorm.lt.ssfmin ) then iscale = 2 call dlascl( 'g', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n, $ info ) call dlascl( 'g', 0, 0, anorm, ssfmin, lend-l, 1, e( l ), n, $ info ) end if c c choose between ql and qr iteration c if( abs( d( lend ) ).lt.abs( d( l ) ) ) then lend = lsv l = lendsv end if c if( lend.gt.l ) then c c ql iteration c c look for small subdiagonal element. c 40 continue if( l.ne.lend ) then lendm1 = lend - 1 do 50 m = l, lendm1 tst = abs( e( m ) )**2 if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+ $ safmin )go to 60 50 continue end if c m = lend c 60 continue if( m.lt.lend ) $ e( m ) = zero p = d( l ) if( m.eq.l ) $ go to 80 c c if remaining matrix is 2-by-2, use dlae2 or dlaev2 c to compute its eigensystem. c if( m.eq.l+1 ) then if( icompz.gt.0 ) then call dlaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) work( l ) = c work( n-1+l ) = s c$$$ call dlasr( 'r', 'v', 'b', n, 2, work( l ), c$$$ $ work( n-1+l ), z( 1, l ), ldz ) c c *** New starting with version 2.5 *** c tst = z(l+1) z(l+1) = c*tst - s*z(l) z(l) = s*tst + c*z(l) c ************************************* else call dlae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) end if d( l ) = rt1 d( l+1 ) = rt2 e( l ) = zero l = l + 2 if( l.le.lend ) $ go to 40 go to 140 end if c if( jtot.eq.nmaxit ) $ go to 140 jtot = jtot + 1 c c form shift. c g = ( d( l+1 )-p ) / ( two*e( l ) ) r = dlapy2( g, one ) g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) c s = one c = one p = zero c c inner loop c mm1 = m - 1 do 70 i = mm1, l, -1 f = s*e( i ) b = c*e( i ) call dlartg( g, f, c, s, r ) if( i.ne.m-1 ) $ e( i+1 ) = r g = d( i+1 ) - p r = ( d( i )-g )*s + two*c*b p = s*r d( i+1 ) = g + p g = c*r - b c c if eigenvectors are desired, then save rotations. c if( icompz.gt.0 ) then work( i ) = c work( n-1+i ) = -s end if c 70 continue c c if eigenvectors are desired, then apply saved rotations. c if( icompz.gt.0 ) then mm = m - l + 1 c$$$ call dlasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ), c$$$ $ z( 1, l ), ldz ) c c *** New starting with version 2.5 *** c call dlasr( 'r', 'v', 'b', 1, mm, work( l ), & work( n-1+l ), z( l ), 1 ) c ************************************* end if c d( l ) = d( l ) - p e( l ) = g go to 40 c c eigenvalue found. c 80 continue d( l ) = p c l = l + 1 if( l.le.lend ) $ go to 40 go to 140 c else c c qr iteration c c look for small superdiagonal element. c 90 continue if( l.ne.lend ) then lendp1 = lend + 1 do 100 m = l, lendp1, -1 tst = abs( e( m-1 ) )**2 if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+ $ safmin )go to 110 100 continue end if c m = lend c 110 continue if( m.gt.lend ) $ e( m-1 ) = zero p = d( l ) if( m.eq.l ) $ go to 130 c c if remaining matrix is 2-by-2, use dlae2 or dlaev2 c to compute its eigensystem. c if( m.eq.l-1 ) then if( icompz.gt.0 ) then call dlaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) c$$$ work( m ) = c c$$$ work( n-1+m ) = s c$$$ call dlasr( 'r', 'v', 'f', n, 2, work( m ), c$$$ $ work( n-1+m ), z( 1, l-1 ), ldz ) c c *** New starting with version 2.5 *** c tst = z(l) z(l) = c*tst - s*z(l-1) z(l-1) = s*tst + c*z(l-1) c ************************************* else call dlae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) end if d( l-1 ) = rt1 d( l ) = rt2 e( l-1 ) = zero l = l - 2 if( l.ge.lend ) $ go to 90 go to 140 end if c if( jtot.eq.nmaxit ) $ go to 140 jtot = jtot + 1 c c form shift. c g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) r = dlapy2( g, one ) g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) c s = one c = one p = zero c c inner loop c lm1 = l - 1 do 120 i = m, lm1 f = s*e( i ) b = c*e( i ) call dlartg( g, f, c, s, r ) if( i.ne.m ) $ e( i-1 ) = r g = d( i ) - p r = ( d( i+1 )-g )*s + two*c*b p = s*r d( i ) = g + p g = c*r - b c c if eigenvectors are desired, then save rotations. c if( icompz.gt.0 ) then work( i ) = c work( n-1+i ) = s end if c 120 continue c c if eigenvectors are desired, then apply saved rotations. c if( icompz.gt.0 ) then mm = l - m + 1 c$$$ call dlasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ), c$$$ $ z( 1, m ), ldz ) c c *** New starting with version 2.5 *** c call dlasr( 'r', 'v', 'f', 1, mm, work( m ), work( n-1+m ), & z( m ), 1 ) c ************************************* end if c d( l ) = d( l ) - p e( lm1 ) = g go to 90 c c eigenvalue found. c 130 continue d( l ) = p c l = l - 1 if( l.ge.lend ) $ go to 90 go to 140 c end if c c undo scaling if necessary c 140 continue if( iscale.eq.1 ) then call dlascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1, $ d( lsv ), n, info ) call dlascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ), $ n, info ) else if( iscale.eq.2 ) then call dlascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1, $ d( lsv ), n, info ) call dlascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ), $ n, info ) end if c c check for no convergence to an eigenvalue after a total c of n*maxit iterations. c if( jtot.lt.nmaxit ) $ go to 10 do 150 i = 1, n - 1 if( e( i ).ne.zero ) $ info = info + 1 150 continue go to 190 c c order eigenvalues and eigenvectors. c 160 continue if( icompz.eq.0 ) then c c use quick sort c call dlasrt( 'i', n, d, info ) c else c c use selection sort to minimize swaps of eigenvectors c do 180 ii = 2, n i = ii - 1 k = i p = d( i ) do 170 j = ii, n if( d( j ).lt.p ) then k = j p = d( j ) end if 170 continue if( k.ne.i ) then d( k ) = d( i ) d( i ) = p c$$$ call dswap( n, z( 1, i ), 1, z( 1, k ), 1 ) c *** New starting with version 2.5 *** c p = z(k) z(k) = z(i) z(i) = p c ************************************* end if 180 continue end if c 190 continue return c c %---------------% c | End of dstqrb | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/zgetv0.f000644 001750 001750 00000031274 11266605602 022042 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: zgetv0 c c\Description: c Generate a random initial residual vector for the Arnoldi process. c Force the residual vector to be in the range of the operator OP. c c\Usage: c call zgetv0 c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, c IPNTR, WORKD, IERR ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to zgetv0. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 99: done c ------------------------------------------------------------- c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B in the (generalized) c eigenvalue problem A*x = lambda*B*x. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x c c ITRY Integer. (INPUT) c ITRY counts the number of times that zgetv0 is called. c It should be set to 1 on the initial call to zgetv0. c c INITV Logical variable. (INPUT) c .TRUE. => the initial residual vector is given in RESID. c .FALSE. => generate a random initial residual vector. c c N Integer. (INPUT) c Dimension of the problem. c c J Integer. (INPUT) c Index of the residual vector to be generated, with respect to c the Arnoldi process. J > 1 in case of a "restart". c c V Complex*16 N by J array. (INPUT) c The first J-1 columns of V contain the current Arnoldi basis c if this is a "restart". c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c RESID Complex*16 array of length N. (INPUT/OUTPUT) c Initial residual vector to be generated. If RESID is c provided, force RESID into the range of the operator OP. c c RNORM Double precision scalar. (OUTPUT) c B-norm of the generated residual. c c IPNTR Integer array of length 3. (OUTPUT) c c WORKD Complex*16 work array of length 2*N. (REVERSE COMMUNICATION). c On exit, WORK(1:N) = B*RESID to be used in SSAITR. c c IERR Integer. (OUTPUT) c = 0: Normal exit. c = -1: Cannot generate a nontrivial restarted residual vector c in the range of the operator OP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex*16 c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c c\Routines called: c second ARPACK utility routine for timing. c zvout ARPACK utility routine that prints vectors. c zlarnv LAPACK routine for generating a random vector. c zgemv Level 2 BLAS routine for matrix vector multiplication. c zcopy Level 1 BLAS that copies one vector to another. c zdotc Level 1 BLAS that computes the scalar product of two vectors. c dznrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: getv0.F SID: 2.3 DATE OF SID: 08/27/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine zgetv0 & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, & ipntr, workd, ierr ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 logical initv integer ido, ierr, itry, j, ldv, n Double precision & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Complex*16 & resid(n), v(ldv,j), workd(2*n) c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero Double precision & rzero parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0), & rzero = 0.0D+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c logical first, inits, orth integer idist, iseed(4), iter, msglvl, jj Double precision & rnorm0 Complex*16 & cnorm save first, iseed, inits, iter, msglvl, orth, rnorm0 c c %----------------------% c | External Subroutines | c %----------------------% c external zcopy, zgemv, zlarnv, zvout, second c c %--------------------% c | External Functions | c %--------------------% c Double precision & dznrm2, dlapy2 Complex*16 & zdotc external zdotc, dznrm2, dlapy2 c c %-----------------% c | Data Statements | c %-----------------% c data inits /.true./ c c %-----------------------% c | Executable Statements | c %-----------------------% c c c %-----------------------------------% c | Initialize the seed of the LAPACK | c | random number generator | c %-----------------------------------% c if (inits) then iseed(1) = 1 iseed(2) = 3 iseed(3) = 5 iseed(4) = 7 inits = .false. end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mgetv0 c ierr = 0 iter = 0 first = .FALSE. orth = .FALSE. c c %-----------------------------------------------------% c | Possibly generate a random starting vector in RESID | c | Use a LAPACK random number generator used by the | c | matrix generation routines. | c | idist = 1: uniform (0,1) distribution; | c | idist = 2: uniform (-1,1) distribution; | c | idist = 3: normal (0,1) distribution; | c %-----------------------------------------------------% c if (.not.initv) then idist = 2 call zlarnv (idist, iseed, n, resid) end if c c %----------------------------------------------------------% c | Force the starting vector into the range of OP to handle | c | the generalized problem when B is possibly (singular). | c %----------------------------------------------------------% c call second (t2) if (bmat .eq. 'G') then nopx = nopx + 1 ipntr(1) = 1 ipntr(2) = n + 1 call zcopy (n, resid, 1, workd, 1) ido = -1 go to 9000 end if end if c c %----------------------------------------% c | Back from computing B*(initial-vector) | c %----------------------------------------% c if (first) go to 20 c c %-----------------------------------------------% c | Back from computing B*(orthogonalized-vector) | c %-----------------------------------------------% c if (orth) go to 40 c call second (t3) tmvopx = tmvopx + (t3 - t2) c c %------------------------------------------------------% c | Starting vector is now in the range of OP; r = OP*r; | c | Compute B-norm of starting vector. | c %------------------------------------------------------% c call second (t2) first = .TRUE. if (bmat .eq. 'G') then nbx = nbx + 1 call zcopy (n, workd(n+1), 1, resid, 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 go to 9000 else if (bmat .eq. 'I') then call zcopy (n, resid, 1, workd, 1) end if c 20 continue c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c first = .FALSE. if (bmat .eq. 'G') then cnorm = zdotc (n, resid, 1, workd, 1) rnorm0 = sqrt(dlapy2(dble(cnorm),dimag(cnorm))) else if (bmat .eq. 'I') then rnorm0 = dznrm2(n, resid, 1) end if rnorm = rnorm0 c c %---------------------------------------------% c | Exit if this is the very first Arnoldi step | c %---------------------------------------------% c if (j .eq. 1) go to 50 c c %---------------------------------------------------------------- c | Otherwise need to B-orthogonalize the starting vector against | c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | c | This is the case where an invariant subspace is encountered | c | in the middle of the Arnoldi factorization. | c | | c | s = V^{T}*B*r; r = r - V*s; | c | | c | Stopping criteria used for iter. ref. is discussed in | c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | c %---------------------------------------------------------------% c orth = .TRUE. 30 continue c call zgemv ('C', n, j-1, one, v, ldv, workd, 1, & zero, workd(n+1), 1) call zgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, & one, resid, 1) c c %----------------------------------------------------------% c | Compute the B-norm of the orthogonalized starting vector | c %----------------------------------------------------------% c call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call zcopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 go to 9000 else if (bmat .eq. 'I') then call zcopy (n, resid, 1, workd, 1) end if c 40 continue c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then cnorm = zdotc (n, resid, 1, workd, 1) rnorm = sqrt(dlapy2(dble(cnorm),dimag(cnorm))) else if (bmat .eq. 'I') then rnorm = dznrm2(n, resid, 1) end if c c %--------------------------------------% c | Check for further orthogonalization. | c %--------------------------------------% c if (msglvl .gt. 2) then call dvout (logfil, 1, rnorm0, ndigit, & '_getv0: re-orthonalization ; rnorm0 is') call dvout (logfil, 1, rnorm, ndigit, & '_getv0: re-orthonalization ; rnorm is') end if c if (rnorm .gt. 0.717*rnorm0) go to 50 c iter = iter + 1 if (iter .le. 1) then c c %-----------------------------------% c | Perform iterative refinement step | c %-----------------------------------% c rnorm0 = rnorm go to 30 else c c %------------------------------------% c | Iterative refinement step "failed" | c %------------------------------------% c do 45 jj = 1, n resid(jj) = zero 45 continue rnorm = rzero ierr = -1 end if c 50 continue c if (msglvl .gt. 0) then call dvout (logfil, 1, rnorm, ndigit, & '_getv0: B-norm of initial / restarted starting vector') end if if (msglvl .gt. 2) then call zvout (logfil, n, resid, ndigit, & '_getv0: initial / restarted starting vector') end if ido = 99 c call second (t1) tgetv0 = tgetv0 + (t1 - t0) c 9000 continue return c c %---------------% c | End of zgetv0 | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dvout.f000644 001750 001750 00000007604 11266605602 021764 0ustar00geuzainegeuzaine000000 000000 *----------------------------------------------------------------------- * Routine: DVOUT * * Purpose: Real vector output routine. * * Usage: CALL DVOUT (LOUT, N, SX, IDIGIT, IFMT) * * Arguments * N - Length of array SX. (Input) * SX - Real array to be printed. (Input) * IFMT - Format to be used in printing array SX. (Input) * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) * If IDIGIT .LT. 0, printing is done with 72 columns. * If IDIGIT .GT. 0, printing is done with 132 columns. * *----------------------------------------------------------------------- * SUBROUTINE DVOUT( LOUT, N, SX, IDIGIT, IFMT ) * ... * ... SPECIFICATIONS FOR ARGUMENTS * ... * ... SPECIFICATIONS FOR LOCAL VARIABLES * .. Scalar Arguments .. CHARACTER*( * ) IFMT INTEGER IDIGIT, LOUT, N * .. * .. Array Arguments .. DOUBLE PRECISION SX( * ) * .. * .. Local Scalars .. CHARACTER*80 LINE INTEGER I, K1, K2, LLL, NDIGIT * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN, MIN0 * .. * .. Executable Statements .. * ... * ... FIRST EXECUTABLE STATEMENT * * LLL = MIN( LEN( IFMT ), 80 ) DO 10 I = 1, LLL LINE( I: I ) = '-' 10 CONTINUE * DO 20 I = LLL + 1, 80 LINE( I: I ) = ' ' 20 CONTINUE * WRITE( LOUT, FMT = 9999 )IFMT, LINE( 1: LLL ) 9999 FORMAT( / 1X, A, / 1X, A ) * IF( N.LE.0 ) $ RETURN NDIGIT = IDIGIT IF( IDIGIT.EQ.0 ) $ NDIGIT = 4 * *======================================================================= * CODE FOR OUTPUT USING 72 COLUMNS FORMAT *======================================================================= * IF( IDIGIT.LT.0 ) THEN NDIGIT = -IDIGIT IF( NDIGIT.LE.4 ) THEN DO 30 K1 = 1, N, 5 K2 = MIN0( N, K1+4 ) WRITE( LOUT, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 ) 30 CONTINUE ELSE IF( NDIGIT.LE.6 ) THEN DO 40 K1 = 1, N, 4 K2 = MIN0( N, K1+3 ) WRITE( LOUT, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 ) 40 CONTINUE ELSE IF( NDIGIT.LE.10 ) THEN DO 50 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) WRITE( LOUT, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 ) 50 CONTINUE ELSE DO 60 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 ) 60 CONTINUE END IF * *======================================================================= * CODE FOR OUTPUT USING 132 COLUMNS FORMAT *======================================================================= * ELSE IF( NDIGIT.LE.4 ) THEN DO 70 K1 = 1, N, 10 K2 = MIN0( N, K1+9 ) WRITE( LOUT, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 ) 70 CONTINUE ELSE IF( NDIGIT.LE.6 ) THEN DO 80 K1 = 1, N, 8 K2 = MIN0( N, K1+7 ) WRITE( LOUT, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 ) 80 CONTINUE ELSE IF( NDIGIT.LE.10 ) THEN DO 90 K1 = 1, N, 6 K2 = MIN0( N, K1+5 ) WRITE( LOUT, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 ) 90 CONTINUE ELSE DO 100 K1 = 1, N, 5 K2 = MIN0( N, K1+4 ) WRITE( LOUT, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 ) 100 CONTINUE END IF END IF WRITE( LOUT, FMT = 9994 ) RETURN 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1P, 10D12.3 ) 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 8D14.5 ) 9996 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 6D18.9 ) 9995 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 5D24.13 ) 9994 FORMAT( 1X, ' ' ) END getdp-2.4.2-source/contrib/Arpack/sneigh.f000644 001750 001750 00000024035 11266605602 022075 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: sneigh c c\Description: c Compute the eigenvalues of the current upper Hessenberg matrix c and the corresponding Ritz estimates given the current residual norm. c c\Usage: c call sneigh c ( RNORM, N, H, LDH, RITZR, RITZI, BOUNDS, Q, LDQ, WORKL, IERR ) c c\Arguments c RNORM Real scalar. (INPUT) c Residual norm corresponding to the current upper Hessenberg c matrix H. c c N Integer. (INPUT) c Size of the matrix H. c c H Real N by N array. (INPUT) c H contains the current upper Hessenberg matrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZR, Real arrays of length N. (OUTPUT) c RITZI On output, RITZR(1:N) (resp. RITZI(1:N)) contains the real c (respectively imaginary) parts of the eigenvalues of H. c c BOUNDS Real array of length N. (OUTPUT) c On output, BOUNDS contains the Ritz estimates associated with c the eigenvalues RITZR and RITZI. This is equal to RNORM c times the last components of the eigenvectors corresponding c to the eigenvalues in RITZR and RITZI. c c Q Real N by N array. (WORKSPACE) c Workspace needed to store the eigenvectors of H. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Real work array of length N**2 + 3*N. (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. This is needed to keep the full Schur form c of H and also in the calculation of the eigenvectors of H. c c IERR Integer. (OUTPUT) c Error exit flag from slaqrb or strevc. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c slaqrb ARPACK routine to compute the real Schur form of an c upper Hessenberg matrix and last row of the Schur vectors. c second ARPACK utility routine for timing. c smout ARPACK utility routine that prints matrices c svout ARPACK utility routine that prints vectors. c slacpy LAPACK matrix copy routine. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c strevc LAPACK routine to compute the eigenvectors of a matrix c in upper quasi-triangular form c sgemv Level 2 BLAS routine for matrix vector multiplication. c scopy Level 1 BLAS that copies one vector to another . c snrm2 Level 1 BLAS that computes the norm of a vector. c sscal Level 1 BLAS that scales a vector. c c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.1' c c\SCCS Information: @(#) c FILE: neigh.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c None c c\EndLib c c----------------------------------------------------------------------- c subroutine sneigh (rnorm, n, h, ldh, ritzr, ritzi, bounds, & q, ldq, workl, ierr) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer ierr, n, ldh, ldq Real & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c Real & bounds(n), h(ldh,n), q(ldq,n), ritzi(n), ritzr(n), & workl(n*(n+3)) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c logical select(1) integer i, iconj, msglvl Real & temp, vl(1) c c %----------------------% c | External Subroutines | c %----------------------% c external scopy, slacpy, slaqrb, strevc, svout, second c c %--------------------% c | External Functions | c %--------------------% c Real & slapy2, snrm2 external slapy2, snrm2 c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mneigh c if (msglvl .gt. 2) then call smout (logfil, n, n, h, ldh, ndigit, & '_neigh: Entering upper Hessenberg matrix H ') end if c c %-----------------------------------------------------------% c | 1. Compute the eigenvalues, the last components of the | c | corresponding Schur vectors and the full Schur form T | c | of the current upper Hessenberg matrix H. | c | slaqrb returns the full Schur form of H in WORKL(1:N**2) | c | and the last components of the Schur vectors in BOUNDS. | c %-----------------------------------------------------------% c call slacpy ('All', n, n, h, ldh, workl, n) call slaqrb (.true., n, 1, n, workl, n, ritzr, ritzi, bounds, & ierr) if (ierr .ne. 0) go to 9000 c if (msglvl .gt. 1) then call svout (logfil, n, bounds, ndigit, & '_neigh: last row of the Schur matrix for H') end if c c %-----------------------------------------------------------% c | 2. Compute the eigenvectors of the full Schur form T and | c | apply the last components of the Schur vectors to get | c | the last components of the corresponding eigenvectors. | c | Remember that if the i-th and (i+1)-st eigenvalues are | c | complex conjugate pairs, then the real & imaginary part | c | of the eigenvector components are split across adjacent | c | columns of Q. | c %-----------------------------------------------------------% c call strevc ('R', 'A', select, n, workl, n, vl, n, q, ldq, & n, n, workl(n*n+1), ierr) c if (ierr .ne. 0) go to 9000 c c %------------------------------------------------% c | Scale the returning eigenvectors so that their | c | euclidean norms are all one. LAPACK subroutine | c | strevc returns each eigenvector normalized so | c | that the element of largest magnitude has | c | magnitude 1; here the magnitude of a complex | c | number (x,y) is taken to be |x| + |y|. | c %------------------------------------------------% c iconj = 0 do 10 i=1, n if ( abs( ritzi(i) ) .le. zero ) then c c %----------------------% c | Real eigenvalue case | c %----------------------% c temp = snrm2( n, q(1,i), 1 ) call sscal ( n, one / temp, q(1,i), 1 ) else c c %-------------------------------------------% c | Complex conjugate pair case. Note that | c | since the real and imaginary part of | c | the eigenvector are stored in consecutive | c | columns, we further normalize by the | c | square root of two. | c %-------------------------------------------% c if (iconj .eq. 0) then temp = slapy2( snrm2( n, q(1,i), 1 ), & snrm2( n, q(1,i+1), 1 ) ) call sscal ( n, one / temp, q(1,i), 1 ) call sscal ( n, one / temp, q(1,i+1), 1 ) iconj = 1 else iconj = 0 end if end if 10 continue c call sgemv ('T', n, n, one, q, ldq, bounds, 1, zero, workl, 1) c if (msglvl .gt. 1) then call svout (logfil, n, workl, ndigit, & '_neigh: Last row of the eigenvector matrix for H') end if c c %----------------------------% c | Compute the Ritz estimates | c %----------------------------% c iconj = 0 do 20 i = 1, n if ( abs( ritzi(i) ) .le. zero ) then c c %----------------------% c | Real eigenvalue case | c %----------------------% c bounds(i) = rnorm * abs( workl(i) ) else c c %-------------------------------------------% c | Complex conjugate pair case. Note that | c | since the real and imaginary part of | c | the eigenvector are stored in consecutive | c | columns, we need to take the magnitude | c | of the last components of the two vectors | c %-------------------------------------------% c if (iconj .eq. 0) then bounds(i) = rnorm * slapy2( workl(i), workl(i+1) ) bounds(i+1) = bounds(i) iconj = 1 else iconj = 0 end if end if 20 continue c if (msglvl .gt. 2) then call svout (logfil, n, ritzr, ndigit, & '_neigh: Real part of the eigenvalues of H') call svout (logfil, n, ritzi, ndigit, & '_neigh: Imaginary part of the eigenvalues of H') call svout (logfil, n, bounds, ndigit, & '_neigh: Ritz estimates for the eigenvalues of H') end if c call second (t1) tneigh = tneigh + (t1 - t0) c 9000 continue return c c %---------------% c | End of sneigh | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dseigt.f000644 001750 001750 00000012115 11266605602 022073 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dseigt c c\Description: c Compute the eigenvalues of the current symmetric tridiagonal matrix c and the corresponding error bounds given the current residual norm. c c\Usage: c call dseigt c ( RNORM, N, H, LDH, EIG, BOUNDS, WORKL, IERR ) c c\Arguments c RNORM Double precision scalar. (INPUT) c RNORM contains the residual norm corresponding to the current c symmetric tridiagonal matrix H. c c N Integer. (INPUT) c Size of the symmetric tridiagonal matrix H. c c H Double precision N by 2 array. (INPUT) c H contains the symmetric tridiagonal matrix with the c subdiagonal in the first column starting at H(2,1) and the c main diagonal in second column. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c EIG Double precision array of length N. (OUTPUT) c On output, EIG contains the N eigenvalues of H possibly c unsorted. The BOUNDS arrays are returned in the c same sorted order as EIG. c c BOUNDS Double precision array of length N. (OUTPUT) c On output, BOUNDS contains the error estimates corresponding c to the eigenvalues EIG. This is equal to RNORM times the c last components of the eigenvectors corresponding to the c eigenvalues in EIG. c c WORKL Double precision work array of length 3*N. (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c IERR Integer. (OUTPUT) c Error exit flag from dstqrb. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c dstqrb ARPACK routine that computes the eigenvalues and the c last components of the eigenvectors of a symmetric c and tridiagonal matrix. c second ARPACK utility routine for timing. c dvout ARPACK utility routine that prints vectors. c dcopy Level 1 BLAS that copies one vector to another. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.4' c c\SCCS Information: @(#) c FILE: seigt.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c None c c\EndLib c c----------------------------------------------------------------------- c subroutine dseigt & ( rnorm, n, h, ldh, eig, bounds, workl, ierr ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer ierr, ldh, n Double precision & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & eig(n), bounds(n), h(ldh,2), workl(3*n) c c %------------% c | Parameters | c %------------% c Double precision & zero parameter (zero = 0.0D+0) c c %---------------% c | Local Scalars | c %---------------% c integer i, k, msglvl c c %----------------------% c | External Subroutines | c %----------------------% c external dcopy, dstqrb, dvout, second c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mseigt c if (msglvl .gt. 0) then call dvout (logfil, n, h(1,2), ndigit, & '_seigt: main diagonal of matrix H') if (n .gt. 1) then call dvout (logfil, n-1, h(2,1), ndigit, & '_seigt: sub diagonal of matrix H') end if end if c call dcopy (n, h(1,2), 1, eig, 1) call dcopy (n-1, h(2,1), 1, workl, 1) call dstqrb (n, eig, workl, bounds, workl(n+1), ierr) if (ierr .ne. 0) go to 9000 if (msglvl .gt. 1) then call dvout (logfil, n, bounds, ndigit, & '_seigt: last row of the eigenvector matrix for H') end if c c %-----------------------------------------------% c | Finally determine the error bounds associated | c | with the n Ritz values of H. | c %-----------------------------------------------% c do 30 k = 1, n bounds(k) = rnorm*abs(bounds(k)) 30 continue c call second (t1) tseigt = tseigt + (t1 - t0) c 9000 continue return c c %---------------% c | End of dseigt | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/ssapps.f000644 001750 001750 00000043732 11266605602 022136 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: ssapps c c\Description: c Given the Arnoldi factorization c c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, c c apply NP shifts implicitly resulting in c c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q c c where Q is an orthogonal matrix of order KEV+NP. Q is the product of c rotations resulting from the NP bulge chasing sweeps. The updated Arnoldi c factorization becomes: c c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. c c\Usage: c call ssapps c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, WORKD ) c c\Arguments c N Integer. (INPUT) c Problem size, i.e. dimension of matrix A. c c KEV Integer. (INPUT) c INPUT: KEV+NP is the size of the input matrix H. c OUTPUT: KEV is the size of the updated matrix HNEW. c c NP Integer. (INPUT) c Number of implicit shifts to be applied. c c SHIFT Real array of length NP. (INPUT) c The shifts to be applied. c c V Real N by (KEV+NP) array. (INPUT/OUTPUT) c INPUT: V contains the current KEV+NP Arnoldi vectors. c OUTPUT: VNEW = V(1:n,1:KEV); the updated Arnoldi vectors c are in the first KEV columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Real (KEV+NP) by 2 array. (INPUT/OUTPUT) c INPUT: H contains the symmetric tridiagonal matrix of the c Arnoldi factorization with the subdiagonal in the 1st column c starting at H(2,1) and the main diagonal in the 2nd column. c OUTPUT: H contains the updated tridiagonal matrix in the c KEV leading submatrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RESID Real array of length (N). (INPUT/OUTPUT) c INPUT: RESID contains the the residual vector r_{k+p}. c OUTPUT: RESID is the updated residual vector rnew_{k}. c c Q Real KEV+NP by KEV+NP work array. (WORKSPACE) c Work array used to accumulate the rotations during the bulge c chase sweep. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKD Real work array of length 2*N. (WORKSPACE) c Distributed array used in the application of the accumulated c orthogonal matrix Q. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c svout ARPACK utility routine that prints vectors. c slamch LAPACK routine that determines machine constants. c slartg LAPACK Givens rotation construction routine. c slacpy LAPACK matrix copy routine. c slaset LAPACK matrix initialization routine. c sgemv Level 2 BLAS routine for matrix vector multiplication. c saxpy Level 1 BLAS that computes a vector triad. c scopy Level 1 BLAS that copies one vector to another. c sscal Level 1 BLAS that scales a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/16/93: Version ' 2.4' c c\SCCS Information: @(#) c FILE: sapps.F SID: 2.6 DATE OF SID: 3/28/97 RELEASE: 2 c c\Remarks c 1. In this version, each shift is applied to all the subblocks of c the tridiagonal matrix H and not just to the submatrix that it c comes from. This routine assumes that the subdiagonal elements c of H that are stored in h(1:kev+np,1) are nonegative upon input c and enforce this condition upon output. This version incorporates c deflation. See code for documentation. c c\EndLib c c----------------------------------------------------------------------- c subroutine ssapps & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, workd ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer kev, ldh, ldq, ldv, n, np c c %-----------------% c | Array Arguments | c %-----------------% c Real & h(ldh,2), q(ldq,kev+np), resid(n), shift(np), & v(ldv,kev+np), workd(2*n) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %---------------% c | Local Scalars | c %---------------% c integer i, iend, istart, itop, j, jj, kplusp, msglvl logical first Real & a1, a2, a3, a4, big, c, epsmch, f, g, r, s save epsmch, first c c c %----------------------% c | External Subroutines | c %----------------------% c external saxpy, scopy, sscal, slacpy, slartg, slaset, svout, & ivout, second, sgemv c c %--------------------% c | External Functions | c %--------------------% c Real & slamch external slamch c c %----------------------% c | Intrinsics Functions | c %----------------------% c intrinsic abs c c %----------------% c | Data statments | c %----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then epsmch = slamch('Epsilon-Machine') first = .false. end if itop = 1 c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = msapps c kplusp = kev + np c c %----------------------------------------------% c | Initialize Q to the identity matrix of order | c | kplusp used to accumulate the rotations. | c %----------------------------------------------% c call slaset ('All', kplusp, kplusp, zero, one, q, ldq) c c %----------------------------------------------% c | Quick return if there are no shifts to apply | c %----------------------------------------------% c if (np .eq. 0) go to 9000 c c %----------------------------------------------------------% c | Apply the np shifts implicitly. Apply each shift to the | c | whole matrix and not just to the submatrix from which it | c | comes. | c %----------------------------------------------------------% c do 90 jj = 1, np c istart = itop c c %----------------------------------------------------------% c | Check for splitting and deflation. Currently we consider | c | an off-diagonal element h(i+1,1) negligible if | c | h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) | c | for i=1:KEV+NP-1. | c | If above condition tests true then we set h(i+1,1) = 0. | c | Note that h(1:KEV+NP,1) are assumed to be non negative. | c %----------------------------------------------------------% c 20 continue c c %------------------------------------------------% c | The following loop exits early if we encounter | c | a negligible off diagonal element. | c %------------------------------------------------% c do 30 i = istart, kplusp-1 big = abs(h(i,2)) + abs(h(i+1,2)) if (h(i+1,1) .le. epsmch*big) then if (msglvl .gt. 0) then call ivout (logfil, 1, i, ndigit, & '_sapps: deflation at row/column no.') call ivout (logfil, 1, jj, ndigit, & '_sapps: occured before shift number.') call svout (logfil, 1, h(i+1,1), ndigit, & '_sapps: the corresponding off diagonal element') end if h(i+1,1) = zero iend = i go to 40 end if 30 continue iend = kplusp 40 continue c if (istart .lt. iend) then c c %--------------------------------------------------------% c | Construct the plane rotation G'(istart,istart+1,theta) | c | that attempts to drive h(istart+1,1) to zero. | c %--------------------------------------------------------% c f = h(istart,2) - shift(jj) g = h(istart+1,1) call slartg (f, g, c, s, r) c c %-------------------------------------------------------% c | Apply rotation to the left and right of H; | c | H <- G' * H * G, where G = G(istart,istart+1,theta). | c | This will create a "bulge". | c %-------------------------------------------------------% c a1 = c*h(istart,2) + s*h(istart+1,1) a2 = c*h(istart+1,1) + s*h(istart+1,2) a4 = c*h(istart+1,2) - s*h(istart+1,1) a3 = c*h(istart+1,1) - s*h(istart,2) h(istart,2) = c*a1 + s*a2 h(istart+1,2) = c*a4 - s*a3 h(istart+1,1) = c*a3 + s*a4 c c %----------------------------------------------------% c | Accumulate the rotation in the matrix Q; Q <- Q*G | c %----------------------------------------------------% c do 60 j = 1, min(istart+jj,kplusp) a1 = c*q(j,istart) + s*q(j,istart+1) q(j,istart+1) = - s*q(j,istart) + c*q(j,istart+1) q(j,istart) = a1 60 continue c c c %----------------------------------------------% c | The following loop chases the bulge created. | c | Note that the previous rotation may also be | c | done within the following loop. But it is | c | kept separate to make the distinction among | c | the bulge chasing sweeps and the first plane | c | rotation designed to drive h(istart+1,1) to | c | zero. | c %----------------------------------------------% c do 70 i = istart+1, iend-1 c c %----------------------------------------------% c | Construct the plane rotation G'(i,i+1,theta) | c | that zeros the i-th bulge that was created | c | by G(i-1,i,theta). g represents the bulge. | c %----------------------------------------------% c f = h(i,1) g = s*h(i+1,1) c c %----------------------------------% c | Final update with G(i-1,i,theta) | c %----------------------------------% c h(i+1,1) = c*h(i+1,1) call slartg (f, g, c, s, r) c c %-------------------------------------------% c | The following ensures that h(1:iend-1,1), | c | the first iend-2 off diagonal of elements | c | H, remain non negative. | c %-------------------------------------------% c if (r .lt. zero) then r = -r c = -c s = -s end if c c %--------------------------------------------% c | Apply rotation to the left and right of H; | c | H <- G * H * G', where G = G(i,i+1,theta) | c %--------------------------------------------% c h(i,1) = r c a1 = c*h(i,2) + s*h(i+1,1) a2 = c*h(i+1,1) + s*h(i+1,2) a3 = c*h(i+1,1) - s*h(i,2) a4 = c*h(i+1,2) - s*h(i+1,1) c h(i,2) = c*a1 + s*a2 h(i+1,2) = c*a4 - s*a3 h(i+1,1) = c*a3 + s*a4 c c %----------------------------------------------------% c | Accumulate the rotation in the matrix Q; Q <- Q*G | c %----------------------------------------------------% c do 50 j = 1, min( i+jj, kplusp ) a1 = c*q(j,i) + s*q(j,i+1) q(j,i+1) = - s*q(j,i) + c*q(j,i+1) q(j,i) = a1 50 continue c 70 continue c end if c c %--------------------------% c | Update the block pointer | c %--------------------------% c istart = iend + 1 c c %------------------------------------------% c | Make sure that h(iend,1) is non-negative | c | If not then set h(iend,1) <-- -h(iend,1) | c | and negate the last column of Q. | c | We have effectively carried out a | c | similarity on transformation H | c %------------------------------------------% c if (h(iend,1) .lt. zero) then h(iend,1) = -h(iend,1) call sscal(kplusp, -one, q(1,iend), 1) end if c c %--------------------------------------------------------% c | Apply the same shift to the next block if there is any | c %--------------------------------------------------------% c if (iend .lt. kplusp) go to 20 c c %-----------------------------------------------------% c | Check if we can increase the the start of the block | c %-----------------------------------------------------% c do 80 i = itop, kplusp-1 if (h(i+1,1) .gt. zero) go to 90 itop = itop + 1 80 continue c c %-----------------------------------% c | Finished applying the jj-th shift | c %-----------------------------------% c 90 continue c c %------------------------------------------% c | All shifts have been applied. Check for | c | more possible deflation that might occur | c | after the last shift is applied. | c %------------------------------------------% c do 100 i = itop, kplusp-1 big = abs(h(i,2)) + abs(h(i+1,2)) if (h(i+1,1) .le. epsmch*big) then if (msglvl .gt. 0) then call ivout (logfil, 1, i, ndigit, & '_sapps: deflation at row/column no.') call svout (logfil, 1, h(i+1,1), ndigit, & '_sapps: the corresponding off diagonal element') end if h(i+1,1) = zero end if 100 continue c c %-------------------------------------------------% c | Compute the (kev+1)-st column of (V*Q) and | c | temporarily store the result in WORKD(N+1:2*N). | c | This is not necessary if h(kev+1,1) = 0. | c %-------------------------------------------------% c if ( h(kev+1,1) .gt. zero ) & call sgemv ('N', n, kplusp, one, v, ldv, & q(1,kev+1), 1, zero, workd(n+1), 1) c c %-------------------------------------------------------% c | Compute column 1 to kev of (V*Q) in backward order | c | taking advantage that Q is an upper triangular matrix | c | with lower bandwidth np. | c | Place results in v(:,kplusp-kev:kplusp) temporarily. | c %-------------------------------------------------------% c do 130 i = 1, kev call sgemv ('N', n, kplusp-i+1, one, v, ldv, & q(1,kev-i+1), 1, zero, workd, 1) call scopy (n, workd, 1, v(1,kplusp-i+1), 1) 130 continue c c %-------------------------------------------------% c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | c %-------------------------------------------------% c call slacpy ('All', n, kev, v(1,np+1), ldv, v, ldv) c c %--------------------------------------------% c | Copy the (kev+1)-st column of (V*Q) in the | c | appropriate place if h(kev+1,1) .ne. zero. | c %--------------------------------------------% c if ( h(kev+1,1) .gt. zero ) & call scopy (n, workd(n+1), 1, v(1,kev+1), 1) c c %-------------------------------------% c | Update the residual vector: | c | r <- sigmak*r + betak*v(:,kev+1) | c | where | c | sigmak = (e_{kev+p}'*Q)*e_{kev} | c | betak = e_{kev+1}'*H*e_{kev} | c %-------------------------------------% c call sscal (n, q(kplusp,kev), resid, 1) if (h(kev+1,1) .gt. zero) & call saxpy (n, h(kev+1,1), v(1,kev+1), 1, resid, 1) c if (msglvl .gt. 1) then call svout (logfil, 1, q(kplusp,kev), ndigit, & '_sapps: sigmak of the updated residual vector') call svout (logfil, 1, h(kev+1,1), ndigit, & '_sapps: betak of the updated residual vector') call svout (logfil, kev, h(1,2), ndigit, & '_sapps: updated main diagonal of H for next iteration') if (kev .gt. 1) then call svout (logfil, kev-1, h(2,1), ndigit, & '_sapps: updated sub diagonal of H for next iteration') end if end if c call second (t1) tsapps = tsapps + (t1 - t0) c 9000 continue return c c %---------------% c | End of ssapps | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/cneigh.f000644 001750 001750 00000017711 11266605602 022060 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: cneigh c c\Description: c Compute the eigenvalues of the current upper Hessenberg matrix c and the corresponding Ritz estimates given the current residual norm. c c\Usage: c call cneigh c ( RNORM, N, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, RWORK, IERR ) c c\Arguments c RNORM Real scalar. (INPUT) c Residual norm corresponding to the current upper Hessenberg c matrix H. c c N Integer. (INPUT) c Size of the matrix H. c c H Complex N by N array. (INPUT) c H contains the current upper Hessenberg matrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZ Complex array of length N. (OUTPUT) c On output, RITZ(1:N) contains the eigenvalues of H. c c BOUNDS Complex array of length N. (OUTPUT) c On output, BOUNDS contains the Ritz estimates associated with c the eigenvalues held in RITZ. This is equal to RNORM c times the last components of the eigenvectors corresponding c to the eigenvalues in RITZ. c c Q Complex N by N array. (WORKSPACE) c Workspace needed to store the eigenvectors of H. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Complex work array of length N**2 + 3*N. (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. This is needed to keep the full Schur form c of H and also in the calculation of the eigenvectors of H. c c RWORK Real work array of length N (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c IERR Integer. (OUTPUT) c Error exit flag from clahqr or ctrevc. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex c c\Routines called: c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c cmout ARPACK utility routine that prints matrices c cvout ARPACK utility routine that prints vectors. c svout ARPACK utility routine that prints vectors. c clacpy LAPACK matrix copy routine. c clahqr LAPACK routine to compute the Schur form of an c upper Hessenberg matrix. c claset LAPACK matrix initialization routine. c ctrevc LAPACK routine to compute the eigenvectors of a matrix c in upper triangular form c ccopy Level 1 BLAS that copies one vector to another. c csscal Level 1 BLAS that scales a complex vector by a real number. c scnrm2 Level 1 BLAS that computes the norm of a vector. c c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: neigh.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c None c c\EndLib c c----------------------------------------------------------------------- c subroutine cneigh (rnorm, n, h, ldh, ritz, bounds, & q, ldq, workl, rwork, ierr) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer ierr, n, ldh, ldq Real & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c Complex & bounds(n), h(ldh,n), q(ldq,n), ritz(n), & workl(n*(n+3)) Real & rwork(n) c c %------------% c | Parameters | c %------------% c Complex & one, zero Real & rone parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0), & rone = 1.0E+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c logical select(1) integer j, msglvl Complex & vl(1) Real & temp c c %----------------------% c | External Subroutines | c %----------------------% c external clacpy, clahqr, ctrevc, ccopy, & csscal, cmout, cvout, second c c %--------------------% c | External Functions | c %--------------------% c Real & scnrm2 external scnrm2 c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mceigh c if (msglvl .gt. 2) then call cmout (logfil, n, n, h, ldh, ndigit, & '_neigh: Entering upper Hessenberg matrix H ') end if c c %----------------------------------------------------------% c | 1. Compute the eigenvalues, the last components of the | c | corresponding Schur vectors and the full Schur form T | c | of the current upper Hessenberg matrix H. | c | clahqr returns the full Schur form of H | c | in WORKL(1:N**2), and the Schur vectors in q. | c %----------------------------------------------------------% c call clacpy ('All', n, n, h, ldh, workl, n) call claset ('All', n, n, zero, one, q, ldq) call clahqr (.true., .true., n, 1, n, workl, ldh, ritz, & 1, n, q, ldq, ierr) if (ierr .ne. 0) go to 9000 c call ccopy (n, q(n-1,1), ldq, bounds, 1) if (msglvl .gt. 1) then call cvout (logfil, n, bounds, ndigit, & '_neigh: last row of the Schur matrix for H') end if c c %----------------------------------------------------------% c | 2. Compute the eigenvectors of the full Schur form T and | c | apply the Schur vectors to get the corresponding | c | eigenvectors. | c %----------------------------------------------------------% c call ctrevc ('Right', 'Back', select, n, workl, n, vl, n, q, & ldq, n, n, workl(n*n+1), rwork, ierr) c if (ierr .ne. 0) go to 9000 c c %------------------------------------------------% c | Scale the returning eigenvectors so that their | c | Euclidean norms are all one. LAPACK subroutine | c | ctrevc returns each eigenvector normalized so | c | that the element of largest magnitude has | c | magnitude 1; here the magnitude of a complex | c | number (x,y) is taken to be |x| + |y|. | c %------------------------------------------------% c do 10 j=1, n temp = scnrm2( n, q(1,j), 1 ) call csscal ( n, rone / temp, q(1,j), 1 ) 10 continue c if (msglvl .gt. 1) then call ccopy(n, q(n,1), ldq, workl, 1) call cvout (logfil, n, workl, ndigit, & '_neigh: Last row of the eigenvector matrix for H') end if c c %----------------------------% c | Compute the Ritz estimates | c %----------------------------% c call ccopy(n, q(n,1), n, bounds, 1) call csscal(n, rnorm, bounds, 1) c if (msglvl .gt. 2) then call cvout (logfil, n, ritz, ndigit, & '_neigh: The eigenvalues of H') call cvout (logfil, n, bounds, ndigit, & '_neigh: Ritz estimates for the eigenvalues of H') end if c call second(t1) tceigh = tceigh + (t1 - t0) c 9000 continue return c c %---------------% c | End of cneigh | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/cstatn.f000644 001750 001750 00000002305 11266605602 022110 0ustar00geuzainegeuzaine000000 000000 c c\SCCS Information: @(#) c FILE: statn.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 c c %---------------------------------------------% c | Initialize statistic and timing information | c | for complex nonsymmetric Arnoldi code. | c %---------------------------------------------% subroutine cstatn c c %--------------------------------% c | See stat.doc for documentation | c %--------------------------------% c include 'stat.h' c %-----------------------% c | Executable Statements | c %-----------------------% nopx = 0 nbx = 0 nrorth = 0 nitref = 0 nrstrt = 0 tcaupd = 0.0E+0 tcaup2 = 0.0E+0 tcaitr = 0.0E+0 tceigh = 0.0E+0 tcgets = 0.0E+0 tcapps = 0.0E+0 tcconv = 0.0E+0 titref = 0.0E+0 tgetv0 = 0.0E+0 trvec = 0.0E+0 c %----------------------------------------------------% c | User time including reverse communication overhead | c %----------------------------------------------------% tmvopx = 0.0E+0 tmvbx = 0.0E+0 return c c %---------------% c | End of cstatn | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dsgets.f000644 001750 001750 00000016435 11266605602 022116 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dsgets c c\Description: c Given the eigenvalues of the symmetric tridiagonal matrix H, c computes the NP shifts AMU that are zeros of the polynomial of c degree NP which filters out components of the unwanted eigenvectors c corresponding to the AMU's based on some given criteria. c c NOTE: This is called even in the case of user specified shifts in c order to sort the eigenvalues, and error bounds of H for later use. c c\Usage: c call dsgets c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS, SHIFTS ) c c\Arguments c ISHIFT Integer. (INPUT) c Method for selecting the implicit shifts at each iteration. c ISHIFT = 0: user specified shifts c ISHIFT = 1: exact shift with respect to the matrix H. c c WHICH Character*2. (INPUT) c Shift selection criteria. c 'LM' -> KEV eigenvalues of largest magnitude are retained. c 'SM' -> KEV eigenvalues of smallest magnitude are retained. c 'LA' -> KEV eigenvalues of largest value are retained. c 'SA' -> KEV eigenvalues of smallest value are retained. c 'BE' -> KEV eigenvalues, half from each end of the spectrum. c If KEV is odd, compute one more from the high end. c c KEV Integer. (INPUT) c KEV+NP is the size of the matrix H. c c NP Integer. (INPUT) c Number of implicit shifts to be computed. c c RITZ Double precision array of length KEV+NP. (INPUT/OUTPUT) c On INPUT, RITZ contains the eigenvalues of H. c On OUTPUT, RITZ are sorted so that the unwanted eigenvalues c are in the first NP locations and the wanted part is in c the last KEV locations. When exact shifts are selected, the c unwanted part corresponds to the shifts to be applied. c c BOUNDS Double precision array of length KEV+NP. (INPUT/OUTPUT) c Error bounds corresponding to the ordering in RITZ. c c SHIFTS Double precision array of length NP. (INPUT/OUTPUT) c On INPUT: contains the user specified shifts if ISHIFT = 0. c On OUTPUT: contains the shifts sorted into decreasing order c of magnitude with respect to the Ritz estimates contained in c BOUNDS. If ISHIFT = 0, SHIFTS is not modified on exit. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c dsortr ARPACK utility sorting routine. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c dvout ARPACK utility routine that prints vectors. c dcopy Level 1 BLAS that copies one vector to another. c dswap Level 1 BLAS that swaps the contents of two vectors. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/93: Version ' 2.1' c c\SCCS Information: @(#) c FILE: sgets.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 c c\Remarks c c\EndLib c c----------------------------------------------------------------------- c subroutine dsgets ( ishift, which, kev, np, ritz, bounds, shifts ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which integer ishift, kev, np c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & bounds(kev+np), ritz(kev+np), shifts(np) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %---------------% c | Local Scalars | c %---------------% c integer kevd2, msglvl c c %----------------------% c | External Subroutines | c %----------------------% c external dswap, dcopy, dsortr, second c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic max, min c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = msgets c if (which .eq. 'BE') then c c %-----------------------------------------------------% c | Both ends of the spectrum are requested. | c | Sort the eigenvalues into algebraically increasing | c | order first then swap high end of the spectrum next | c | to low end in appropriate locations. | c | NOTE: when np < floor(kev/2) be careful not to swap | c | overlapping locations. | c %-----------------------------------------------------% c call dsortr ('LA', .true., kev+np, ritz, bounds) kevd2 = kev / 2 if ( kev .gt. 1 ) then call dswap ( min(kevd2,np), ritz, 1, & ritz( max(kevd2,np)+1 ), 1) call dswap ( min(kevd2,np), bounds, 1, & bounds( max(kevd2,np)+1 ), 1) end if c else c c %----------------------------------------------------% c | LM, SM, LA, SA case. | c | Sort the eigenvalues of H into the desired order | c | and apply the resulting order to BOUNDS. | c | The eigenvalues are sorted so that the wanted part | c | are always in the last KEV locations. | c %----------------------------------------------------% c call dsortr (which, .true., kev+np, ritz, bounds) end if c if (ishift .eq. 1 .and. np .gt. 0) then c c %-------------------------------------------------------% c | Sort the unwanted Ritz values used as shifts so that | c | the ones with largest Ritz estimates are first. | c | This will tend to minimize the effects of the | c | forward instability of the iteration when the shifts | c | are applied in subroutine dsapps. | c %-------------------------------------------------------% c call dsortr ('SM', .true., np, bounds, ritz) call dcopy (np, ritz, 1, shifts, 1) end if c call second (t1) tsgets = tsgets + (t1 - t0) c if (msglvl .gt. 0) then call ivout (logfil, 1, kev, ndigit, '_sgets: KEV is') call ivout (logfil, 1, np, ndigit, '_sgets: NP is') call dvout (logfil, kev+np, ritz, ndigit, & '_sgets: Eigenvalues of current H matrix') call dvout (logfil, kev+np, bounds, ndigit, & '_sgets: Associated Ritz estimates') end if c return c c %---------------% c | End of dsgets | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/second.f000644 001750 001750 00000001526 11266605602 022073 0ustar00geuzainegeuzaine000000 000000 SUBROUTINE SECOND( T ) * REAL T * * -- LAPACK auxiliary routine (preliminary version) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * July 26, 1991 * * Purpose * ======= * * SECOND returns the user time for a process in seconds. * This version gets the time from the system function ETIME. * * .. Local Scalars .. REAL T1 * .. * .. Local Arrays .. REAL TARRAY( 2 ) * .. * .. External Functions .. * REMOVED BY CHRISTOPHE * REAL ETIME * EXTERNAL ETIME * .. * .. Executable Statements .. * * REMOVED BY CHRISTOPHE * T1 = ETIME( TARRAY ) T1 = 0 T = TARRAY( 1 ) RETURN * * End of SECOND * END getdp-2.4.2-source/contrib/Arpack/snapps.f000644 001750 001750 00000055515 11266605602 022133 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: snapps c c\Description: c Given the Arnoldi factorization c c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, c c apply NP implicit shifts resulting in c c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q c c where Q is an orthogonal matrix which is the product of rotations c and reflections resulting from the NP bulge chage sweeps. c The updated Arnoldi factorization becomes: c c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. c c\Usage: c call snapps c ( N, KEV, NP, SHIFTR, SHIFTI, V, LDV, H, LDH, RESID, Q, LDQ, c WORKL, WORKD ) c c\Arguments c N Integer. (INPUT) c Problem size, i.e. size of matrix A. c c KEV Integer. (INPUT/OUTPUT) c KEV+NP is the size of the input matrix H. c KEV is the size of the updated matrix HNEW. KEV is only c updated on ouput when fewer than NP shifts are applied in c order to keep the conjugate pair together. c c NP Integer. (INPUT) c Number of implicit shifts to be applied. c c SHIFTR, Real array of length NP. (INPUT) c SHIFTI Real and imaginary part of the shifts to be applied. c Upon, entry to snapps, the shifts must be sorted so that the c conjugate pairs are in consecutive locations. c c V Real N by (KEV+NP) array. (INPUT/OUTPUT) c On INPUT, V contains the current KEV+NP Arnoldi vectors. c On OUTPUT, V contains the updated KEV Arnoldi vectors c in the first KEV columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Real (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) c On INPUT, H contains the current KEV+NP by KEV+NP upper c Hessenber matrix of the Arnoldi factorization. c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg c matrix in the KEV leading submatrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RESID Real array of length N. (INPUT/OUTPUT) c On INPUT, RESID contains the the residual vector r_{k+p}. c On OUTPUT, RESID is the update residual vector rnew_{k} c in the first KEV locations. c c Q Real KEV+NP by KEV+NP work array. (WORKSPACE) c Work array used to accumulate the rotations and reflections c during the bulge chase sweep. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Real work array of length (KEV+NP). (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c WORKD Real work array of length 2*N. (WORKSPACE) c Distributed array used in the application of the accumulated c orthogonal matrix Q. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c c\Routines called: c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c smout ARPACK utility routine that prints matrices. c svout ARPACK utility routine that prints vectors. c slabad LAPACK routine that computes machine constants. c slacpy LAPACK matrix copy routine. c slamch LAPACK routine that determines machine constants. c slanhs LAPACK routine that computes various norms of a matrix. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slarf LAPACK routine that applies Householder reflection to c a matrix. c slarfg LAPACK Householder reflection construction routine. c slartg LAPACK Givens rotation construction routine. c slaset LAPACK matrix initialization routine. c sgemv Level 2 BLAS routine for matrix vector multiplication. c saxpy Level 1 BLAS that computes a vector triad. c scopy Level 1 BLAS that copies one vector to another . c sscal Level 1 BLAS that scales a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.4' c c\SCCS Information: @(#) c FILE: napps.F SID: 2.4 DATE OF SID: 3/28/97 RELEASE: 2 c c\Remarks c 1. In this version, each shift is applied to all the sublocks of c the Hessenberg matrix H and not just to the submatrix that it c comes from. Deflation as in LAPACK routine slahqr (QR algorithm c for upper Hessenberg matrices ) is used. c The subdiagonals of H are enforced to be non-negative. c c\EndLib c c----------------------------------------------------------------------- c subroutine snapps & ( n, kev, np, shiftr, shifti, v, ldv, h, ldh, resid, q, ldq, & workl, workd ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer kev, ldh, ldq, ldv, n, np c c %-----------------% c | Array Arguments | c %-----------------% c Real & h(ldh,kev+np), resid(n), shifti(np), shiftr(np), & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c integer i, iend, ir, istart, j, jj, kplusp, msglvl, nr logical cconj, first Real & c, f, g, h11, h12, h21, h22, h32, ovfl, r, s, sigmai, & sigmar, smlnum, ulp, unfl, u(3), t, tau, tst1 save first, ovfl, smlnum, ulp, unfl c c %----------------------% c | External Subroutines | c %----------------------% c external saxpy, scopy, sscal, slacpy, slarfg, slarf, & slaset, slabad, second, slartg c c %--------------------% c | External Functions | c %--------------------% c Real & slamch, slanhs, slapy2 external slamch, slanhs, slapy2 c c %----------------------% c | Intrinsics Functions | c %----------------------% c intrinsic abs, max, min c c %----------------% c | Data statments | c %----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then c c %-----------------------------------------------% c | Set machine-dependent constants for the | c | stopping criterion. If norm(H) <= sqrt(OVFL), | c | overflow should not occur. | c | REFERENCE: LAPACK subroutine slahqr | c %-----------------------------------------------% c unfl = slamch( 'safe minimum' ) ovfl = one / unfl call slabad( unfl, ovfl ) ulp = slamch( 'precision' ) smlnum = unfl*( n / ulp ) first = .false. end if c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mnapps kplusp = kev + np c c %--------------------------------------------% c | Initialize Q to the identity to accumulate | c | the rotations and reflections | c %--------------------------------------------% c call slaset ('All', kplusp, kplusp, zero, one, q, ldq) c c %----------------------------------------------% c | Quick return if there are no shifts to apply | c %----------------------------------------------% c if (np .eq. 0) go to 9000 c c %----------------------------------------------% c | Chase the bulge with the application of each | c | implicit shift. Each shift is applied to the | c | whole matrix including each block. | c %----------------------------------------------% c cconj = .false. do 110 jj = 1, np sigmar = shiftr(jj) sigmai = shifti(jj) c if (msglvl .gt. 2 ) then call ivout (logfil, 1, jj, ndigit, & '_napps: shift number.') call svout (logfil, 1, sigmar, ndigit, & '_napps: The real part of the shift ') call svout (logfil, 1, sigmai, ndigit, & '_napps: The imaginary part of the shift ') end if c c %-------------------------------------------------% c | The following set of conditionals is necessary | c | in order that complex conjugate pairs of shifts | c | are applied together or not at all. | c %-------------------------------------------------% c if ( cconj ) then c c %-----------------------------------------% c | cconj = .true. means the previous shift | c | had non-zero imaginary part. | c %-----------------------------------------% c cconj = .false. go to 110 else if ( jj .lt. np .and. abs( sigmai ) .gt. zero ) then c c %------------------------------------% c | Start of a complex conjugate pair. | c %------------------------------------% c cconj = .true. else if ( jj .eq. np .and. abs( sigmai ) .gt. zero ) then c c %----------------------------------------------% c | The last shift has a nonzero imaginary part. | c | Don't apply it; thus the order of the | c | compressed H is order KEV+1 since only np-1 | c | were applied. | c %----------------------------------------------% c kev = kev + 1 go to 110 end if istart = 1 20 continue c c %--------------------------------------------------% c | if sigmai = 0 then | c | Apply the jj-th shift ... | c | else | c | Apply the jj-th and (jj+1)-th together ... | c | (Note that jj < np at this point in the code) | c | end | c | to the current block of H. The next do loop | c | determines the current block ; | c %--------------------------------------------------% c do 30 i = istart, kplusp-1 c c %----------------------------------------% c | Check for splitting and deflation. Use | c | a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine slahqr | c %----------------------------------------% c tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) if( tst1.eq.zero ) & tst1 = slanhs( '1', kplusp-jj+1, h, ldh, workl ) if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) then if (msglvl .gt. 0) then call ivout (logfil, 1, i, ndigit, & '_napps: matrix splitting at row/column no.') call ivout (logfil, 1, jj, ndigit, & '_napps: matrix splitting with shift number.') call svout (logfil, 1, h(i+1,i), ndigit, & '_napps: off diagonal element.') end if iend = i h(i+1,i) = zero go to 40 end if 30 continue iend = kplusp 40 continue c if (msglvl .gt. 2) then call ivout (logfil, 1, istart, ndigit, & '_napps: Start of current block ') call ivout (logfil, 1, iend, ndigit, & '_napps: End of current block ') end if c c %------------------------------------------------% c | No reason to apply a shift to block of order 1 | c %------------------------------------------------% c if ( istart .eq. iend ) go to 100 c c %------------------------------------------------------% c | If istart + 1 = iend then no reason to apply a | c | complex conjugate pair of shifts on a 2 by 2 matrix. | c %------------------------------------------------------% c if ( istart + 1 .eq. iend .and. abs( sigmai ) .gt. zero ) & go to 100 c h11 = h(istart,istart) h21 = h(istart+1,istart) if ( abs( sigmai ) .le. zero ) then c c %---------------------------------------------% c | Real-valued shift ==> apply single shift QR | c %---------------------------------------------% c f = h11 - sigmar g = h21 c do 80 i = istart, iend-1 c c %-----------------------------------------------------% c | Contruct the plane rotation G to zero out the bulge | c %-----------------------------------------------------% c call slartg (f, g, c, s, r) if (i .gt. istart) then c c %-------------------------------------------% c | The following ensures that h(1:iend-1,1), | c | the first iend-2 off diagonal of elements | c | H, remain non negative. | c %-------------------------------------------% c if (r .lt. zero) then r = -r c = -c s = -s end if h(i,i-1) = r h(i+1,i-1) = zero end if c c %---------------------------------------------% c | Apply rotation to the left of H; H <- G'*H | c %---------------------------------------------% c do 50 j = i, kplusp t = c*h(i,j) + s*h(i+1,j) h(i+1,j) = -s*h(i,j) + c*h(i+1,j) h(i,j) = t 50 continue c c %---------------------------------------------% c | Apply rotation to the right of H; H <- H*G | c %---------------------------------------------% c do 60 j = 1, min(i+2,iend) t = c*h(j,i) + s*h(j,i+1) h(j,i+1) = -s*h(j,i) + c*h(j,i+1) h(j,i) = t 60 continue c c %----------------------------------------------------% c | Accumulate the rotation in the matrix Q; Q <- Q*G | c %----------------------------------------------------% c do 70 j = 1, min( i+jj, kplusp ) t = c*q(j,i) + s*q(j,i+1) q(j,i+1) = - s*q(j,i) + c*q(j,i+1) q(j,i) = t 70 continue c c %---------------------------% c | Prepare for next rotation | c %---------------------------% c if (i .lt. iend-1) then f = h(i+1,i) g = h(i+2,i) end if 80 continue c c %-----------------------------------% c | Finished applying the real shift. | c %-----------------------------------% c else c c %----------------------------------------------------% c | Complex conjugate shifts ==> apply double shift QR | c %----------------------------------------------------% c h12 = h(istart,istart+1) h22 = h(istart+1,istart+1) h32 = h(istart+2,istart+1) c c %---------------------------------------------------------% c | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) | c %---------------------------------------------------------% c s = 2.0*sigmar t = slapy2 ( sigmar, sigmai ) u(1) = ( h11 * (h11 - s) + t * t ) / h21 + h12 u(2) = h11 + h22 - s u(3) = h32 c do 90 i = istart, iend-1 c nr = min ( 3, iend-i+1 ) c c %-----------------------------------------------------% c | Construct Householder reflector G to zero out u(1). | c | G is of the form I - tau*( 1 u )' * ( 1 u' ). | c %-----------------------------------------------------% c call slarfg ( nr, u(1), u(2), 1, tau ) c if (i .gt. istart) then h(i,i-1) = u(1) h(i+1,i-1) = zero if (i .lt. iend-1) h(i+2,i-1) = zero end if u(1) = one c c %--------------------------------------% c | Apply the reflector to the left of H | c %--------------------------------------% c call slarf ('Left', nr, kplusp-i+1, u, 1, tau, & h(i,i), ldh, workl) c c %---------------------------------------% c | Apply the reflector to the right of H | c %---------------------------------------% c ir = min ( i+3, iend ) call slarf ('Right', ir, nr, u, 1, tau, & h(1,i), ldh, workl) c c %-----------------------------------------------------% c | Accumulate the reflector in the matrix Q; Q <- Q*G | c %-----------------------------------------------------% c call slarf ('Right', kplusp, nr, u, 1, tau, & q(1,i), ldq, workl) c c %----------------------------% c | Prepare for next reflector | c %----------------------------% c if (i .lt. iend-1) then u(1) = h(i+1,i) u(2) = h(i+2,i) if (i .lt. iend-2) u(3) = h(i+3,i) end if c 90 continue c c %--------------------------------------------% c | Finished applying a complex pair of shifts | c | to the current block | c %--------------------------------------------% c end if c 100 continue c c %---------------------------------------------------------% c | Apply the same shift to the next block if there is any. | c %---------------------------------------------------------% c istart = iend + 1 if (iend .lt. kplusp) go to 20 c c %---------------------------------------------% c | Loop back to the top to get the next shift. | c %---------------------------------------------% c 110 continue c c %--------------------------------------------------% c | Perform a similarity transformation that makes | c | sure that H will have non negative sub diagonals | c %--------------------------------------------------% c do 120 j=1,kev if ( h(j+1,j) .lt. zero ) then call sscal( kplusp-j+1, -one, h(j+1,j), ldh ) call sscal( min(j+2, kplusp), -one, h(1,j+1), 1 ) call sscal( min(j+np+1,kplusp), -one, q(1,j+1), 1 ) end if 120 continue c do 130 i = 1, kev c c %--------------------------------------------% c | Final check for splitting and deflation. | c | Use a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine slahqr | c %--------------------------------------------% c tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) if( tst1.eq.zero ) & tst1 = slanhs( '1', kev, h, ldh, workl ) if( h( i+1,i ) .le. max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 130 continue c c %-------------------------------------------------% c | Compute the (kev+1)-st column of (V*Q) and | c | temporarily store the result in WORKD(N+1:2*N). | c | This is needed in the residual update since we | c | cannot GUARANTEE that the corresponding entry | c | of H would be zero as in exact arithmetic. | c %-------------------------------------------------% c if (h(kev+1,kev) .gt. zero) & call sgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, & workd(n+1), 1) c c %----------------------------------------------------------% c | Compute column 1 to kev of (V*Q) in backward order | c | taking advantage of the upper Hessenberg structure of Q. | c %----------------------------------------------------------% c do 140 i = 1, kev call sgemv ('N', n, kplusp-i+1, one, v, ldv, & q(1,kev-i+1), 1, zero, workd, 1) call scopy (n, workd, 1, v(1,kplusp-i+1), 1) 140 continue c c %-------------------------------------------------% c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | c %-------------------------------------------------% c call slacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv) c c %--------------------------------------------------------------% c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | c %--------------------------------------------------------------% c if (h(kev+1,kev) .gt. zero) & call scopy (n, workd(n+1), 1, v(1,kev+1), 1) c c %-------------------------------------% c | Update the residual vector: | c | r <- sigmak*r + betak*v(:,kev+1) | c | where | c | sigmak = (e_{kplusp}'*Q)*e_{kev} | c | betak = e_{kev+1}'*H*e_{kev} | c %-------------------------------------% c call sscal (n, q(kplusp,kev), resid, 1) if (h(kev+1,kev) .gt. zero) & call saxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) c if (msglvl .gt. 1) then call svout (logfil, 1, q(kplusp,kev), ndigit, & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') call svout (logfil, 1, h(kev+1,kev), ndigit, & '_napps: betak = e_{kev+1}^T*H*e_{kev}') call ivout (logfil, 1, kev, ndigit, & '_napps: Order of the final Hessenberg matrix ') if (msglvl .gt. 2) then call smout (logfil, kev, kev, h, ldh, ndigit, & '_napps: updated Hessenberg matrix H for next iteration') end if c end if c 9000 continue call second (t1) tnapps = tnapps + (t1 - t0) c return c c %---------------% c | End of snapps | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/snaup2.f000644 001750 001750 00000075145 11266605602 022040 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: snaup2 c c\Description: c Intermediate level interface called by snaupd. c c\Usage: c call snaup2 c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, c ISHIFT, MXITER, V, LDV, H, LDH, RITZR, RITZI, BOUNDS, c Q, LDQ, WORKL, IPNTR, WORKD, INFO ) c c\Arguments c c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in snaupd. c MODE, ISHIFT, MXITER: see the definition of IPARAM in snaupd. c c NP Integer. (INPUT/OUTPUT) c Contains the number of implicit shifts to apply during c each Arnoldi iteration. c If ISHIFT=1, NP is adjusted dynamically at each iteration c to accelerate convergence and prevent stagnation. c This is also roughly equal to the number of matrix-vector c products (involving the operator OP) per Arnoldi iteration. c The logic for adjusting is contained within the current c subroutine. c If ISHIFT=0, NP is the number of shifts the user needs c to provide via reverse comunication. 0 < NP < NCV-NEV. c NP may be less than NCV-NEV for two reasons. The first, is c to keep complex conjugate pairs of "wanted" Ritz values c together. The second, is that a leading block of the current c upper Hessenberg matrix has split off and contains "unwanted" c Ritz values. c Upon termination of the IRA iteration, NP contains the number c of "converged" wanted Ritz values. c c IUPD Integer. (INPUT) c IUPD .EQ. 0: use explicit restart instead implicit update. c IUPD .NE. 0: use implicit update. c c V Real N by (NEV+NP) array. (INPUT/OUTPUT) c The Arnoldi basis vectors are returned in the first NEV c columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Real (NEV+NP) by (NEV+NP) array. (OUTPUT) c H is used to store the generated upper Hessenberg matrix c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZR, Real arrays of length NEV+NP. (OUTPUT) c RITZI RITZR(1:NEV) (resp. RITZI(1:NEV)) contains the real (resp. c imaginary) part of the computed Ritz values of OP. c c BOUNDS Real array of length NEV+NP. (OUTPUT) c BOUNDS(1:NEV) contain the error bounds corresponding to c the computed Ritz values. c c Q Real (NEV+NP) by (NEV+NP) array. (WORKSPACE) c Private (replicated) work array used to accumulate the c rotation in the shift application step. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Real work array of length at least c (NEV+NP)**2 + 3*(NEV+NP). (INPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. It is used in shifts calculation, shifts c application and convergence checking. c c On exit, the last 3*(NEV+NP) locations of WORKL contain c the Ritz values (real,imaginary) and associated Ritz c estimates of the current Hessenberg matrix. They are c listed in the same order as returned from sneigh. c c If ISHIFT .EQ. O and IDO .EQ. 3, the first 2*NP locations c of WORKL are used in reverse communication to hold the user c supplied shifts. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORKD for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Real work array of length 3*N. (WORKSPACE) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration !!!!!!!!!! c See Data Distribution Note in DNAUPD. c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal return. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. c NP returns the number of converged Ritz values. c = 2: No shifts could be applied. c = -8: Error return from LAPACK eigenvalue calculation; c This should never happen. c = -9: Starting vector is zero. c = -9999: Could not build an Arnoldi factorization. c Size that was built in returned in NP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c sgetv0 ARPACK initial vector generation routine. c snaitr ARPACK Arnoldi factorization routine. c snapps ARPACK application of implicit shifts routine. c snconv ARPACK convergence of Ritz values routine. c sneigh ARPACK compute Ritz values and error bounds routine. c sngets ARPACK reorder Ritz values and error bounds routine. c ssortc ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c smout ARPACK utility routine that prints matrices c svout ARPACK utility routine that prints vectors. c slamch LAPACK routine that determines machine constants. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c scopy Level 1 BLAS that copies one vector to another . c sdot Level 1 BLAS that computes the scalar product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c sswap Level 1 BLAS that swaps two vectors. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: naup2.F SID: 2.8 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c subroutine snaup2 & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, h, ldh, ritzr, ritzi, bounds, & q, ldq, workl, ipntr, workd, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, & n, nev, np Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(13) Real & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), resid(n), & ritzi(nev+np), ritzr(nev+np), v(ldv,nev+np), & workd(3*n), workl( (nev+np)*(nev+np+3) ) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %---------------% c | Local Scalars | c %---------------% c character wprime*2 logical cnorm , getv0, initv, update, ushift integer ierr , iter , j , kplusp, msglvl, nconv, & nevbef, nev0 , np0 , nptemp, numcnv Real & rnorm , temp , eps23 save cnorm , getv0, initv, update, ushift, & rnorm , iter , eps23, kplusp, msglvl, nconv , & nevbef, nev0 , np0 , numcnv c c %-----------------------% c | Local array arguments | c %-----------------------% c integer kp(4) c c %----------------------% c | External Subroutines | c %----------------------% c external scopy , sgetv0, snaitr, snconv, sneigh, & sngets, snapps, svout , ivout , second c c %--------------------% c | External Functions | c %--------------------% c Real & sdot, snrm2, slapy2, slamch external sdot, snrm2, slapy2, slamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic min, max, abs, sqrt c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c call second (t0) c msglvl = mnaup2 c c %-------------------------------------% c | Get the machine dependent constant. | c %-------------------------------------% c eps23 = slamch('Epsilon-Machine') eps23 = eps23**(2.0E+0 / 3.0E+0) c nev0 = nev np0 = np c c %-------------------------------------% c | kplusp is the bound on the largest | c | Lanczos factorization built. | c | nconv is the current number of | c | "converged" eigenvlues. | c | iter is the counter on the current | c | iteration step. | c %-------------------------------------% c kplusp = nev + np nconv = 0 iter = 0 c c %---------------------------------------% c | Set flags for computing the first NEV | c | steps of the Arnoldi factorization. | c %---------------------------------------% c getv0 = .true. update = .false. ushift = .false. cnorm = .false. c if (info .ne. 0) then c c %--------------------------------------------% c | User provides the initial residual vector. | c %--------------------------------------------% c initv = .true. info = 0 else initv = .false. end if end if c c %---------------------------------------------% c | Get a possibly random starting vector and | c | force it into the range of the operator OP. | c %---------------------------------------------% c 10 continue c if (getv0) then call sgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, & ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (rnorm .eq. zero) then c c %-----------------------------------------% c | The initial vector is zero. Error exit. | c %-----------------------------------------% c info = -9 go to 1100 end if getv0 = .false. ido = 0 end if c c %-----------------------------------% c | Back from reverse communication : | c | continue with update step | c %-----------------------------------% c if (update) go to 20 c c %-------------------------------------------% c | Back from computing user specified shifts | c %-------------------------------------------% c if (ushift) go to 50 c c %-------------------------------------% c | Back from computing residual norm | c | at the end of the current iteration | c %-------------------------------------% c if (cnorm) go to 100 c c %----------------------------------------------------------% c | Compute the first NEV steps of the Arnoldi factorization | c %----------------------------------------------------------% c call snaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, & h, ldh, ipntr, workd, info) c c %---------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP and possibly B | c %---------------------------------------------------% c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then np = info mxiter = iter info = -9999 go to 1200 end if c c %--------------------------------------------------------------% c | | c | M A I N ARNOLDI I T E R A T I O N L O O P | c | Each iteration implicitly restarts the Arnoldi | c | factorization in place. | c | | c %--------------------------------------------------------------% c 1000 continue c iter = iter + 1 c if (msglvl .gt. 0) then call ivout (logfil, 1, iter, ndigit, & '_naup2: **** Start of major iteration number ****') end if c c %-----------------------------------------------------------% c | Compute NP additional steps of the Arnoldi factorization. | c | Adjust NP since NEV might have been updated by last call | c | to the shift application routine snapps. | c %-----------------------------------------------------------% c np = kplusp - nev c if (msglvl .gt. 1) then call ivout (logfil, 1, nev, ndigit, & '_naup2: The length of the current Arnoldi factorization') call ivout (logfil, 1, np, ndigit, & '_naup2: Extend the Arnoldi factorization by') end if c c %-----------------------------------------------------------% c | Compute NP additional steps of the Arnoldi factorization. | c %-----------------------------------------------------------% c ido = 0 20 continue update = .true. c call snaitr (ido , bmat, n , nev, np , mode , resid, & rnorm, v , ldv, h , ldh, ipntr, workd, & info) c c %---------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP and possibly B | c %---------------------------------------------------% c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then np = info mxiter = iter info = -9999 go to 1200 end if update = .false. c if (msglvl .gt. 1) then call svout (logfil, 1, rnorm, ndigit, & '_naup2: Corresponding B-norm of the residual') end if c c %--------------------------------------------------------% c | Compute the eigenvalues and corresponding error bounds | c | of the current upper Hessenberg matrix. | c %--------------------------------------------------------% c call sneigh (rnorm, kplusp, h, ldh, ritzr, ritzi, bounds, & q, ldq, workl, ierr) c if (ierr .ne. 0) then info = -8 go to 1200 end if c c %----------------------------------------------------% c | Make a copy of eigenvalues and corresponding error | c | bounds obtained from sneigh. | c %----------------------------------------------------% c call scopy(kplusp, ritzr, 1, workl(kplusp**2+1), 1) call scopy(kplusp, ritzi, 1, workl(kplusp**2+kplusp+1), 1) call scopy(kplusp, bounds, 1, workl(kplusp**2+2*kplusp+1), 1) c c %---------------------------------------------------% c | Select the wanted Ritz values and their bounds | c | to be used in the convergence test. | c | The wanted part of the spectrum and corresponding | c | error bounds are in the last NEV loc. of RITZR, | c | RITZI and BOUNDS respectively. The variables NEV | c | and NP may be updated if the NEV-th wanted Ritz | c | value has a non zero imaginary part. In this case | c | NEV is increased by one and NP decreased by one. | c | NOTE: The last two arguments of sngets are no | c | longer used as of version 2.1. | c %---------------------------------------------------% c nev = nev0 np = np0 numcnv = nev call sngets (ishift, which, nev, np, ritzr, ritzi, & bounds, workl, workl(np+1)) if (nev .eq. nev0+1) numcnv = nev0+1 c c %-------------------% c | Convergence test. | c %-------------------% c call scopy (nev, bounds(np+1), 1, workl(2*np+1), 1) call snconv (nev, ritzr(np+1), ritzi(np+1), workl(2*np+1), & tol, nconv) c if (msglvl .gt. 2) then kp(1) = nev kp(2) = np kp(3) = numcnv kp(4) = nconv call ivout (logfil, 4, kp, ndigit, & '_naup2: NEV, NP, NUMCNV, NCONV are') call svout (logfil, kplusp, ritzr, ndigit, & '_naup2: Real part of the eigenvalues of H') call svout (logfil, kplusp, ritzi, ndigit, & '_naup2: Imaginary part of the eigenvalues of H') call svout (logfil, kplusp, bounds, ndigit, & '_naup2: Ritz estimates of the current NCV Ritz values') end if c c %---------------------------------------------------------% c | Count the number of unwanted Ritz values that have zero | c | Ritz estimates. If any Ritz estimates are equal to zero | c | then a leading block of H of order equal to at least | c | the number of Ritz values with zero Ritz estimates has | c | split off. None of these Ritz values may be removed by | c | shifting. Decrease NP the number of shifts to apply. If | c | no shifts may be applied, then prepare to exit | c %---------------------------------------------------------% c nptemp = np do 30 j=1, nptemp if (bounds(j) .eq. zero) then np = np - 1 nev = nev + 1 end if 30 continue c if ( (nconv .ge. numcnv) .or. & (iter .gt. mxiter) .or. & (np .eq. 0) ) then c if (msglvl .gt. 4) then call svout(logfil, kplusp, workl(kplusp**2+1), ndigit, & '_naup2: Real part of the eig computed by _neigh:') call svout(logfil, kplusp, workl(kplusp**2+kplusp+1), & ndigit, & '_naup2: Imag part of the eig computed by _neigh:') call svout(logfil, kplusp, workl(kplusp**2+kplusp*2+1), & ndigit, & '_naup2: Ritz eistmates computed by _neigh:') end if c c %------------------------------------------------% c | Prepare to exit. Put the converged Ritz values | c | and corresponding bounds in RITZ(1:NCONV) and | c | BOUNDS(1:NCONV) respectively. Then sort. Be | c | careful when NCONV > NP | c %------------------------------------------------% c c %------------------------------------------% c | Use h( 3,1 ) as storage to communicate | c | rnorm to _neupd if needed | c %------------------------------------------% h(3,1) = rnorm c c %----------------------------------------------% c | To be consistent with sngets, we first do a | c | pre-processing sort in order to keep complex | c | conjugate pairs together. This is similar | c | to the pre-processing sort used in sngets | c | except that the sort is done in the opposite | c | order. | c %----------------------------------------------% c if (which .eq. 'LM') wprime = 'SR' if (which .eq. 'SM') wprime = 'LR' if (which .eq. 'LR') wprime = 'SM' if (which .eq. 'SR') wprime = 'LM' if (which .eq. 'LI') wprime = 'SM' if (which .eq. 'SI') wprime = 'LM' c call ssortc (wprime, .true., kplusp, ritzr, ritzi, bounds) c c %----------------------------------------------% c | Now sort Ritz values so that converged Ritz | c | values appear within the first NEV locations | c | of ritzr, ritzi and bounds, and the most | c | desired one appears at the front. | c %----------------------------------------------% c if (which .eq. 'LM') wprime = 'SM' if (which .eq. 'SM') wprime = 'LM' if (which .eq. 'LR') wprime = 'SR' if (which .eq. 'SR') wprime = 'LR' if (which .eq. 'LI') wprime = 'SI' if (which .eq. 'SI') wprime = 'LI' c call ssortc(wprime, .true., kplusp, ritzr, ritzi, bounds) c c %--------------------------------------------------% c | Scale the Ritz estimate of each Ritz value | c | by 1 / max(eps23,magnitude of the Ritz value). | c %--------------------------------------------------% c do 35 j = 1, numcnv temp = max(eps23,slapy2(ritzr(j), & ritzi(j))) bounds(j) = bounds(j)/temp 35 continue c c %----------------------------------------------------% c | Sort the Ritz values according to the scaled Ritz | c | esitmates. This will push all the converged ones | c | towards the front of ritzr, ritzi, bounds | c | (in the case when NCONV < NEV.) | c %----------------------------------------------------% c wprime = 'LR' call ssortc(wprime, .true., numcnv, bounds, ritzr, ritzi) c c %----------------------------------------------% c | Scale the Ritz estimate back to its original | c | value. | c %----------------------------------------------% c do 40 j = 1, numcnv temp = max(eps23, slapy2(ritzr(j), & ritzi(j))) bounds(j) = bounds(j)*temp 40 continue c c %------------------------------------------------% c | Sort the converged Ritz values again so that | c | the "threshold" value appears at the front of | c | ritzr, ritzi and bound. | c %------------------------------------------------% c call ssortc(which, .true., nconv, ritzr, ritzi, bounds) c if (msglvl .gt. 1) then call svout (logfil, kplusp, ritzr, ndigit, & '_naup2: Sorted real part of the eigenvalues') call svout (logfil, kplusp, ritzi, ndigit, & '_naup2: Sorted imaginary part of the eigenvalues') call svout (logfil, kplusp, bounds, ndigit, & '_naup2: Sorted ritz estimates.') end if c c %------------------------------------% c | Max iterations have been exceeded. | c %------------------------------------% c if (iter .gt. mxiter .and. nconv .lt. numcnv) info = 1 c c %---------------------% c | No shifts to apply. | c %---------------------% c if (np .eq. 0 .and. nconv .lt. numcnv) info = 2 c np = nconv go to 1100 c else if ( (nconv .lt. numcnv) .and. (ishift .eq. 1) ) then c c %-------------------------------------------------% c | Do not have all the requested eigenvalues yet. | c | To prevent possible stagnation, adjust the size | c | of NEV. | c %-------------------------------------------------% c nevbef = nev nev = nev + min(nconv, np/2) if (nev .eq. 1 .and. kplusp .ge. 6) then nev = kplusp / 2 else if (nev .eq. 1 .and. kplusp .gt. 3) then nev = 2 end if np = kplusp - nev c c %---------------------------------------% c | If the size of NEV was just increased | c | resort the eigenvalues. | c %---------------------------------------% c if (nevbef .lt. nev) & call sngets (ishift, which, nev, np, ritzr, ritzi, & bounds, workl, workl(np+1)) c end if c if (msglvl .gt. 0) then call ivout (logfil, 1, nconv, ndigit, & '_naup2: no. of "converged" Ritz values at this iter.') if (msglvl .gt. 1) then kp(1) = nev kp(2) = np call ivout (logfil, 2, kp, ndigit, & '_naup2: NEV and NP are') call svout (logfil, nev, ritzr(np+1), ndigit, & '_naup2: "wanted" Ritz values -- real part') call svout (logfil, nev, ritzi(np+1), ndigit, & '_naup2: "wanted" Ritz values -- imag part') call svout (logfil, nev, bounds(np+1), ndigit, & '_naup2: Ritz estimates of the "wanted" values ') end if end if c if (ishift .eq. 0) then c c %-------------------------------------------------------% c | User specified shifts: reverse comminucation to | c | compute the shifts. They are returned in the first | c | 2*NP locations of WORKL. | c %-------------------------------------------------------% c ushift = .true. ido = 3 go to 9000 end if c 50 continue c c %------------------------------------% c | Back from reverse communication; | c | User specified shifts are returned | c | in WORKL(1:2*NP) | c %------------------------------------% c ushift = .false. c if ( ishift .eq. 0 ) then c c %----------------------------------% c | Move the NP shifts from WORKL to | c | RITZR, RITZI to free up WORKL | c | for non-exact shift case. | c %----------------------------------% c call scopy (np, workl, 1, ritzr, 1) call scopy (np, workl(np+1), 1, ritzi, 1) end if c if (msglvl .gt. 2) then call ivout (logfil, 1, np, ndigit, & '_naup2: The number of shifts to apply ') call svout (logfil, np, ritzr, ndigit, & '_naup2: Real part of the shifts') call svout (logfil, np, ritzi, ndigit, & '_naup2: Imaginary part of the shifts') if ( ishift .eq. 1 ) & call svout (logfil, np, bounds, ndigit, & '_naup2: Ritz estimates of the shifts') end if c c %---------------------------------------------------------% c | Apply the NP implicit shifts by QR bulge chasing. | c | Each shift is applied to the whole upper Hessenberg | c | matrix H. | c | The first 2*N locations of WORKD are used as workspace. | c %---------------------------------------------------------% c call snapps (n, nev, np, ritzr, ritzi, v, ldv, & h, ldh, resid, q, ldq, workl, workd) c c %---------------------------------------------% c | Compute the B-norm of the updated residual. | c | Keep B*RESID in WORKD(1:N) to be used in | c | the first step of the next call to snaitr. | c %---------------------------------------------% c cnorm = .true. call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call scopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 c c %----------------------------------% c | Exit in order to compute B*RESID | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd, 1) end if c 100 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(1:N) := B*RESID | c %----------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then rnorm = sdot (n, resid, 1, workd, 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = snrm2(n, resid, 1) end if cnorm = .false. c if (msglvl .gt. 2) then call svout (logfil, 1, rnorm, ndigit, & '_naup2: B-norm of residual for compressed factorization') call smout (logfil, nev, nev, h, ldh, ndigit, & '_naup2: Compressed upper Hessenberg matrix H') end if c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 1100 continue c mxiter = iter nev = numcnv c 1200 continue ido = 99 c c %------------% c | Error Exit | c %------------% c call second (t1) tnaup2 = t1 - t0 c 9000 continue c c %---------------% c | End of snaup2 | c %---------------% c return end getdp-2.4.2-source/contrib/Arpack/dmout.f000644 001750 001750 00000012657 11266605602 021757 0ustar00geuzainegeuzaine000000 000000 *----------------------------------------------------------------------- * Routine: DMOUT * * Purpose: Real matrix output routine. * * Usage: CALL DMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) * * Arguments * M - Number of rows of A. (Input) * N - Number of columns of A. (Input) * A - Real M by N matrix to be printed. (Input) * LDA - Leading dimension of A exactly as specified in the * dimension statement of the calling program. (Input) * IFMT - Format to be used in printing matrix A. (Input) * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) * If IDIGIT .LT. 0, printing is done with 72 columns. * If IDIGIT .GT. 0, printing is done with 132 columns. * *----------------------------------------------------------------------- * SUBROUTINE DMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) * ... * ... SPECIFICATIONS FOR ARGUMENTS * ... * ... SPECIFICATIONS FOR LOCAL VARIABLES * .. Scalar Arguments .. CHARACTER*( * ) IFMT INTEGER IDIGIT, LDA, LOUT, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * .. Local Scalars .. CHARACTER*80 LINE INTEGER I, J, K1, K2, LLL, NDIGIT * .. * .. Local Arrays .. CHARACTER ICOL( 3 ) * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN, MIN0 * .. * .. Data statements .. DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', $ 'l' / * .. * .. Executable Statements .. * ... * ... FIRST EXECUTABLE STATEMENT * LLL = MIN( LEN( IFMT ), 80 ) DO 10 I = 1, LLL LINE( I: I ) = '-' 10 CONTINUE * DO 20 I = LLL + 1, 80 LINE( I: I ) = ' ' 20 CONTINUE * WRITE( LOUT, FMT = 9999 )IFMT, LINE( 1: LLL ) 9999 FORMAT( / 1X, A, / 1X, A ) * IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) $ RETURN NDIGIT = IDIGIT IF( IDIGIT.EQ.0 ) $ NDIGIT = 4 * *======================================================================= * CODE FOR OUTPUT USING 72 COLUMNS FORMAT *======================================================================= * IF( IDIGIT.LT.0 ) THEN NDIGIT = -IDIGIT IF( NDIGIT.LE.4 ) THEN DO 40 K1 = 1, N, 5 K2 = MIN0( N, K1+4 ) WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 ) DO 30 I = 1, M WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 ) 30 CONTINUE 40 CONTINUE * ELSE IF( NDIGIT.LE.6 ) THEN DO 60 K1 = 1, N, 4 K2 = MIN0( N, K1+3 ) WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 ) DO 50 I = 1, M WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 ) 50 CONTINUE 60 CONTINUE * ELSE IF( NDIGIT.LE.10 ) THEN DO 80 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 ) DO 70 I = 1, M WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 ) 70 CONTINUE 80 CONTINUE * ELSE DO 100 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 ) DO 90 I = 1, M WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 ) 90 CONTINUE 100 CONTINUE END IF * *======================================================================= * CODE FOR OUTPUT USING 132 COLUMNS FORMAT *======================================================================= * ELSE IF( NDIGIT.LE.4 ) THEN DO 120 K1 = 1, N, 10 K2 = MIN0( N, K1+9 ) WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 ) DO 110 I = 1, M WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 ) 110 CONTINUE 120 CONTINUE * ELSE IF( NDIGIT.LE.6 ) THEN DO 140 K1 = 1, N, 8 K2 = MIN0( N, K1+7 ) WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 ) DO 130 I = 1, M WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 ) 130 CONTINUE 140 CONTINUE * ELSE IF( NDIGIT.LE.10 ) THEN DO 160 K1 = 1, N, 6 K2 = MIN0( N, K1+5 ) WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 ) DO 150 I = 1, M WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 ) 150 CONTINUE 160 CONTINUE * ELSE DO 180 K1 = 1, N, 5 K2 = MIN0( N, K1+4 ) WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 ) DO 170 I = 1, M WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 ) 170 CONTINUE 180 CONTINUE END IF END IF WRITE( LOUT, FMT = 9990 ) * 9998 FORMAT( 10X, 10( 4X, 3A1, I4, 1X ) ) 9997 FORMAT( 10X, 8( 5X, 3A1, I4, 2X ) ) 9996 FORMAT( 10X, 6( 7X, 3A1, I4, 4X ) ) 9995 FORMAT( 10X, 5( 9X, 3A1, I4, 6X ) ) 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 10D12.3 ) 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 8D14.5 ) 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 6D18.9 ) 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 5D22.13 ) 9990 FORMAT( 1X, ' ' ) * RETURN END getdp-2.4.2-source/contrib/Arpack/sstqrb.f000644 001750 001750 00000040464 11266605602 022142 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: sstqrb c c\Description: c Computes all eigenvalues and the last component of the eigenvectors c of a symmetric tridiagonal matrix using the implicit QL or QR method. c c This is mostly a modification of the LAPACK routine ssteqr. c See Remarks. c c\Usage: c call sstqrb c ( N, D, E, Z, WORK, INFO ) c c\Arguments c N Integer. (INPUT) c The number of rows and columns in the matrix. N >= 0. c c D Real array, dimension (N). (INPUT/OUTPUT) c On entry, D contains the diagonal elements of the c tridiagonal matrix. c On exit, D contains the eigenvalues, in ascending order. c If an error exit is made, the eigenvalues are correct c for indices 1,2,...,INFO-1, but they are unordered and c may not be the smallest eigenvalues of the matrix. c c E Real array, dimension (N-1). (INPUT/OUTPUT) c On entry, E contains the subdiagonal elements of the c tridiagonal matrix in positions 1 through N-1. c On exit, E has been destroyed. c c Z Real array, dimension (N). (OUTPUT) c On exit, Z contains the last row of the orthonormal c eigenvector matrix of the symmetric tridiagonal matrix. c If an error exit is made, Z contains the last row of the c eigenvector matrix associated with the stored eigenvalues. c c WORK Real array, dimension (max(1,2*N-2)). (WORKSPACE) c Workspace used in accumulating the transformation for c computing the last components of the eigenvectors. c c INFO Integer. (OUTPUT) c = 0: normal return. c < 0: if INFO = -i, the i-th argument had an illegal value. c > 0: if INFO = +i, the i-th eigenvalue has not converged c after a total of 30*N iterations. c c\Remarks c 1. None. c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c saxpy Level 1 BLAS that computes a vector triad. c scopy Level 1 BLAS that copies one vector to another. c sswap Level 1 BLAS that swaps the contents of two vectors. c lsame LAPACK character comparison routine. c slae2 LAPACK routine that computes the eigenvalues of a 2-by-2 c symmetric matrix. c slaev2 LAPACK routine that eigendecomposition of a 2-by-2 symmetric c matrix. c slamch LAPACK routine that determines machine constants. c slanst LAPACK routine that computes the norm of a matrix. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slartg LAPACK Givens rotation construction routine. c slascl LAPACK routine for careful scaling of a matrix. c slaset LAPACK matrix initialization routine. c slasr LAPACK routine that applies an orthogonal transformation to c a matrix. c slasrt LAPACK sorting routine. c ssteqr LAPACK routine that computes eigenvalues and eigenvectors c of a symmetric tridiagonal matrix. c xerbla LAPACK error handler routine. c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: stqrb.F SID: 2.5 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c 1. Starting with version 2.5, this routine is a modified version c of LAPACK version 2.0 subroutine SSTEQR. No lines are deleted, c only commeted out and new lines inserted. c All lines commented out have "c$$$" at the beginning. c Note that the LAPACK version 1.0 subroutine SSTEQR contained c bugs. c c\EndLib c c----------------------------------------------------------------------- c subroutine sstqrb ( n, d, e, z, work, info ) c c %------------------% c | Scalar Arguments | c %------------------% c integer info, n c c %-----------------% c | Array Arguments | c %-----------------% c Real & d( n ), e( n-1 ), z( n ), work( 2*n-2 ) c c .. parameters .. Real & zero, one, two, three parameter ( zero = 0.0E+0, one = 1.0E+0, & two = 2.0E+0, three = 3.0E+0 ) integer maxit parameter ( maxit = 30 ) c .. c .. local scalars .. integer i, icompz, ii, iscale, j, jtot, k, l, l1, lend, & lendm1, lendp1, lendsv, lm1, lsv, m, mm, mm1, & nm1, nmaxit Real & anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, & s, safmax, safmin, ssfmax, ssfmin, tst c .. c .. external functions .. logical lsame Real & slamch, slanst, slapy2 external lsame, slamch, slanst, slapy2 c .. c .. external subroutines .. external slae2, slaev2, slartg, slascl, slaset, slasr, & slasrt, sswap, xerbla c .. c .. intrinsic functions .. intrinsic abs, max, sign, sqrt c .. c .. executable statements .. c c test the input parameters. c info = 0 c c$$$ IF( LSAME( COMPZ, 'N' ) ) THEN c$$$ ICOMPZ = 0 c$$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN c$$$ ICOMPZ = 1 c$$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN c$$$ ICOMPZ = 2 c$$$ ELSE c$$$ ICOMPZ = -1 c$$$ END IF c$$$ IF( ICOMPZ.LT.0 ) THEN c$$$ INFO = -1 c$$$ ELSE IF( N.LT.0 ) THEN c$$$ INFO = -2 c$$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, c$$$ $ N ) ) ) THEN c$$$ INFO = -6 c$$$ END IF c$$$ IF( INFO.NE.0 ) THEN c$$$ CALL XERBLA( 'SSTEQR', -INFO ) c$$$ RETURN c$$$ END IF c c *** New starting with version 2.5 *** c icompz = 2 c ************************************* c c quick return if possible c if( n.eq.0 ) $ return c if( n.eq.1 ) then if( icompz.eq.2 ) z( 1 ) = one return end if c c determine the unit roundoff and over/underflow thresholds. c eps = slamch( 'e' ) eps2 = eps**2 safmin = slamch( 's' ) safmax = one / safmin ssfmax = sqrt( safmax ) / three ssfmin = sqrt( safmin ) / eps2 c c compute the eigenvalues and eigenvectors of the tridiagonal c matrix. c c$$ if( icompz.eq.2 ) c$$$ $ call slaset( 'full', n, n, zero, one, z, ldz ) c c *** New starting with version 2.5 *** c if ( icompz .eq. 2 ) then do 5 j = 1, n-1 z(j) = zero 5 continue z( n ) = one end if c ************************************* c nmaxit = n*maxit jtot = 0 c c determine where the matrix splits and choose ql or qr iteration c for each block, according to whether top or bottom diagonal c element is smaller. c l1 = 1 nm1 = n - 1 c 10 continue if( l1.gt.n ) $ go to 160 if( l1.gt.1 ) $ e( l1-1 ) = zero if( l1.le.nm1 ) then do 20 m = l1, nm1 tst = abs( e( m ) ) if( tst.eq.zero ) $ go to 30 if( tst.le.( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+ $ 1 ) ) ) )*eps ) then e( m ) = zero go to 30 end if 20 continue end if m = n c 30 continue l = l1 lsv = l lend = m lendsv = lend l1 = m + 1 if( lend.eq.l ) $ go to 10 c c scale submatrix in rows and columns l to lend c anorm = slanst( 'i', lend-l+1, d( l ), e( l ) ) iscale = 0 if( anorm.eq.zero ) $ go to 10 if( anorm.gt.ssfmax ) then iscale = 1 call slascl( 'g', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n, $ info ) call slascl( 'g', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n, $ info ) else if( anorm.lt.ssfmin ) then iscale = 2 call slascl( 'g', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n, $ info ) call slascl( 'g', 0, 0, anorm, ssfmin, lend-l, 1, e( l ), n, $ info ) end if c c choose between ql and qr iteration c if( abs( d( lend ) ).lt.abs( d( l ) ) ) then lend = lsv l = lendsv end if c if( lend.gt.l ) then c c ql iteration c c look for small subdiagonal element. c 40 continue if( l.ne.lend ) then lendm1 = lend - 1 do 50 m = l, lendm1 tst = abs( e( m ) )**2 if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+ $ safmin )go to 60 50 continue end if c m = lend c 60 continue if( m.lt.lend ) $ e( m ) = zero p = d( l ) if( m.eq.l ) $ go to 80 c c if remaining matrix is 2-by-2, use slae2 or slaev2 c to compute its eigensystem. c if( m.eq.l+1 ) then if( icompz.gt.0 ) then call slaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) work( l ) = c work( n-1+l ) = s c$$$ call slasr( 'r', 'v', 'b', n, 2, work( l ), c$$$ $ work( n-1+l ), z( 1, l ), ldz ) c c *** New starting with version 2.5 *** c tst = z(l+1) z(l+1) = c*tst - s*z(l) z(l) = s*tst + c*z(l) c ************************************* else call slae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) end if d( l ) = rt1 d( l+1 ) = rt2 e( l ) = zero l = l + 2 if( l.le.lend ) $ go to 40 go to 140 end if c if( jtot.eq.nmaxit ) $ go to 140 jtot = jtot + 1 c c form shift. c g = ( d( l+1 )-p ) / ( two*e( l ) ) r = slapy2( g, one ) g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) c s = one c = one p = zero c c inner loop c mm1 = m - 1 do 70 i = mm1, l, -1 f = s*e( i ) b = c*e( i ) call slartg( g, f, c, s, r ) if( i.ne.m-1 ) $ e( i+1 ) = r g = d( i+1 ) - p r = ( d( i )-g )*s + two*c*b p = s*r d( i+1 ) = g + p g = c*r - b c c if eigenvectors are desired, then save rotations. c if( icompz.gt.0 ) then work( i ) = c work( n-1+i ) = -s end if c 70 continue c c if eigenvectors are desired, then apply saved rotations. c if( icompz.gt.0 ) then mm = m - l + 1 c$$$ call slasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ), c$$$ $ z( 1, l ), ldz ) c c *** New starting with version 2.5 *** c call slasr( 'r', 'v', 'b', 1, mm, work( l ), & work( n-1+l ), z( l ), 1 ) c ************************************* end if c d( l ) = d( l ) - p e( l ) = g go to 40 c c eigenvalue found. c 80 continue d( l ) = p c l = l + 1 if( l.le.lend ) $ go to 40 go to 140 c else c c qr iteration c c look for small superdiagonal element. c 90 continue if( l.ne.lend ) then lendp1 = lend + 1 do 100 m = l, lendp1, -1 tst = abs( e( m-1 ) )**2 if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+ $ safmin )go to 110 100 continue end if c m = lend c 110 continue if( m.gt.lend ) $ e( m-1 ) = zero p = d( l ) if( m.eq.l ) $ go to 130 c c if remaining matrix is 2-by-2, use slae2 or slaev2 c to compute its eigensystem. c if( m.eq.l-1 ) then if( icompz.gt.0 ) then call slaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) c$$$ work( m ) = c c$$$ work( n-1+m ) = s c$$$ call slasr( 'r', 'v', 'f', n, 2, work( m ), c$$$ $ work( n-1+m ), z( 1, l-1 ), ldz ) c c *** New starting with version 2.5 *** c tst = z(l) z(l) = c*tst - s*z(l-1) z(l-1) = s*tst + c*z(l-1) c ************************************* else call slae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) end if d( l-1 ) = rt1 d( l ) = rt2 e( l-1 ) = zero l = l - 2 if( l.ge.lend ) $ go to 90 go to 140 end if c if( jtot.eq.nmaxit ) $ go to 140 jtot = jtot + 1 c c form shift. c g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) r = slapy2( g, one ) g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) c s = one c = one p = zero c c inner loop c lm1 = l - 1 do 120 i = m, lm1 f = s*e( i ) b = c*e( i ) call slartg( g, f, c, s, r ) if( i.ne.m ) $ e( i-1 ) = r g = d( i ) - p r = ( d( i+1 )-g )*s + two*c*b p = s*r d( i ) = g + p g = c*r - b c c if eigenvectors are desired, then save rotations. c if( icompz.gt.0 ) then work( i ) = c work( n-1+i ) = s end if c 120 continue c c if eigenvectors are desired, then apply saved rotations. c if( icompz.gt.0 ) then mm = l - m + 1 c$$$ call slasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ), c$$$ $ z( 1, m ), ldz ) c c *** New starting with version 2.5 *** c call slasr( 'r', 'v', 'f', 1, mm, work( m ), work( n-1+m ), & z( m ), 1 ) c ************************************* end if c d( l ) = d( l ) - p e( lm1 ) = g go to 90 c c eigenvalue found. c 130 continue d( l ) = p c l = l - 1 if( l.ge.lend ) $ go to 90 go to 140 c end if c c undo scaling if necessary c 140 continue if( iscale.eq.1 ) then call slascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1, $ d( lsv ), n, info ) call slascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ), $ n, info ) else if( iscale.eq.2 ) then call slascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1, $ d( lsv ), n, info ) call slascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ), $ n, info ) end if c c check for no convergence to an eigenvalue after a total c of n*maxit iterations. c if( jtot.lt.nmaxit ) $ go to 10 do 150 i = 1, n - 1 if( e( i ).ne.zero ) $ info = info + 1 150 continue go to 190 c c order eigenvalues and eigenvectors. c 160 continue if( icompz.eq.0 ) then c c use quick sort c call slasrt( 'i', n, d, info ) c else c c use selection sort to minimize swaps of eigenvectors c do 180 ii = 2, n i = ii - 1 k = i p = d( i ) do 170 j = ii, n if( d( j ).lt.p ) then k = j p = d( j ) end if 170 continue if( k.ne.i ) then d( k ) = d( i ) d( i ) = p c$$$ call sswap( n, z( 1, i ), 1, z( 1, k ), 1 ) c *** New starting with version 2.5 *** c p = z(k) z(k) = z(i) z(i) = p c ************************************* end if 180 continue end if c 190 continue return c c %---------------% c | End of sstqrb | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/cnaupd.f000644 001750 001750 00000066152 11266605602 022100 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: cnaupd c c\Description: c Reverse communication interface for the Implicitly Restarted Arnoldi c iteration. This is intended to be used to find a few eigenpairs of a c complex linear operator OP with respect to a semi-inner product defined c by a hermitian positive semi-definite real matrix B. B may be the identity c matrix. NOTE: if both OP and B are real, then ssaupd or snaupd should c be used. c c c The computed approximate eigenvalues are called Ritz values and c the corresponding approximate eigenvectors are called Ritz vectors. c c cnaupd is usually called iteratively to solve one of the c following problems: c c Mode 1: A*x = lambda*x. c ===> OP = A and B = I. c c Mode 2: A*x = lambda*M*x, M hermitian positive definite c ===> OP = inv[M]*A and B = M. c ===> (If M can be factored see remark 3 below) c c Mode 3: A*x = lambda*M*x, M hermitian semi-definite c ===> OP = inv[A - sigma*M]*M and B = M. c ===> shift-and-invert mode c If OP*x = amu*x, then lambda = sigma + 1/amu. c c c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v c should be accomplished either by a direct method c using a sparse matrix factorization and solving c c [A - sigma*M]*w = v or M*w = v, c c or through an iterative method for solving these c systems. If an iterative method is used, the c convergence test must be more stringent than c the accuracy requirements for the eigenvalue c approximations. c c\Usage: c call cnaupd c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, c IPNTR, WORKD, WORKL, LWORKL, RWORK, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to cnaupd. IDO will be set internally to c indicate the type of operation to be performed. Control is c then given back to the calling routine which has the c responsibility to carry out the requested operation and call c cnaupd with the result. The operand is given in c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c In mode 3, the vector B * X is already c available in WORKD(ipntr(3)). It does not c need to be recomputed in forming OP * X. c IDO = 2: compute Y = M * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 3: compute and return the shifts in the first c NP locations of WORKL. c IDO = 99: done c ------------------------------------------------------------- c After the initialization phase, when the routine is used in c the "shift-and-invert" mode, the vector M * X is already c available and does not need to be recomputed in forming OP*X. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c WHICH Character*2. (INPUT) c 'LM' -> want the NEV eigenvalues of largest magnitude. c 'SM' -> want the NEV eigenvalues of smallest magnitude. c 'LR' -> want the NEV eigenvalues of largest real part. c 'SR' -> want the NEV eigenvalues of smallest real part. c 'LI' -> want the NEV eigenvalues of largest imaginary part. c 'SI' -> want the NEV eigenvalues of smallest imaginary part. c c NEV Integer. (INPUT) c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. c c TOL Real scalar. (INPUT) c Stopping criteria: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. c DEFAULT = slamch('EPS') (machine precision as computed c by the LAPACK auxiliary subroutine slamch). c c RESID Complex array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V. NCV must satisfy the two c inequalities 1 <= NCV-NEV and NCV <= N. c This will indicate how many Arnoldi vectors are generated c at each iteration. After the startup phase in which NEV c Arnoldi vectors are generated, the algorithm generates c approximately NCV-NEV Arnoldi vectors at each subsequent update c iteration. Most of the cost in generating each Arnoldi vector is c in the matrix-vector operation OP*x. (See remark 4 below.) c c V Complex array N by NCV. (OUTPUT) c Contains the final set of Arnoldi basis vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling program. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. c The shifts selected at each iteration are used to filter out c the components of the unwanted eigenvector. c ------------------------------------------------------------- c ISHIFT = 0: the shifts are to be provided by the user via c reverse communication. The NCV eigenvalues of c the Hessenberg matrix H are returned in the part c of WORKL array corresponding to RITZ. c ISHIFT = 1: exact shifts with respect to the current c Hessenberg matrix H. This is equivalent to c restarting the iteration from the beginning c after updating the starting vector with a linear c combination of Ritz vectors associated with the c "wanted" eigenvalues. c ISHIFT = 2: other choice of internal shift to be defined. c ------------------------------------------------------------- c c IPARAM(2) = No longer referenced c c IPARAM(3) = MXITER c On INPUT: maximum number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" Ritz values. c This represents the number of Ritz values that satisfy c the convergence criterion. c c IPARAM(6) = IUPD c No longer referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = MODE c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2,3; See under \Description of cnaupd for the c four modes available. c c IPARAM(8) = NP c When ido = 3 and the user provides shifts through reverse c communication (IPARAM(1)=0), _naupd returns NP, the number c of shifts the user is to provide. 0 < NP < NCV-NEV. c c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, c OUTPUT: NUMOP = total number of OP*x operations, c NUMOPB = total number of B*x operations if BMAT='G', c NUMREO = total number of steps of re-orthogonalization. c c IPNTR Integer array of length 14. (OUTPUT) c Pointer to mark the starting locations in the WORKD and WORKL c arrays for matrices/vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X in WORKD. c IPNTR(2): pointer to the current result vector Y in WORKD. c IPNTR(3): pointer to the vector B * X in WORKD when used in c the shift-and-invert mode. c IPNTR(4): pointer to the next available location in WORKL c that is untouched by the program. c IPNTR(5): pointer to the NCV by NCV upper Hessenberg c matrix H in WORKL. c IPNTR(6): pointer to the ritz value array RITZ c IPNTR(7): pointer to the (projected) ritz vector array Q c IPNTR(8): pointer to the error BOUNDS array in WORKL. c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. c c Note: IPNTR(9:13) is only referenced by cneupd. See Remark 2 below. c c IPNTR(9): pointer to the NCV RITZ values of the c original system. c IPNTR(10): Not Used c IPNTR(11): pointer to the NCV corresponding error bounds. c IPNTR(12): pointer to the NCV by NCV upper triangular c Schur matrix for H. c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors c of the upper Hessenberg matrix H. Only referenced by c cneupd if RVEC = .TRUE. See Remark 2 below. c c ------------------------------------------------------------- c c WORKD Complex work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration !!!!!!!!!! c See Data Distribution Note below. c c WORKL Complex work array of length LWORKL. (OUTPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. See Data Distribution Note below. c c LWORKL Integer. (INPUT) c LWORKL must be at least 3*NCV**2 + 5*NCV. c c RWORK Real work array of length NCV (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal exit. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. IPARAM(5) c returns the number of wanted converged Ritz values. c = 2: No longer an informational error. Deprecated starting c with release 2 of ARPACK. c = 3: No shifts could be applied during a cycle of the c Implicitly restarted Arnoldi iteration. One possibility c is to increase the size of NCV relative to NEV. c See remark 4 below. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 1 and less than or equal to N. c = -4: The maximum number of Arnoldi update iteration c must be greater than zero. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work array is not sufficient. c = -8: Error return from LAPACK eigenvalue calculation; c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: IPARAM(1) must be equal to 0 or 1. c = -9999: Could not build an Arnoldi factorization. c User input error highly likely. Please c check actual array dimensions and layout. c IPARAM(5) returns the size of the current Arnoldi c factorization. c c\Remarks c 1. The computed Ritz values are approximate eigenvalues of OP. The c selection of WHICH should be made with this in mind when using c Mode = 3. When operating in Mode = 3 setting WHICH = 'LM' will c compute the NEV eigenvalues of the original problem that are c closest to the shift SIGMA . After convergence, approximate eigenvalues c of the original problem may be obtained with the ARPACK subroutine cneupd. c c 2. If a basis for the invariant subspace corresponding to the converged Ritz c values is needed, the user must call cneupd immediately following c completion of cnaupd. This is new starting with release 2 of ARPACK. c c 3. If M can be factored into a Cholesky factorization M = LL` c then Mode = 2 should not be selected. Instead one should use c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular c linear systems should be solved with L and L` rather c than computing inverses. After convergence, an approximate c eigenvector z of the original problem is recovered by solving c L`z = x where x is a Ritz vector of OP. c c 4. At present there is no a-priori analysis to guide the selection c of NCV relative to NEV. The only formal requirement is that NCV > NEV + 1. c However, it is recommended that NCV .ge. 2*NEV. If many problems of c the same type are to be solved, one should experiment with increasing c NCV while keeping NEV fixed for a given test problem. This will c usually decrease the required number of OP*x operations but it c also increases the work and storage required to maintain the orthogonal c basis vectors. The optimal "cross-over" with respect to CPU time c is problem dependent and must be determined empirically. c See Chapter 8 of Reference 2 for further information. c c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the c NP = IPARAM(8) complex shifts in locations c WORKL(IPNTR(14)), WORKL(IPNTR(14)+1), ... , WORKL(IPNTR(14)+NP). c Eigenvalues of the current upper Hessenberg matrix are located in c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are ordered c according to the order defined by WHICH. The associated Ritz estimates c are located in WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , c WORKL(IPNTR(8)+NCV-1). c c----------------------------------------------------------------------- c c\Data Distribution Note: c c Fortran-D syntax: c ================ c Complex resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) c decompose d1(n), d2(n,ncv) c align resid(i) with d1(i) c align v(i,j) with d2(i,j) c align workd(i) with d1(i) range (1:n) c align workd(i) with d1(i-n) range (n+1:2*n) c align workd(i) with d1(i-2*n) range (2*n+1:3*n) c distribute d1(block), d2(block,:) c replicated workl(lworkl) c c Cray MPP syntax: c =============== c Complex resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) c shared resid(block), v(block,:), workd(block,:) c replicated workl(lworkl) c c CM2/CM5 syntax: c ============== c c----------------------------------------------------------------------- c c include 'ex-nonsym.doc' c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett & Y. Saad, "_Complex_ Shift and Invert Strategies for c Real Matrices", Linear Algebra and its Applications, vol 88/89, c pp 575-595, (1987). c c\Routines called: c cnaup2 ARPACK routine that implements the Implicitly Restarted c Arnoldi Iteration. c cstatn ARPACK routine that initializes the timing variables. c ivout ARPACK utility routine that prints integers. c cvout ARPACK utility routine that prints vectors. c second ARPACK utility routine for timing. c slamch LAPACK routine that determines machine constants. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: naupd.F SID: 2.9 DATE OF SID: 07/21/02 RELEASE: 2 c c\Remarks c c\EndLib c c----------------------------------------------------------------------- c subroutine cnaupd & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, & ipntr, workd, workl, lworkl, rwork, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ldv, lworkl, n, ncv, nev Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(14) Complex & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) Real & rwork(ncv) c c %------------% c | Parameters | c %------------% c Complex & one, zero parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0)) c c %---------------% c | Local Scalars | c %---------------% c integer bounds, ierr, ih, iq, ishift, iupd, iw, & ldh, ldq, levec, mode, msglvl, mxiter, nb, & nev0, next, np, ritz, j save bounds, ih, iq, ishift, iupd, iw, & ldh, ldq, levec, mode, msglvl, mxiter, nb, & nev0, next, np, ritz c c %----------------------% c | External Subroutines | c %----------------------% c external cnaup2, cvout, ivout, second, cstatn c c %--------------------% c | External Functions | c %--------------------% c Real & slamch external slamch c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call cstatn call second (t0) msglvl = mcaupd c c %----------------% c | Error checking | c %----------------% c ierr = 0 ishift = iparam(1) c levec = iparam(2) mxiter = iparam(3) c nb = iparam(4) nb = 1 c c %--------------------------------------------% c | Revision 2 performs only implicit restart. | c %--------------------------------------------% c iupd = 1 mode = iparam(7) c if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev .or. ncv .gt. n) then ierr = -3 else if (mxiter .le. 0) then ierr = -4 else if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LR' .and. & which .ne. 'SR' .and. & which .ne. 'LI' .and. & which .ne. 'SI') then ierr = -5 else if (bmat .ne. 'I' .and. bmat .ne. 'G') then ierr = -6 else if (lworkl .lt. 3*ncv**2 + 5*ncv) then ierr = -7 else if (mode .lt. 1 .or. mode .gt. 3) then ierr = -10 else if (mode .eq. 1 .and. bmat .eq. 'G') then ierr = -11 end if c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr ido = 99 go to 9000 end if c c %------------------------% c | Set default parameters | c %------------------------% c if (nb .le. 0) nb = 1 if (tol .le. 0.0E+0 ) tol = slamch('EpsMach') if (ishift .ne. 0 .and. & ishift .ne. 1 .and. & ishift .ne. 2) ishift = 1 c c %----------------------------------------------% c | NP is the number of additional steps to | c | extend the length NEV Lanczos factorization. | c | NEV0 is the local variable designating the | c | size of the invariant subspace desired. | c %----------------------------------------------% c np = ncv - nev nev0 = nev c c %-----------------------------% c | Zero out internal workspace | c %-----------------------------% c do 10 j = 1, 3*ncv**2 + 5*ncv workl(j) = zero 10 continue c c %-------------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:ncv*ncv) := generated Hessenberg matrix | c | workl(ncv*ncv+1:ncv*ncv+ncv) := the ritz values | c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | c | workl(ncv*ncv+2*ncv+1:2*ncv*ncv+2*ncv) := rotation matrix Q | c | workl(2*ncv*ncv+2*ncv+1:3*ncv*ncv+5*ncv) := workspace | c | The final workspace is needed by subroutine cneigh called | c | by cnaup2. Subroutine cneigh calls LAPACK routines for | c | calculating eigenvalues and the last row of the eigenvector | c | matrix. | c %-------------------------------------------------------------% c ldh = ncv ldq = ncv ih = 1 ritz = ih + ldh*ncv bounds = ritz + ncv iq = bounds + ncv iw = iq + ldq*ncv next = iw + ncv**2 + 3*ncv c ipntr(4) = next ipntr(5) = ih ipntr(6) = ritz ipntr(7) = iq ipntr(8) = bounds ipntr(14) = iw end if c c %-------------------------------------------------------% c | Carry out the Implicitly restarted Arnoldi Iteration. | c %-------------------------------------------------------% c call cnaup2 & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), & workl(bounds), workl(iq), ldq, workl(iw), & ipntr, workd, rwork, info ) c c %--------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP. | c %--------------------------------------------------% c if (ido .eq. 3) iparam(8) = np if (ido .ne. 99) go to 9000 c iparam(3) = mxiter iparam(5) = np iparam(9) = nopx iparam(10) = nbx iparam(11) = nrorth c c %------------------------------------% c | Exit if there was an informational | c | error within cnaup2. | c %------------------------------------% c if (info .lt. 0) go to 9000 if (info .eq. 2) info = 3 c if (msglvl .gt. 0) then call ivout (logfil, 1, mxiter, ndigit, & '_naupd: Number of update iterations taken') call ivout (logfil, 1, np, ndigit, & '_naupd: Number of wanted "converged" Ritz values') call cvout (logfil, np, workl(ritz), ndigit, & '_naupd: The final Ritz values') call cvout (logfil, np, workl(bounds), ndigit, & '_naupd: Associated Ritz estimates') end if c call second (t1) tcaupd = t1 - t0 c if (msglvl .gt. 0) then c c %--------------------------------------------------------% c | Version Number & Version Date are defined in version.h | c %--------------------------------------------------------% c write (6,1000) write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, & tmvopx, tmvbx, tcaupd, tcaup2, tcaitr, titref, & tgetv0, tceigh, tcgets, tcapps, tcconv, trvec 1000 format (//, & 5x, '=============================================',/ & 5x, '= Complex implicit Arnoldi update code =',/ & 5x, '= Version Number: ', ' 2.3', 21x, ' =',/ & 5x, '= Version Date: ', ' 07/31/96', 16x, ' =',/ & 5x, '=============================================',/ & 5x, '= Summary of timing statistics =',/ & 5x, '=============================================',//) 1100 format ( & 5x, 'Total number update iterations = ', i5,/ & 5x, 'Total number of OP*x operations = ', i5,/ & 5x, 'Total number of B*x operations = ', i5,/ & 5x, 'Total number of reorthogonalization steps = ', i5,/ & 5x, 'Total number of iterative refinement steps = ', i5,/ & 5x, 'Total number of restart steps = ', i5,/ & 5x, 'Total time in user OP*x operation = ', f12.6,/ & 5x, 'Total time in user B*x operation = ', f12.6,/ & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ & 5x, 'Total time in naup2 routine = ', f12.6,/ & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ & 5x, 'Total time in (re)start vector generation = ', f12.6,/ & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ & 5x, 'Total time in getting the shifts = ', f12.6,/ & 5x, 'Total time in applying the shifts = ', f12.6,/ & 5x, 'Total time in convergence testing = ', f12.6,/ & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) end if c 9000 continue c return c c %---------------% c | End of cnaupd | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/ssesrt.f000644 001750 001750 00000012310 11266605602 022134 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: ssesrt c c\Description: c Sort the array X in the order specified by WHICH and optionally c apply the permutation to the columns of the matrix A. c c\Usage: c call ssesrt c ( WHICH, APPLY, N, X, NA, A, LDA) c c\Arguments c WHICH Character*2. (Input) c 'LM' -> X is sorted into increasing order of magnitude. c 'SM' -> X is sorted into decreasing order of magnitude. c 'LA' -> X is sorted into increasing order of algebraic. c 'SA' -> X is sorted into decreasing order of algebraic. c c APPLY Logical. (Input) c APPLY = .TRUE. -> apply the sorted order to A. c APPLY = .FALSE. -> do not apply the sorted order to A. c c N Integer. (INPUT) c Dimension of the array X. c c X Real array of length N. (INPUT/OUTPUT) c The array to be sorted. c c NA Integer. (INPUT) c Number of rows of the matrix A. c c A Real array of length NA by N. (INPUT/OUTPUT) c c LDA Integer. (INPUT) c Leading dimension of A. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Routines c sswap Level 1 BLAS that swaps the contents of two vectors. c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/15/93: Version ' 2.1'. c Adapted from the sort routine in LANSO and c the ARPACK code ssortr c c\SCCS Information: @(#) c FILE: sesrt.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine ssesrt (which, apply, n, x, na, a, lda) c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which logical apply integer lda, n, na c c %-----------------% c | Array Arguments | c %-----------------% c Real & x(0:n-1), a(lda, 0:n-1) c c %---------------% c | Local Scalars | c %---------------% c integer i, igap, j Real & temp c c %----------------------% c | External Subroutines | c %----------------------% c external sswap c c %-----------------------% c | Executable Statements | c %-----------------------% c igap = n / 2 c if (which .eq. 'SA') then c c X is sorted into decreasing order of algebraic. c 10 continue if (igap .eq. 0) go to 9000 do 30 i = igap, n-1 j = i-igap 20 continue c if (j.lt.0) go to 30 c if (x(j).lt.x(j+igap)) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1) else go to 30 endif j = j-igap go to 20 30 continue igap = igap / 2 go to 10 c else if (which .eq. 'SM') then c c X is sorted into decreasing order of magnitude. c 40 continue if (igap .eq. 0) go to 9000 do 60 i = igap, n-1 j = i-igap 50 continue c if (j.lt.0) go to 60 c if (abs(x(j)).lt.abs(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1) else go to 60 endif j = j-igap go to 50 60 continue igap = igap / 2 go to 40 c else if (which .eq. 'LA') then c c X is sorted into increasing order of algebraic. c 70 continue if (igap .eq. 0) go to 9000 do 90 i = igap, n-1 j = i-igap 80 continue c if (j.lt.0) go to 90 c if (x(j).gt.x(j+igap)) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1) else go to 90 endif j = j-igap go to 80 90 continue igap = igap / 2 go to 70 c else if (which .eq. 'LM') then c c X is sorted into increasing order of magnitude. c 100 continue if (igap .eq. 0) go to 9000 do 120 i = igap, n-1 j = i-igap 110 continue c if (j.lt.0) go to 120 c if (abs(x(j)).gt.abs(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1) else go to 120 endif j = j-igap go to 110 120 continue igap = igap / 2 go to 100 end if c 9000 continue return c c %---------------% c | End of ssesrt | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dngets.f000644 001750 001750 00000017534 11266605602 022112 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dngets c c\Description: c Given the eigenvalues of the upper Hessenberg matrix H, c computes the NP shifts AMU that are zeros of the polynomial of c degree NP which filters out components of the unwanted eigenvectors c corresponding to the AMU's based on some given criteria. c c NOTE: call this even in the case of user specified shifts in order c to sort the eigenvalues, and error bounds of H for later use. c c\Usage: c call dngets c ( ISHIFT, WHICH, KEV, NP, RITZR, RITZI, BOUNDS, SHIFTR, SHIFTI ) c c\Arguments c ISHIFT Integer. (INPUT) c Method for selecting the implicit shifts at each iteration. c ISHIFT = 0: user specified shifts c ISHIFT = 1: exact shift with respect to the matrix H. c c WHICH Character*2. (INPUT) c Shift selection criteria. c 'LM' -> want the KEV eigenvalues of largest magnitude. c 'SM' -> want the KEV eigenvalues of smallest magnitude. c 'LR' -> want the KEV eigenvalues of largest real part. c 'SR' -> want the KEV eigenvalues of smallest real part. c 'LI' -> want the KEV eigenvalues of largest imaginary part. c 'SI' -> want the KEV eigenvalues of smallest imaginary part. c c KEV Integer. (INPUT/OUTPUT) c INPUT: KEV+NP is the size of the matrix H. c OUTPUT: Possibly increases KEV by one to keep complex conjugate c pairs together. c c NP Integer. (INPUT/OUTPUT) c Number of implicit shifts to be computed. c OUTPUT: Possibly decreases NP by one to keep complex conjugate c pairs together. c c RITZR, Double precision array of length KEV+NP. (INPUT/OUTPUT) c RITZI On INPUT, RITZR and RITZI contain the real and imaginary c parts of the eigenvalues of H. c On OUTPUT, RITZR and RITZI are sorted so that the unwanted c eigenvalues are in the first NP locations and the wanted c portion is in the last KEV locations. When exact shifts are c selected, the unwanted part corresponds to the shifts to c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues c are further sorted so that the ones with largest Ritz values c are first. c c BOUNDS Double precision array of length KEV+NP. (INPUT/OUTPUT) c Error bounds corresponding to the ordering in RITZ. c c SHIFTR, SHIFTI *** USE deprecated as of version 2.1. *** c c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c dsortc ARPACK sorting routine. c dcopy Level 1 BLAS that copies one vector to another . c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.1' c c\SCCS Information: @(#) c FILE: ngets.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c 1. xxxx c c\EndLib c c----------------------------------------------------------------------- c subroutine dngets ( ishift, which, kev, np, ritzr, ritzi, bounds, & shiftr, shifti ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which integer ishift, kev, np c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & bounds(kev+np), ritzr(kev+np), ritzi(kev+np), & shiftr(1), shifti(1) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0, zero = 0.0) c c %---------------% c | Local Scalars | c %---------------% c integer msglvl c c %----------------------% c | External Subroutines | c %----------------------% c external dcopy, dsortc, second c c %----------------------% c | Intrinsics Functions | c %----------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mngets c c %----------------------------------------------------% c | LM, SM, LR, SR, LI, SI case. | c | Sort the eigenvalues of H into the desired order | c | and apply the resulting order to BOUNDS. | c | The eigenvalues are sorted so that the wanted part | c | are always in the last KEV locations. | c | We first do a pre-processing sort in order to keep | c | complex conjugate pairs together | c %----------------------------------------------------% c if (which .eq. 'LM') then call dsortc ('LR', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'SM') then call dsortc ('SR', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'LR') then call dsortc ('LM', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'SR') then call dsortc ('SM', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'LI') then call dsortc ('LM', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'SI') then call dsortc ('SM', .true., kev+np, ritzr, ritzi, bounds) end if c call dsortc (which, .true., kev+np, ritzr, ritzi, bounds) c c %-------------------------------------------------------% c | Increase KEV by one if the ( ritzr(np),ritzi(np) ) | c | = ( ritzr(np+1),-ritzi(np+1) ) and ritz(np) .ne. zero | c | Accordingly decrease NP by one. In other words keep | c | complex conjugate pairs together. | c %-------------------------------------------------------% c if ( ( ritzr(np+1) - ritzr(np) ) .eq. zero & .and. ( ritzi(np+1) + ritzi(np) ) .eq. zero ) then np = np - 1 kev = kev + 1 end if c if ( ishift .eq. 1 ) then c c %-------------------------------------------------------% c | Sort the unwanted Ritz values used as shifts so that | c | the ones with largest Ritz estimates are first | c | This will tend to minimize the effects of the | c | forward instability of the iteration when they shifts | c | are applied in subroutine dnapps. | c | Be careful and use 'SR' since we want to sort BOUNDS! | c %-------------------------------------------------------% c call dsortc ( 'SR', .true., np, bounds, ritzr, ritzi ) end if c call second (t1) tngets = tngets + (t1 - t0) c if (msglvl .gt. 0) then call ivout (logfil, 1, kev, ndigit, '_ngets: KEV is') call ivout (logfil, 1, np, ndigit, '_ngets: NP is') call dvout (logfil, kev+np, ritzr, ndigit, & '_ngets: Eigenvalues of current H matrix -- real part') call dvout (logfil, kev+np, ritzi, ndigit, & '_ngets: Eigenvalues of current H matrix -- imag part') call dvout (logfil, kev+np, bounds, ndigit, & '_ngets: Ritz estimates of the current KEV+NP Ritz values') end if c return c c %---------------% c | End of dngets | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dnaupd.f000644 001750 001750 00000072023 11266605602 022073 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: dnaupd c c\Description: c Reverse communication interface for the Implicitly Restarted Arnoldi c iteration. This subroutine computes approximations to a few eigenpairs c of a linear operator "OP" with respect to a semi-inner product defined by c a symmetric positive semi-definite real matrix B. B may be the identity c matrix. NOTE: If the linear operator "OP" is real and symmetric c with respect to the real positive semi-definite symmetric matrix B, c i.e. B*OP = (OP`)*B, then subroutine dsaupd should be used instead. c c The computed approximate eigenvalues are called Ritz values and c the corresponding approximate eigenvectors are called Ritz vectors. c c dnaupd is usually called iteratively to solve one of the c following problems: c c Mode 1: A*x = lambda*x. c ===> OP = A and B = I. c c Mode 2: A*x = lambda*M*x, M symmetric positive definite c ===> OP = inv[M]*A and B = M. c ===> (If M can be factored see remark 3 below) c c Mode 3: A*x = lambda*M*x, M symmetric semi-definite c ===> OP = Real_Part{ inv[A - sigma*M]*M } and B = M. c ===> shift-and-invert mode (in real arithmetic) c If OP*x = amu*x, then c amu = 1/2 * [ 1/(lambda-sigma) + 1/(lambda-conjg(sigma)) ]. c Note: If sigma is real, i.e. imaginary part of sigma is zero; c Real_Part{ inv[A - sigma*M]*M } == inv[A - sigma*M]*M c amu == 1/(lambda-sigma). c c Mode 4: A*x = lambda*M*x, M symmetric semi-definite c ===> OP = Imaginary_Part{ inv[A - sigma*M]*M } and B = M. c ===> shift-and-invert mode (in real arithmetic) c If OP*x = amu*x, then c amu = 1/2i * [ 1/(lambda-sigma) - 1/(lambda-conjg(sigma)) ]. c c Both mode 3 and 4 give the same enhancement to eigenvalues close to c the (complex) shift sigma. However, as lambda goes to infinity, c the operator OP in mode 4 dampens the eigenvalues more strongly than c does OP defined in mode 3. c c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v c should be accomplished either by a direct method c using a sparse matrix factorization and solving c c [A - sigma*M]*w = v or M*w = v, c c or through an iterative method for solving these c systems. If an iterative method is used, the c convergence test must be more stringent than c the accuracy requirements for the eigenvalue c approximations. c c\Usage: c call dnaupd c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, c IPNTR, WORKD, WORKL, LWORKL, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to dnaupd. IDO will be set internally to c indicate the type of operation to be performed. Control is c then given back to the calling routine which has the c responsibility to carry out the requested operation and call c dnaupd with the result. The operand is given in c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c In mode 3 and 4, the vector B * X is already c available in WORKD(ipntr(3)). It does not c need to be recomputed in forming OP * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 3: compute the IPARAM(8) real and imaginary parts c of the shifts where INPTR(14) is the pointer c into WORKL for placing the shifts. See Remark c 5 below. c IDO = 99: done c ------------------------------------------------------------- c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*B*x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c WHICH Character*2. (INPUT) c 'LM' -> want the NEV eigenvalues of largest magnitude. c 'SM' -> want the NEV eigenvalues of smallest magnitude. c 'LR' -> want the NEV eigenvalues of largest real part. c 'SR' -> want the NEV eigenvalues of smallest real part. c 'LI' -> want the NEV eigenvalues of largest imaginary part. c 'SI' -> want the NEV eigenvalues of smallest imaginary part. c c NEV Integer. (INPUT/OUTPUT) c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. c c TOL Double precision scalar. (INPUT) c Stopping criterion: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. c DEFAULT = DLAMCH('EPS') (machine precision as computed c by the LAPACK auxiliary subroutine DLAMCH). c c RESID Double precision array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V. NCV must satisfy the two c inequalities 2 <= NCV-NEV and NCV <= N. c This will indicate how many Arnoldi vectors are generated c at each iteration. After the startup phase in which NEV c Arnoldi vectors are generated, the algorithm generates c approximately NCV-NEV Arnoldi vectors at each subsequent update c iteration. Most of the cost in generating each Arnoldi vector is c in the matrix-vector operation OP*x. c NOTE: 2 <= NCV-NEV in order that complex conjugate pairs of Ritz c values are kept together. (See remark 4 below) c c V Double precision array N by NCV. (OUTPUT) c Contains the final set of Arnoldi basis vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling program. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. c The shifts selected at each iteration are used to restart c the Arnoldi iteration in an implicit fashion. c ------------------------------------------------------------- c ISHIFT = 0: the shifts are provided by the user via c reverse communication. The real and imaginary c parts of the NCV eigenvalues of the Hessenberg c matrix H are returned in the part of the WORKL c array corresponding to RITZR and RITZI. See remark c 5 below. c ISHIFT = 1: exact shifts with respect to the current c Hessenberg matrix H. This is equivalent to c restarting the iteration with a starting vector c that is a linear combination of approximate Schur c vectors associated with the "wanted" Ritz values. c ------------------------------------------------------------- c c IPARAM(2) = No longer referenced. c c IPARAM(3) = MXITER c On INPUT: maximum number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" Ritz values. c This represents the number of Ritz values that satisfy c the convergence criterion. c c IPARAM(6) = IUPD c No longer referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = MODE c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2,3,4; See under \Description of dnaupd for the c four modes available. c c IPARAM(8) = NP c When ido = 3 and the user provides shifts through reverse c communication (IPARAM(1)=0), dnaupd returns NP, the number c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark c 5 below. c c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, c OUTPUT: NUMOP = total number of OP*x operations, c NUMOPB = total number of B*x operations if BMAT='G', c NUMREO = total number of steps of re-orthogonalization. c c IPNTR Integer array of length 14. (OUTPUT) c Pointer to mark the starting locations in the WORKD and WORKL c arrays for matrices/vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X in WORKD. c IPNTR(2): pointer to the current result vector Y in WORKD. c IPNTR(3): pointer to the vector B * X in WORKD when used in c the shift-and-invert mode. c IPNTR(4): pointer to the next available location in WORKL c that is untouched by the program. c IPNTR(5): pointer to the NCV by NCV upper Hessenberg matrix c H in WORKL. c IPNTR(6): pointer to the real part of the ritz value array c RITZR in WORKL. c IPNTR(7): pointer to the imaginary part of the ritz value array c RITZI in WORKL. c IPNTR(8): pointer to the Ritz estimates in array WORKL associated c with the Ritz values located in RITZR and RITZI in WORKL. c c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. c c Note: IPNTR(9:13) is only referenced by dneupd. See Remark 2 below. c c IPNTR(9): pointer to the real part of the NCV RITZ values of the c original system. c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of c the original system. c IPNTR(11): pointer to the NCV corresponding error bounds. c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular c Schur matrix for H. c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors c of the upper Hessenberg matrix H. Only referenced by c dneupd if RVEC = .TRUE. See Remark 2 below. c ------------------------------------------------------------- c c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration. Upon termination c WORKD(1:N) contains B*RESID(1:N). If an invariant subspace c associated with the converged Ritz values is desired, see remark c 2 below, subroutine dneupd uses this output. c See Data Distribution Note below. c c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. See Data Distribution Note below. c c LWORKL Integer. (INPUT) c LWORKL must be at least 3*NCV**2 + 6*NCV. c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal exit. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. IPARAM(5) c returns the number of wanted converged Ritz values. c = 2: No longer an informational error. Deprecated starting c with release 2 of ARPACK. c = 3: No shifts could be applied during a cycle of the c Implicitly restarted Arnoldi iteration. One possibility c is to increase the size of NCV relative to NEV. c See remark 4 below. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 2 and less than or equal to N. c = -4: The maximum number of Arnoldi update iteration c must be greater than zero. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work array is not sufficient. c = -8: Error return from LAPACK eigenvalue calculation; c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3,4. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable. c = -12: IPARAM(1) must be equal to 0 or 1. c = -9999: Could not build an Arnoldi factorization. c IPARAM(5) returns the size of the current Arnoldi c factorization. c c\Remarks c 1. The computed Ritz values are approximate eigenvalues of OP. The c selection of WHICH should be made with this in mind when c Mode = 3 and 4. After convergence, approximate eigenvalues of the c original problem may be obtained with the ARPACK subroutine dneupd. c c 2. If a basis for the invariant subspace corresponding to the converged Ritz c values is needed, the user must call dneupd immediately following c completion of dnaupd. This is new starting with release 2 of ARPACK. c c 3. If M can be factored into a Cholesky factorization M = LL` c then Mode = 2 should not be selected. Instead one should use c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular c linear systems should be solved with L and L` rather c than computing inverses. After convergence, an approximate c eigenvector z of the original problem is recovered by solving c L`z = x where x is a Ritz vector of OP. c c 4. At present there is no a-priori analysis to guide the selection c of NCV relative to NEV. The only formal requrement is that NCV > NEV + 2. c However, it is recommended that NCV .ge. 2*NEV+1. If many problems of c the same type are to be solved, one should experiment with increasing c NCV while keeping NEV fixed for a given test problem. This will c usually decrease the required number of OP*x operations but it c also increases the work and storage required to maintain the orthogonal c basis vectors. The optimal "cross-over" with respect to CPU time c is problem dependent and must be determined empirically. c See Chapter 8 of Reference 2 for further information. c c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the c NP = IPARAM(8) real and imaginary parts of the shifts in locations c real part imaginary part c ----------------------- -------------- c 1 WORKL(IPNTR(14)) WORKL(IPNTR(14)+NP) c 2 WORKL(IPNTR(14)+1) WORKL(IPNTR(14)+NP+1) c . . c . . c . . c NP WORKL(IPNTR(14)+NP-1) WORKL(IPNTR(14)+2*NP-1). c c Only complex conjugate pairs of shifts may be applied and the pairs c must be placed in consecutive locations. The real part of the c eigenvalues of the current upper Hessenberg matrix are located in c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1) and the imaginary part c in WORKL(IPNTR(7)) through WORKL(IPNTR(7)+NCV-1). They are ordered c according to the order defined by WHICH. The complex conjugate c pairs are kept together and the associated Ritz estimates are located in c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). c c----------------------------------------------------------------------- c c\Data Distribution Note: c c Fortran-D syntax: c ================ c Double precision resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) c decompose d1(n), d2(n,ncv) c align resid(i) with d1(i) c align v(i,j) with d2(i,j) c align workd(i) with d1(i) range (1:n) c align workd(i) with d1(i-n) range (n+1:2*n) c align workd(i) with d1(i-2*n) range (2*n+1:3*n) c distribute d1(block), d2(block,:) c replicated workl(lworkl) c c Cray MPP syntax: c =============== c Double precision resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) c shared resid(block), v(block,:), workd(block,:) c replicated workl(lworkl) c c CM2/CM5 syntax: c ============== c c----------------------------------------------------------------------- c c include 'ex-nonsym.doc' c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for c Real Matrices", Linear Algebra and its Applications, vol 88/89, c pp 575-595, (1987). c c\Routines called: c dnaup2 ARPACK routine that implements the Implicitly Restarted c Arnoldi Iteration. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c dvout ARPACK utility routine that prints vectors. c dlamch LAPACK routine that determines machine constants. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/16/93: Version '1.1' c c\SCCS Information: @(#) c FILE: naupd.F SID: 2.10 DATE OF SID: 08/23/02 RELEASE: 2 c c\Remarks c c\EndLib c c----------------------------------------------------------------------- c subroutine dnaupd & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, & ipntr, workd, workl, lworkl, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ldv, lworkl, n, ncv, nev Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(14) Double precision & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %---------------% c | Local Scalars | c %---------------% c integer bounds, ierr, ih, iq, ishift, iupd, iw, & ldh, ldq, levec, mode, msglvl, mxiter, nb, & nev0, next, np, ritzi, ritzr, j save bounds, ih, iq, ishift, iupd, iw, ldh, ldq, & levec, mode, msglvl, mxiter, nb, nev0, next, & np, ritzi, ritzr c c %----------------------% c | External Subroutines | c %----------------------% c external dnaup2, dvout, ivout, second, dstatn c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlamch external dlamch c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call dstatn call second (t0) msglvl = mnaupd c c %----------------% c | Error checking | c %----------------% c ierr = 0 ishift = iparam(1) c levec = iparam(2) mxiter = iparam(3) c nb = iparam(4) nb = 1 c c %--------------------------------------------% c | Revision 2 performs only implicit restart. | c %--------------------------------------------% c iupd = 1 mode = iparam(7) c if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev+1 .or. ncv .gt. n) then ierr = -3 else if (mxiter .le. 0) then ierr = 4 else if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LR' .and. & which .ne. 'SR' .and. & which .ne. 'LI' .and. & which .ne. 'SI') then ierr = -5 else if (bmat .ne. 'I' .and. bmat .ne. 'G') then ierr = -6 else if (lworkl .lt. 3*ncv**2 + 6*ncv) then ierr = -7 else if (mode .lt. 1 .or. mode .gt. 4) then ierr = -10 else if (mode .eq. 1 .and. bmat .eq. 'G') then ierr = -11 else if (ishift .lt. 0 .or. ishift .gt. 1) then ierr = -12 end if c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr ido = 99 go to 9000 end if c c %------------------------% c | Set default parameters | c %------------------------% c if (nb .le. 0) nb = 1 if (tol .le. zero) tol = dlamch('EpsMach') c c %----------------------------------------------% c | NP is the number of additional steps to | c | extend the length NEV Lanczos factorization. | c | NEV0 is the local variable designating the | c | size of the invariant subspace desired. | c %----------------------------------------------% c np = ncv - nev nev0 = nev c c %-----------------------------% c | Zero out internal workspace | c %-----------------------------% c do 10 j = 1, 3*ncv**2 + 6*ncv workl(j) = zero 10 continue c c %-------------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:ncv*ncv) := generated Hessenberg matrix | c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | c | parts of ritz values | c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | c | workl(ncv*ncv+3*ncv+1:2*ncv*ncv+3*ncv) := rotation matrix Q | c | workl(2*ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) := workspace | c | The final workspace is needed by subroutine dneigh called | c | by dnaup2. Subroutine dneigh calls LAPACK routines for | c | calculating eigenvalues and the last row of the eigenvector | c | matrix. | c %-------------------------------------------------------------% c ldh = ncv ldq = ncv ih = 1 ritzr = ih + ldh*ncv ritzi = ritzr + ncv bounds = ritzi + ncv iq = bounds + ncv iw = iq + ldq*ncv next = iw + ncv**2 + 3*ncv c ipntr(4) = next ipntr(5) = ih ipntr(6) = ritzr ipntr(7) = ritzi ipntr(8) = bounds ipntr(14) = iw c end if c c %-------------------------------------------------------% c | Carry out the Implicitly restarted Arnoldi Iteration. | c %-------------------------------------------------------% c call dnaup2 & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritzr), & workl(ritzi), workl(bounds), workl(iq), ldq, workl(iw), & ipntr, workd, info ) c c %--------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP or shifts. | c %--------------------------------------------------% c if (ido .eq. 3) iparam(8) = np if (ido .ne. 99) go to 9000 c iparam(3) = mxiter iparam(5) = np iparam(9) = nopx iparam(10) = nbx iparam(11) = nrorth c c %------------------------------------% c | Exit if there was an informational | c | error within dnaup2. | c %------------------------------------% c if (info .lt. 0) go to 9000 if (info .eq. 2) info = 3 c if (msglvl .gt. 0) then call ivout (logfil, 1, mxiter, ndigit, & '_naupd: Number of update iterations taken') call ivout (logfil, 1, np, ndigit, & '_naupd: Number of wanted "converged" Ritz values') call dvout (logfil, np, workl(ritzr), ndigit, & '_naupd: Real part of the final Ritz values') call dvout (logfil, np, workl(ritzi), ndigit, & '_naupd: Imaginary part of the final Ritz values') call dvout (logfil, np, workl(bounds), ndigit, & '_naupd: Associated Ritz estimates') end if c call second (t1) tnaupd = t1 - t0 c if (msglvl .gt. 0) then c c %--------------------------------------------------------% c | Version Number & Version Date are defined in version.h | c %--------------------------------------------------------% c write (6,1000) write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, & tmvopx, tmvbx, tnaupd, tnaup2, tnaitr, titref, & tgetv0, tneigh, tngets, tnapps, tnconv, trvec 1000 format (//, & 5x, '=============================================',/ & 5x, '= Nonsymmetric implicit Arnoldi update code =',/ & 5x, '= Version Number: ', ' 2.4', 21x, ' =',/ & 5x, '= Version Date: ', ' 07/31/96', 16x, ' =',/ & 5x, '=============================================',/ & 5x, '= Summary of timing statistics =',/ & 5x, '=============================================',//) 1100 format ( & 5x, 'Total number update iterations = ', i5,/ & 5x, 'Total number of OP*x operations = ', i5,/ & 5x, 'Total number of B*x operations = ', i5,/ & 5x, 'Total number of reorthogonalization steps = ', i5,/ & 5x, 'Total number of iterative refinement steps = ', i5,/ & 5x, 'Total number of restart steps = ', i5,/ & 5x, 'Total time in user OP*x operation = ', f12.6,/ & 5x, 'Total time in user B*x operation = ', f12.6,/ & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ & 5x, 'Total time in naup2 routine = ', f12.6,/ & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ & 5x, 'Total time in (re)start vector generation = ', f12.6,/ & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ & 5x, 'Total time in getting the shifts = ', f12.6,/ & 5x, 'Total time in applying the shifts = ', f12.6,/ & 5x, 'Total time in convergence testing = ', f12.6,/ & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) end if c 9000 continue c return c c %---------------% c | End of dnaupd | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/znapps.f000644 001750 001750 00000042331 11266605602 022132 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: znapps c c\Description: c Given the Arnoldi factorization c c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, c c apply NP implicit shifts resulting in c c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q c c where Q is an orthogonal matrix which is the product of rotations c and reflections resulting from the NP bulge change sweeps. c The updated Arnoldi factorization becomes: c c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. c c\Usage: c call znapps c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, c WORKL, WORKD ) c c\Arguments c N Integer. (INPUT) c Problem size, i.e. size of matrix A. c c KEV Integer. (INPUT/OUTPUT) c KEV+NP is the size of the input matrix H. c KEV is the size of the updated matrix HNEW. c c NP Integer. (INPUT) c Number of implicit shifts to be applied. c c SHIFT Complex*16 array of length NP. (INPUT) c The shifts to be applied. c c V Complex*16 N by (KEV+NP) array. (INPUT/OUTPUT) c On INPUT, V contains the current KEV+NP Arnoldi vectors. c On OUTPUT, V contains the updated KEV Arnoldi vectors c in the first KEV columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Complex*16 (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) c On INPUT, H contains the current KEV+NP by KEV+NP upper c Hessenberg matrix of the Arnoldi factorization. c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg c matrix in the KEV leading submatrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RESID Complex*16 array of length N. (INPUT/OUTPUT) c On INPUT, RESID contains the the residual vector r_{k+p}. c On OUTPUT, RESID is the update residual vector rnew_{k} c in the first KEV locations. c c Q Complex*16 KEV+NP by KEV+NP work array. (WORKSPACE) c Work array used to accumulate the rotations and reflections c during the bulge chase sweep. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Complex*16 work array of length (KEV+NP). (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c WORKD Complex*16 work array of length 2*N. (WORKSPACE) c Distributed array used in the application of the accumulated c orthogonal matrix Q. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex*16 c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c c\Routines called: c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c zmout ARPACK utility routine that prints matrices c zvout ARPACK utility routine that prints vectors. c zlacpy LAPACK matrix copy routine. c zlanhs LAPACK routine that computes various norms of a matrix. c zlartg LAPACK Givens rotation construction routine. c zlaset LAPACK matrix initialization routine. c dlabad LAPACK routine for defining the underflow and overflow c limits. c dlamch LAPACK routine that determines machine constants. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c zgemv Level 2 BLAS routine for matrix vector multiplication. c zaxpy Level 1 BLAS that computes a vector triad. c zcopy Level 1 BLAS that copies one vector to another. c zscal Level 1 BLAS that scales a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: napps.F SID: 2.3 DATE OF SID: 3/28/97 RELEASE: 2 c c\Remarks c 1. In this version, each shift is applied to all the sublocks of c the Hessenberg matrix H and not just to the submatrix that it c comes from. Deflation as in LAPACK routine zlahqr (QR algorithm c for upper Hessenberg matrices ) is used. c Upon output, the subdiagonals of H are enforced to be non-negative c real numbers. c c\EndLib c c----------------------------------------------------------------------- c subroutine znapps & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, & workl, workd ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer kev, ldh, ldq, ldv, n, np c c %-----------------% c | Array Arguments | c %-----------------% c Complex*16 & h(ldh,kev+np), resid(n), shift(np), & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero Double precision & rzero parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0), & rzero = 0.0D+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c integer i, iend, istart, j, jj, kplusp, msglvl logical first Complex*16 & cdum, f, g, h11, h21, r, s, sigma, t Double precision & c, ovfl, smlnum, ulp, unfl, tst1 save first, ovfl, smlnum, ulp, unfl c c %----------------------% c | External Subroutines | c %----------------------% c external zaxpy, zcopy, zgemv, zscal, zlacpy, zlartg, & zvout, zlaset, dlabad, zmout, second, ivout c c %--------------------% c | External Functions | c %--------------------% c Double precision & zlanhs, dlamch, dlapy2 external zlanhs, dlamch, dlapy2 c c %----------------------% c | Intrinsics Functions | c %----------------------% c intrinsic abs, dimag, conjg, dcmplx, max, min, dble c c %---------------------% c | Statement Functions | c %---------------------% c Double precision & zabs1 zabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) ) c c %----------------% c | Data statments | c %----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then c c %-----------------------------------------------% c | Set machine-dependent constants for the | c | stopping criterion. If norm(H) <= sqrt(OVFL), | c | overflow should not occur. | c | REFERENCE: LAPACK subroutine zlahqr | c %-----------------------------------------------% c unfl = dlamch( 'safe minimum' ) ovfl = dble(one / unfl) call dlabad( unfl, ovfl ) ulp = dlamch( 'precision' ) smlnum = unfl*( n / ulp ) first = .false. end if c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mcapps c kplusp = kev + np c c %--------------------------------------------% c | Initialize Q to the identity to accumulate | c | the rotations and reflections | c %--------------------------------------------% c call zlaset ('All', kplusp, kplusp, zero, one, q, ldq) c c %----------------------------------------------% c | Quick return if there are no shifts to apply | c %----------------------------------------------% c if (np .eq. 0) go to 9000 c c %----------------------------------------------% c | Chase the bulge with the application of each | c | implicit shift. Each shift is applied to the | c | whole matrix including each block. | c %----------------------------------------------% c do 110 jj = 1, np sigma = shift(jj) c if (msglvl .gt. 2 ) then call ivout (logfil, 1, jj, ndigit, & '_napps: shift number.') call zvout (logfil, 1, sigma, ndigit, & '_napps: Value of the shift ') end if c istart = 1 20 continue c do 30 i = istart, kplusp-1 c c %----------------------------------------% c | Check for splitting and deflation. Use | c | a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine zlahqr | c %----------------------------------------% c tst1 = zabs1( h( i, i ) ) + zabs1( h( i+1, i+1 ) ) if( tst1.eq.rzero ) & tst1 = zlanhs( '1', kplusp-jj+1, h, ldh, workl ) if ( abs(dble(h(i+1,i))) & .le. max(ulp*tst1, smlnum) ) then if (msglvl .gt. 0) then call ivout (logfil, 1, i, ndigit, & '_napps: matrix splitting at row/column no.') call ivout (logfil, 1, jj, ndigit, & '_napps: matrix splitting with shift number.') call zvout (logfil, 1, h(i+1,i), ndigit, & '_napps: off diagonal element.') end if iend = i h(i+1,i) = zero go to 40 end if 30 continue iend = kplusp 40 continue c if (msglvl .gt. 2) then call ivout (logfil, 1, istart, ndigit, & '_napps: Start of current block ') call ivout (logfil, 1, iend, ndigit, & '_napps: End of current block ') end if c c %------------------------------------------------% c | No reason to apply a shift to block of order 1 | c | or if the current block starts after the point | c | of compression since we'll discard this stuff | c %------------------------------------------------% c if ( istart .eq. iend .or. istart .gt. kev) go to 100 c h11 = h(istart,istart) h21 = h(istart+1,istart) f = h11 - sigma g = h21 c do 80 i = istart, iend-1 c c %------------------------------------------------------% c | Construct the plane rotation G to zero out the bulge | c %------------------------------------------------------% c call zlartg (f, g, c, s, r) if (i .gt. istart) then h(i,i-1) = r h(i+1,i-1) = zero end if c c %---------------------------------------------% c | Apply rotation to the left of H; H <- G'*H | c %---------------------------------------------% c do 50 j = i, kplusp t = c*h(i,j) + s*h(i+1,j) h(i+1,j) = -conjg(s)*h(i,j) + c*h(i+1,j) h(i,j) = t 50 continue c c %---------------------------------------------% c | Apply rotation to the right of H; H <- H*G | c %---------------------------------------------% c do 60 j = 1, min(i+2,iend) t = c*h(j,i) + conjg(s)*h(j,i+1) h(j,i+1) = -s*h(j,i) + c*h(j,i+1) h(j,i) = t 60 continue c c %-----------------------------------------------------% c | Accumulate the rotation in the matrix Q; Q <- Q*G' | c %-----------------------------------------------------% c do 70 j = 1, min(i+jj, kplusp) t = c*q(j,i) + conjg(s)*q(j,i+1) q(j,i+1) = - s*q(j,i) + c*q(j,i+1) q(j,i) = t 70 continue c c %---------------------------% c | Prepare for next rotation | c %---------------------------% c if (i .lt. iend-1) then f = h(i+1,i) g = h(i+2,i) end if 80 continue c c %-------------------------------% c | Finished applying the shift. | c %-------------------------------% c 100 continue c c %---------------------------------------------------------% c | Apply the same shift to the next block if there is any. | c %---------------------------------------------------------% c istart = iend + 1 if (iend .lt. kplusp) go to 20 c c %---------------------------------------------% c | Loop back to the top to get the next shift. | c %---------------------------------------------% c 110 continue c c %---------------------------------------------------% c | Perform a similarity transformation that makes | c | sure that the compressed H will have non-negative | c | real subdiagonal elements. | c %---------------------------------------------------% c do 120 j=1,kev if ( dble( h(j+1,j) ) .lt. rzero .or. & dimag( h(j+1,j) ) .ne. rzero ) then t = h(j+1,j) / dlapy2(dble(h(j+1,j)),dimag(h(j+1,j))) call zscal( kplusp-j+1, conjg(t), h(j+1,j), ldh ) call zscal( min(j+2, kplusp), t, h(1,j+1), 1 ) call zscal( min(j+np+1,kplusp), t, q(1,j+1), 1 ) h(j+1,j) = dcmplx( dble( h(j+1,j) ), rzero ) end if 120 continue c do 130 i = 1, kev c c %--------------------------------------------% c | Final check for splitting and deflation. | c | Use a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine zlahqr. | c | Note: Since the subdiagonals of the | c | compressed H are nonnegative real numbers, | c | we take advantage of this. | c %--------------------------------------------% c tst1 = zabs1( h( i, i ) ) + zabs1( h( i+1, i+1 ) ) if( tst1 .eq. rzero ) & tst1 = zlanhs( '1', kev, h, ldh, workl ) if( dble( h( i+1,i ) ) .le. max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 130 continue c c %-------------------------------------------------% c | Compute the (kev+1)-st column of (V*Q) and | c | temporarily store the result in WORKD(N+1:2*N). | c | This is needed in the residual update since we | c | cannot GUARANTEE that the corresponding entry | c | of H would be zero as in exact arithmetic. | c %-------------------------------------------------% c if ( dble( h(kev+1,kev) ) .gt. rzero ) & call zgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, & workd(n+1), 1) c c %----------------------------------------------------------% c | Compute column 1 to kev of (V*Q) in backward order | c | taking advantage of the upper Hessenberg structure of Q. | c %----------------------------------------------------------% c do 140 i = 1, kev call zgemv ('N', n, kplusp-i+1, one, v, ldv, & q(1,kev-i+1), 1, zero, workd, 1) call zcopy (n, workd, 1, v(1,kplusp-i+1), 1) 140 continue c c %-------------------------------------------------% c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | c %-------------------------------------------------% c call zlacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv) c c %--------------------------------------------------------------% c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | c %--------------------------------------------------------------% c if ( dble( h(kev+1,kev) ) .gt. rzero ) & call zcopy (n, workd(n+1), 1, v(1,kev+1), 1) c c %-------------------------------------% c | Update the residual vector: | c | r <- sigmak*r + betak*v(:,kev+1) | c | where | c | sigmak = (e_{kev+p}'*Q)*e_{kev} | c | betak = e_{kev+1}'*H*e_{kev} | c %-------------------------------------% c call zscal (n, q(kplusp,kev), resid, 1) if ( dble( h(kev+1,kev) ) .gt. rzero ) & call zaxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) c if (msglvl .gt. 1) then call zvout (logfil, 1, q(kplusp,kev), ndigit, & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') call zvout (logfil, 1, h(kev+1,kev), ndigit, & '_napps: betak = e_{kev+1}^T*H*e_{kev}') call ivout (logfil, 1, kev, ndigit, & '_napps: Order of the final Hessenberg matrix ') if (msglvl .gt. 2) then call zmout (logfil, kev, kev, h, ldh, ndigit, & '_napps: updated Hessenberg matrix H for next iteration') end if c end if c 9000 continue call second (t1) tcapps = tcapps + (t1 - t0) c return c c %---------------% c | End of znapps | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dsaitr.f000644 001750 001750 00000074133 11266605602 022112 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dsaitr c c\Description: c Reverse communication interface for applying NP additional steps to c a K step symmetric Arnoldi factorization. c c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T c c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. c c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T c c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. c c where OP and B are as in dsaupd. The B-norm of r_{k+p} is also c computed and returned. c c\Usage: c call dsaitr c ( IDO, BMAT, N, K, NP, MODE, RESID, RNORM, V, LDV, H, LDH, c IPNTR, WORKD, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c This is for the restart phase to force the new c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y, c IPNTR(3) is the pointer into WORK for B * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c IDO = 99: done c ------------------------------------------------------------- c When the routine is used in the "shift-and-invert" mode, the c vector B * Q is already available and does not need to be c recomputed in forming OP * Q. c c BMAT Character*1. (INPUT) c BMAT specifies the type of matrix B that defines the c semi-inner product for the operator OP. See dsaupd. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*M*x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c K Integer. (INPUT) c Current order of H and the number of columns of V. c c NP Integer. (INPUT) c Number of additional Arnoldi steps to take. c c MODE Integer. (INPUT) c Signifies which form for "OP". If MODE=2 then c a reduction in the number of B matrix vector multiplies c is possible since the B-norm of OP*x is equivalent to c the inv(B)-norm of A*x. c c RESID Double precision array of length N. (INPUT/OUTPUT) c On INPUT: RESID contains the residual vector r_{k}. c On OUTPUT: RESID contains the residual vector r_{k+p}. c c RNORM Double precision scalar. (INPUT/OUTPUT) c On INPUT the B-norm of r_{k}. c On OUTPUT the B-norm of the updated residual r_{k+p}. c c V Double precision N by K+NP array. (INPUT/OUTPUT) c On INPUT: V contains the Arnoldi vectors in the first K c columns. c On OUTPUT: V contains the new NP Arnoldi vectors in the next c NP columns. The first K columns are unchanged. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Double precision (K+NP) by 2 array. (INPUT/OUTPUT) c H is used to store the generated symmetric tridiagonal matrix c with the subdiagonal in the first column starting at H(2,1) c and the main diagonal in the second column. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORK for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The calling program should not c use WORKD as temporary workspace during the iteration !!!!!! c On INPUT, WORKD(1:N) = B*RESID where RESID is associated c with the K step Arnoldi factorization. Used to save some c computation at the first step. c On OUTPUT, WORKD(1:N) = B*RESID where RESID is associated c with the K+NP step Arnoldi factorization. c c INFO Integer. (OUTPUT) c = 0: Normal exit. c > 0: Size of an invariant subspace of OP is found that is c less than K + NP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c dgetv0 ARPACK routine to generate the initial vector. c ivout ARPACK utility routine that prints integers. c dmout ARPACK utility routine that prints matrices. c dvout ARPACK utility routine that prints vectors. c dlamch LAPACK routine that determines machine constants. c dlascl LAPACK routine for careful scaling of a matrix. c dgemv Level 2 BLAS routine for matrix vector multiplication. c daxpy Level 1 BLAS that computes a vector triad. c dscal Level 1 BLAS that scales a vector. c dcopy Level 1 BLAS that copies one vector to another . c ddot Level 1 BLAS that computes the scalar product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/93: Version ' 2.4' c c\SCCS Information: @(#) c FILE: saitr.F SID: 2.6 DATE OF SID: 8/28/96 RELEASE: 2 c c\Remarks c The algorithm implemented is: c c restart = .false. c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; c r_{k} contains the initial residual vector even for k = 0; c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already c computed by the calling program. c c betaj = rnorm ; p_{k+1} = B*r_{k} ; c For j = k+1, ..., k+np Do c 1) if ( betaj < tol ) stop or restart depending on j. c if ( restart ) generate a new starting vector. c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; c p_{j} = p_{j}/betaj c 3) r_{j} = OP*v_{j} where OP is defined as in dsaupd c For shift-invert mode p_{j} = B*v_{j} is already available. c wnorm = || OP*v_{j} || c 4) Compute the j-th step residual vector. c w_{j} = V_{j}^T * B * OP * v_{j} c r_{j} = OP*v_{j} - V_{j} * w_{j} c alphaj <- j-th component of w_{j} c rnorm = || r_{j} || c betaj+1 = rnorm c If (rnorm > 0.717*wnorm) accept step and go back to 1) c 5) Re-orthogonalization step: c s = V_{j}'*B*r_{j} c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || c alphaj = alphaj + s_{j}; c 6) Iterative refinement step: c If (rnorm1 > 0.717*rnorm) then c rnorm = rnorm1 c accept step and go back to 1) c Else c rnorm = rnorm1 c If this is the first time in step 6), go to 5) c Else r_{j} lies in the span of V_{j} numerically. c Set r_{j} = 0 and rnorm = 0; go to 1) c EndIf c End Do c c\EndLib c c----------------------------------------------------------------------- c subroutine dsaitr & (ido, bmat, n, k, np, mode, resid, rnorm, v, ldv, h, ldh, & ipntr, workd, info) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 integer ido, info, k, ldh, ldv, n, mode, np Double precision & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Double precision & h(ldh,2), resid(n), v(ldv,k+np), workd(3*n) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %---------------% c | Local Scalars | c %---------------% c logical first, orth1, orth2, rstart, step3, step4 integer i, ierr, ipj, irj, ivj, iter, itry, j, msglvl, & infol, jj Double precision & rnorm1, wnorm, safmin, temp1 save orth1, orth2, rstart, step3, step4, & ierr, ipj, irj, ivj, iter, itry, j, msglvl, & rnorm1, safmin, wnorm c c %-----------------------% c | Local Array Arguments | c %-----------------------% c Double precision & xtemp(2) c c %----------------------% c | External Subroutines | c %----------------------% c external daxpy, dcopy, dscal, dgemv, dgetv0, dvout, dmout, & dlascl, ivout, second c c %--------------------% c | External Functions | c %--------------------% c Double precision & ddot, dnrm2, dlamch external ddot, dnrm2, dlamch c c %-----------------% c | Data statements | c %-----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then first = .false. c c %--------------------------------% c | safmin = safe minimum is such | c | that 1/sfmin does not overflow | c %--------------------------------% c safmin = dlamch('safmin') end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = msaitr c c %------------------------------% c | Initial call to this routine | c %------------------------------% c info = 0 step3 = .false. step4 = .false. rstart = .false. orth1 = .false. orth2 = .false. c c %--------------------------------% c | Pointer to the current step of | c | the factorization to build | c %--------------------------------% c j = k + 1 c c %------------------------------------------% c | Pointers used for reverse communication | c | when using WORKD. | c %------------------------------------------% c ipj = 1 irj = ipj + n ivj = irj + n end if c c %-------------------------------------------------% c | When in reverse communication mode one of: | c | STEP3, STEP4, ORTH1, ORTH2, RSTART | c | will be .true. | c | STEP3: return from computing OP*v_{j}. | c | STEP4: return from computing B-norm of OP*v_{j} | c | ORTH1: return from computing B-norm of r_{j+1} | c | ORTH2: return from computing B-norm of | c | correction to the residual vector. | c | RSTART: return from OP computations needed by | c | dgetv0. | c %-------------------------------------------------% c if (step3) go to 50 if (step4) go to 60 if (orth1) go to 70 if (orth2) go to 90 if (rstart) go to 30 c c %------------------------------% c | Else this is the first step. | c %------------------------------% c c %--------------------------------------------------------------% c | | c | A R N O L D I I T E R A T I O N L O O P | c | | c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | c %--------------------------------------------------------------% c 1000 continue c if (msglvl .gt. 2) then call ivout (logfil, 1, j, ndigit, & '_saitr: generating Arnoldi vector no.') call dvout (logfil, 1, rnorm, ndigit, & '_saitr: B-norm of the current residual =') end if c c %---------------------------------------------------------% c | Check for exact zero. Equivalent to determing whether a | c | j-step Arnoldi factorization is present. | c %---------------------------------------------------------% c if (rnorm .gt. zero) go to 40 c c %---------------------------------------------------% c | Invariant subspace found, generate a new starting | c | vector which is orthogonal to the current Arnoldi | c | basis and continue the iteration. | c %---------------------------------------------------% c if (msglvl .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_saitr: ****** restart at step ******') end if c c %---------------------------------------------% c | ITRY is the loop variable that controls the | c | maximum amount of times that a restart is | c | attempted. NRSTRT is used by stat.h | c %---------------------------------------------% c nrstrt = nrstrt + 1 itry = 1 20 continue rstart = .true. ido = 0 30 continue c c %--------------------------------------% c | If in reverse communication mode and | c | RSTART = .true. flow returns here. | c %--------------------------------------% c call dgetv0 (ido, bmat, itry, .false., n, j, v, ldv, & resid, rnorm, ipntr, workd, ierr) if (ido .ne. 99) go to 9000 if (ierr .lt. 0) then itry = itry + 1 if (itry .le. 3) go to 20 c c %------------------------------------------------% c | Give up after several restart attempts. | c | Set INFO to the size of the invariant subspace | c | which spans OP and exit. | c %------------------------------------------------% c info = j - 1 call second (t1) tsaitr = tsaitr + (t1 - t0) ido = 99 go to 9000 end if c 40 continue c c %---------------------------------------------------------% c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | c | when reciprocating a small RNORM, test against lower | c | machine bound. | c %---------------------------------------------------------% c call dcopy (n, resid, 1, v(1,j), 1) if (rnorm .ge. safmin) then temp1 = one / rnorm call dscal (n, temp1, v(1,j), 1) call dscal (n, temp1, workd(ipj), 1) else c c %-----------------------------------------% c | To scale both v_{j} and p_{j} carefully | c | use LAPACK routine SLASCL | c %-----------------------------------------% c call dlascl ('General', i, i, rnorm, one, n, 1, & v(1,j), n, infol) call dlascl ('General', i, i, rnorm, one, n, 1, & workd(ipj), n, infol) end if c c %------------------------------------------------------% c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | c | Note that this is not quite yet r_{j}. See STEP 4 | c %------------------------------------------------------% c step3 = .true. nopx = nopx + 1 call second (t2) call dcopy (n, v(1,j), 1, workd(ivj), 1) ipntr(1) = ivj ipntr(2) = irj ipntr(3) = ipj ido = 1 c c %-----------------------------------% c | Exit in order to compute OP*v_{j} | c %-----------------------------------% c go to 9000 50 continue c c %-----------------------------------% c | Back from reverse communication; | c | WORKD(IRJ:IRJ+N-1) := OP*v_{j}. | c %-----------------------------------% c call second (t3) tmvopx = tmvopx + (t3 - t2) c step3 = .false. c c %------------------------------------------% c | Put another copy of OP*v_{j} into RESID. | c %------------------------------------------% c call dcopy (n, workd(irj), 1, resid, 1) c c %-------------------------------------------% c | STEP 4: Finish extending the symmetric | c | Arnoldi to length j. If MODE = 2 | c | then B*OP = B*inv(B)*A = A and | c | we don't need to compute B*OP. | c | NOTE: If MODE = 2 WORKD(IVJ:IVJ+N-1) is | c | assumed to have A*v_{j}. | c %-------------------------------------------% c if (mode .eq. 2) go to 65 call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 step4 = .true. ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-------------------------------------% c | Exit in order to compute B*OP*v_{j} | c %-------------------------------------% c go to 9000 else if (bmat .eq. 'I') then call dcopy(n, resid, 1 , workd(ipj), 1) end if 60 continue c c %-----------------------------------% c | Back from reverse communication; | c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j}. | c %-----------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c step4 = .false. c c %-------------------------------------% c | The following is needed for STEP 5. | c | Compute the B-norm of OP*v_{j}. | c %-------------------------------------% c 65 continue if (mode .eq. 2) then c c %----------------------------------% c | Note that the B-norm of OP*v_{j} | c | is the inv(B)-norm of A*v_{j}. | c %----------------------------------% c wnorm = ddot (n, resid, 1, workd(ivj), 1) wnorm = sqrt(abs(wnorm)) else if (bmat .eq. 'G') then wnorm = ddot (n, resid, 1, workd(ipj), 1) wnorm = sqrt(abs(wnorm)) else if (bmat .eq. 'I') then wnorm = dnrm2(n, resid, 1) end if c c %-----------------------------------------% c | Compute the j-th residual corresponding | c | to the j step factorization. | c | Use Classical Gram Schmidt and compute: | c | w_{j} <- V_{j}^T * B * OP * v_{j} | c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | c %-----------------------------------------% c c c %------------------------------------------% c | Compute the j Fourier coefficients w_{j} | c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | c %------------------------------------------% c if (mode .ne. 2 ) then call dgemv('T', n, j, one, v, ldv, workd(ipj), 1, zero, & workd(irj), 1) else if (mode .eq. 2) then call dgemv('T', n, j, one, v, ldv, workd(ivj), 1, zero, & workd(irj), 1) end if c c %--------------------------------------% c | Orthgonalize r_{j} against V_{j}. | c | RESID contains OP*v_{j}. See STEP 3. | c %--------------------------------------% c call dgemv('N', n, j, -one, v, ldv, workd(irj), 1, one, & resid, 1) c c %--------------------------------------% c | Extend H to have j rows and columns. | c %--------------------------------------% c h(j,2) = workd(irj + j - 1) if (j .eq. 1 .or. rstart) then h(j,1) = zero else h(j,1) = rnorm end if call second (t4) c orth1 = .true. iter = 0 c call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call dcopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %----------------------------------% c | Exit in order to compute B*r_{j} | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd(ipj), 1) end if 70 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH1 = .true. | c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c orth1 = .false. c c %------------------------------% c | Compute the B-norm of r_{j}. | c %------------------------------% c if (bmat .eq. 'G') then rnorm = ddot (n, resid, 1, workd(ipj), 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = dnrm2(n, resid, 1) end if c c %-----------------------------------------------------------% c | STEP 5: Re-orthogonalization / Iterative refinement phase | c | Maximum NITER_ITREF tries. | c | | c | s = V_{j}^T * B * r_{j} | c | r_{j} = r_{j} - V_{j}*s | c | alphaj = alphaj + s_{j} | c | | c | The stopping criteria used for iterative refinement is | c | discussed in Parlett's book SEP, page 107 and in Gragg & | c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | c | Determine if we need to correct the residual. The goal is | c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | c %-----------------------------------------------------------% c if (rnorm .gt. 0.717*wnorm) go to 100 nrorth = nrorth + 1 c c %---------------------------------------------------% c | Enter the Iterative refinement phase. If further | c | refinement is necessary, loop back here. The loop | c | variable is ITER. Perform a step of Classical | c | Gram-Schmidt using all the Arnoldi vectors V_{j} | c %---------------------------------------------------% c 80 continue c if (msglvl .gt. 2) then xtemp(1) = wnorm xtemp(2) = rnorm call dvout (logfil, 2, xtemp, ndigit, & '_saitr: re-orthonalization ; wnorm and rnorm are') end if c c %----------------------------------------------------% c | Compute V_{j}^T * B * r_{j}. | c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | c %----------------------------------------------------% c call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1, & zero, workd(irj), 1) c c %----------------------------------------------% c | Compute the correction to the residual: | c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | c | The correction to H is v(:,1:J)*H(1:J,1:J) + | c | v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j, but only | c | H(j,j) is updated. | c %----------------------------------------------% c call dgemv ('N', n, j, -one, v, ldv, workd(irj), 1, & one, resid, 1) c if (j .eq. 1 .or. rstart) h(j,1) = zero h(j,2) = h(j,2) + workd(irj + j - 1) c orth2 = .true. call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call dcopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-----------------------------------% c | Exit in order to compute B*r_{j}. | c | r_{j} is the corrected residual. | c %-----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd(ipj), 1) end if 90 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH2 = .true. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c c %-----------------------------------------------------% c | Compute the B-norm of the corrected residual r_{j}. | c %-----------------------------------------------------% c if (bmat .eq. 'G') then rnorm1 = ddot (n, resid, 1, workd(ipj), 1) rnorm1 = sqrt(abs(rnorm1)) else if (bmat .eq. 'I') then rnorm1 = dnrm2(n, resid, 1) end if c if (msglvl .gt. 0 .and. iter .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_saitr: Iterative refinement for Arnoldi residual') if (msglvl .gt. 2) then xtemp(1) = rnorm xtemp(2) = rnorm1 call dvout (logfil, 2, xtemp, ndigit, & '_saitr: iterative refinement ; rnorm and rnorm1 are') end if end if c c %-----------------------------------------% c | Determine if we need to perform another | c | step of re-orthogonalization. | c %-----------------------------------------% c if (rnorm1 .gt. 0.717*rnorm) then c c %--------------------------------% c | No need for further refinement | c %--------------------------------% c rnorm = rnorm1 c else c c %-------------------------------------------% c | Another step of iterative refinement step | c | is required. NITREF is used by stat.h | c %-------------------------------------------% c nitref = nitref + 1 rnorm = rnorm1 iter = iter + 1 if (iter .le. 1) go to 80 c c %-------------------------------------------------% c | Otherwise RESID is numerically in the span of V | c %-------------------------------------------------% c do 95 jj = 1, n resid(jj) = zero 95 continue rnorm = zero end if c c %----------------------------------------------% c | Branch here directly if iterative refinement | c | wasn't necessary or after at most NITER_REF | c | steps of iterative refinement. | c %----------------------------------------------% c 100 continue c rstart = .false. orth2 = .false. c call second (t5) titref = titref + (t5 - t4) c c %----------------------------------------------------------% c | Make sure the last off-diagonal element is non negative | c | If not perform a similarity transformation on H(1:j,1:j) | c | and scale v(:,j) by -1. | c %----------------------------------------------------------% c if (h(j,1) .lt. zero) then h(j,1) = -h(j,1) if ( j .lt. k+np) then call dscal(n, -one, v(1,j+1), 1) else call dscal(n, -one, resid, 1) end if end if c c %------------------------------------% c | STEP 6: Update j = j+1; Continue | c %------------------------------------% c j = j + 1 if (j .gt. k+np) then call second (t1) tsaitr = tsaitr + (t1 - t0) ido = 99 c if (msglvl .gt. 1) then call dvout (logfil, k+np, h(1,2), ndigit, & '_saitr: main diagonal of matrix H of step K+NP.') if (k+np .gt. 1) then call dvout (logfil, k+np-1, h(2,1), ndigit, & '_saitr: sub diagonal of matrix H of step K+NP.') end if end if c go to 9000 end if c c %--------------------------------------------------------% c | Loop back to extend the factorization by another step. | c %--------------------------------------------------------% c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 9000 continue return c c %---------------% c | End of dsaitr | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/zmout.f000644 001750 001750 00000021074 11266605602 021776 0ustar00geuzainegeuzaine000000 000000 * * Routine: ZMOUT * * Purpose: Complex*16 matrix output routine. * * Usage: CALL ZMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) * * Arguments * M - Number of rows of A. (Input) * N - Number of columns of A. (Input) * A - Complex*16 M by N matrix to be printed. (Input) * LDA - Leading dimension of A exactly as specified in the * dimension statement of the calling program. (Input) * IFMT - Format to be used in printing matrix A. (Input) * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) * If IDIGIT .LT. 0, printing is done with 72 columns. * If IDIGIT .GT. 0, printing is done with 132 columns. * *\SCCS Information: @(#) * FILE: zmout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2 * *----------------------------------------------------------------------- * SUBROUTINE ZMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) * ... * ... SPECIFICATIONS FOR ARGUMENTS INTEGER M, N, IDIGIT, LDA, LOUT Complex*16 & A( LDA, * ) CHARACTER IFMT*( * ) * ... * ... SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I, J, NDIGIT, K1, K2, LLL CHARACTER*1 ICOL( 3 ) CHARACTER*80 LINE * ... * ... SPECIFICATIONS INTRINSICS INTRINSIC MIN * DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', $ 'l' / * ... * ... FIRST EXECUTABLE STATEMENT * LLL = MIN( LEN( IFMT ), 80 ) DO 10 I = 1, LLL LINE( I: I ) = '-' 10 CONTINUE * DO 20 I = LLL + 1, 80 LINE( I: I ) = ' ' 20 CONTINUE * WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) 9999 FORMAT( / 1X, A / 1X, A ) * IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) $ RETURN NDIGIT = IDIGIT IF( IDIGIT.EQ.0 ) $ NDIGIT = 4 * *======================================================================= * CODE FOR OUTPUT USING 72 COLUMNS FORMAT *======================================================================= * IF( IDIGIT.LT.0 ) THEN NDIGIT = -IDIGIT IF( NDIGIT.LE.4 ) THEN DO 40 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) DO 30 I = 1, M IF (K1.NE.N) THEN WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 ) ELSE WRITE( LOUT, 9984 )I, ( A( I, J ), J = K1, K2 ) END IF 30 CONTINUE 40 CONTINUE * ELSE IF( NDIGIT.LE.6 ) THEN DO 60 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) DO 50 I = 1, M IF (K1.NE.N) THEN WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 ) ELSE WRITE( LOUT, 9983 )I, ( A( I, J ), J = K1, K2 ) END IF 50 CONTINUE 60 CONTINUE * ELSE IF( NDIGIT.LE.8 ) THEN DO 80 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) DO 70 I = 1, M IF (K1.NE.N) THEN WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 ) ELSE WRITE( LOUT, 9982 )I, ( A( I, J ), J = K1, K2 ) END IF 70 CONTINUE 80 CONTINUE * ELSE DO 100 K1 = 1, N WRITE( LOUT, 9995 ) ICOL, K1 DO 90 I = 1, M WRITE( LOUT, 9991 )I, A( I, K1 ) 90 CONTINUE 100 CONTINUE END IF * *======================================================================= * CODE FOR OUTPUT USING 132 COLUMNS FORMAT *======================================================================= * ELSE IF( NDIGIT.LE.4 ) THEN DO 120 K1 = 1, N, 4 K2 = MIN0( N, K1+3 ) WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) DO 110 I = 1, M IF ((K1+3).LE.N) THEN WRITE( LOUT, 9974 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+3-N).EQ.1) THEN WRITE( LOUT, 9964 )I, ( A( I, J ), J = k1, K2 ) ELSE IF ((K1+3-N).EQ.2) THEN WRITE( LOUT, 9954 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+3-N).EQ.3) THEN WRITE( LOUT, 9944 )I, ( A( I, J ), J = K1, K2 ) END IF 110 CONTINUE 120 CONTINUE * ELSE IF( NDIGIT.LE.6 ) THEN DO 140 K1 = 1, N, 3 K2 = MIN0( N, K1+ 2) WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) DO 130 I = 1, M IF ((K1+2).LE.N) THEN WRITE( LOUT, 9973 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+2-N).EQ.1) THEN WRITE( LOUT, 9963 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+2-N).EQ.2) THEN WRITE( LOUT, 9953 )I, ( A( I, J ), J = K1, K2 ) END IF 130 CONTINUE 140 CONTINUE * ELSE IF( NDIGIT.LE.8 ) THEN DO 160 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) DO 150 I = 1, M IF ((K1+2).LE.N) THEN WRITE( LOUT, 9972 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+2-N).EQ.1) THEN WRITE( LOUT, 9962 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+2-N).EQ.2) THEN WRITE( LOUT, 9952 )I, ( A( I, J ), J = K1, K2 ) END IF 150 CONTINUE 160 CONTINUE * ELSE DO 180 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 ) DO 170 I = 1, M IF ((K1+1).LE.N) THEN WRITE( LOUT, 9971 )I, ( A( I, J ), J = K1, K2 ) ELSE WRITE( LOUT, 9961 )I, ( A( I, J ), J = K1, K2 ) END IF 170 CONTINUE 180 CONTINUE END IF END IF WRITE( LOUT, 9990 ) * 9998 FORMAT( 11X, 4( 9X, 3A1, I4, 9X ) ) 9997 FORMAT( 10X, 4( 11X, 3A1, I4, 11X ) ) 9996 FORMAT( 10X, 3( 13X, 3A1, I4, 13X ) ) 9995 FORMAT( 12X, 2( 18x, 3A1, I4, 18X ) ) * *======================================================== * FORMAT FOR 72 COLUMN *======================================================== * * DISPLAY 4 SIGNIFICANT DIGITS * 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D10.3,',',D10.3,') ') ) 9984 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D10.3,',',D10.3,') ') ) * * DISPLAY 6 SIGNIFICANT DIGITS * 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D12.5,',',D12.5,') ') ) 9983 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D12.5,',',D12.5,') ') ) * * DISPLAY 8 SIGNIFICANT DIGITS * 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D14.7,',',D14.7,') ') ) 9982 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D14.7,',',D14.7,') ') ) * * DISPLAY 13 SIGNIFICANT DIGITS * 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D20.13,',',D20.13,')') ) 9990 FORMAT( 1X, ' ' ) * * *======================================================== * FORMAT FOR 132 COLUMN *======================================================== * * DISPLAY 4 SIGNIFICANT DIGIT * 9974 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,4('(',D10.3,',',D10.3,') ') ) 9964 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',D10.3,',',D10.3,') ') ) 9954 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D10.3,',',D10.3,') ') ) 9944 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D10.3,',',D10.3,') ') ) * * DISPLAY 6 SIGNIFICANT DIGIT * 9973 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',D12.5,',',D12.5,') ') ) 9963 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D12.5,',',D12.5,') ') ) 9953 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D12.5,',',D12.5,') ') ) * * DISPLAY 8 SIGNIFICANT DIGIT * 9972 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',D14.7,',',D14.7,') ') ) 9962 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D14.7,',',D14.7,') ') ) 9952 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D14.7,',',D14.7,') ') ) * * DISPLAY 13 SIGNIFICANT DIGIT * 9971 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D20.13,',',D20.13, & ') ')) 9961 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D20.13,',',D20.13, & ') ')) * * * * RETURN END getdp-2.4.2-source/contrib/Arpack/sneupd.f000644 001750 001750 00000125775 11266605602 022133 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: sneupd c c\Description: c c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) The corresponding approximate eigenvectors; c c (2) An orthonormal basis for the associated approximate c invariant subspace; c c (3) Both. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c basis is always computed. There is an additional storage cost of n*nev c if both are requested (in this case a separate array Z must be supplied). c c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z c are derived from approximate eigenvalues and eigenvectors of c of the linear operator OP prescribed by the MODE selection in the c call to SNAUPD. SNAUPD must be called before this routine is called. c These approximate eigenvalues and vectors are commonly called Ritz c values and Ritz vectors respectively. They are referred to as such c in the comments that follow. The computed orthonormal basis for the c invariant subspace corresponding to these Ritz values is referred to as a c Schur basis. c c See documentation in the header of the subroutine SNAUPD for c definition of OP as well as other terms and the relation of computed c Ritz values and Ritz vectors of OP with respect to the given problem c A*z = lambda*B*z. For a brief description, see definitions of c IPARAM(7), MODE and WHICH in the documentation of SNAUPD. c c\Usage: c call sneupd c ( RVEC, HOWMNY, SELECT, DR, DI, Z, LDZ, SIGMAR, SIGMAI, WORKEV, BMAT, c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, c LWORKL, INFO ) c c\Arguments: c RVEC LOGICAL (INPUT) c Specifies whether a basis for the invariant subspace corresponding c to the converged Ritz value approximations for the eigenproblem c A*z = lambda*B*z is computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute the Ritz vectors or Schur vectors. c See Remarks below. c c HOWMNY Character*1 (INPUT) c Specifies the form of the basis for the invariant subspace c corresponding to the converged Ritz values that is to be computed. c c = 'A': Compute NEV Ritz vectors; c = 'P': Compute NEV Schur vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the Ritz vector corresponding to a c Ritz value (DR(j), DI(j)), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' or 'P', SELECT is used as internal workspace. c c DR Real array of dimension NEV+1. (OUTPUT) c If IPARAM(7) = 1,2 or 3 and SIGMAI=0.0 then on exit: DR contains c the real part of the Ritz approximations to the eigenvalues of c A*z = lambda*B*z. c If IPARAM(7) = 3, 4 and SIGMAI is not equal to zero, then on exit: c DR contains the real part of the Ritz values of OP computed by c SNAUPD. A further computation must be performed by the user c to transform the Ritz values computed for OP by SNAUPD to those c of the original system A*z = lambda*B*z. See remark 3 below. c c DI Real array of dimension NEV+1. (OUTPUT) c On exit, DI contains the imaginary part of the Ritz value c approximations to the eigenvalues of A*z = lambda*B*z associated c with DR. c c NOTE: When Ritz values are complex, they will come in complex c conjugate pairs. If eigenvectors are requested, the c corresponding Ritz vectors will also come in conjugate c pairs and the real and imaginary parts of these are c represented in two consecutive columns of the array Z c (see below). c c Z Real N by NEV+1 array if RVEC = .TRUE. and HOWMNY = 'A'. (OUTPUT) c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of c Z represent approximate eigenvectors (Ritz vectors) corresponding c to the NCONV=IPARAM(5) Ritz values for eigensystem c A*z = lambda*B*z. c c The complex Ritz vector associated with the Ritz value c with positive imaginary part is stored in two consecutive c columns. The first column holds the real part of the Ritz c vector and the second column holds the imaginary part. The c Ritz vector associated with the Ritz value with negative c imaginary part is simply the complex conjugate of the Ritz vector c associated with the positive imaginary part. c c If RVEC = .FALSE. or HOWMNY = 'P', then Z is not referenced. c c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, c the array Z may be set equal to first NEV+1 columns of the Arnoldi c basis array V computed by SNAUPD. In this case the Arnoldi basis c will be destroyed and overwritten with the eigenvector basis. c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ >= max( 1, N ). In any case, LDZ >= 1. c c SIGMAR Real (INPUT) c If IPARAM(7) = 3 or 4, represents the real part of the shift. c Not referenced if IPARAM(7) = 1 or 2. c c SIGMAI Real (INPUT) c If IPARAM(7) = 3 or 4, represents the imaginary part of the shift. c Not referenced if IPARAM(7) = 1 or 2. See remark 3 below. c c WORKEV Real work array of dimension 3*NCV. (WORKSPACE) c c **** The remaining arguments MUST be the same as for the **** c **** call to SNAUPD that was just completed. **** c c NOTE: The remaining arguments c c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, c WORKD, WORKL, LWORKL, INFO c c must be passed directly to SNEUPD following the last call c to SNAUPD. These arguments MUST NOT BE MODIFIED between c the the last call to SNAUPD and the call to SNEUPD. c c Three of these parameters (V, WORKL, INFO) are also output parameters: c c V Real N by NCV array. (INPUT/OUTPUT) c c Upon INPUT: the NCV columns of V contain the Arnoldi basis c vectors for OP as constructed by SNAUPD . c c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns c contain approximate Schur vectors that span the c desired invariant subspace. See Remark 2 below. c c NOTE: If the array Z has been set equal to first NEV+1 columns c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the c Arnoldi basis held by V has been overwritten by the desired c Ritz vectors. If a separate array Z has been passed then c the first NCONV=IPARAM(5) columns of V will contain approximate c Schur vectors that span the desired invariant subspace. c c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) c WORKL(1:ncv*ncv+3*ncv) contains information obtained in c snaupd. They are not changed by sneupd. c WORKL(ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) holds the c real and imaginary part of the untransformed Ritz values, c the upper quasi-triangular matrix for H, and the c associated matrix representation of the invariant subspace for H. c c Note: IPNTR(9:13) contains the pointer into WORKL for addresses c of the above information computed by sneupd. c ------------------------------------------------------------- c IPNTR(9): pointer to the real part of the NCV RITZ values of the c original system. c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of c the original system. c IPNTR(11): pointer to the NCV corresponding error bounds. c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular c Schur matrix for H. c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors c of the upper Hessenberg matrix H. Only referenced by c sneupd if RVEC = .TRUE. See Remark 2 below. c ------------------------------------------------------------- c c INFO Integer. (OUTPUT) c Error flag on output. c c = 0: Normal exit. c c = 1: The Schur form computed by LAPACK routine slahqr c could not be reordered by LAPACK routine strsen. c Re-enter subroutine sneupd with IPARAM(5)=NCV and c increase the size of the arrays DR and DI to have c dimension at least dimension NCV and allocate at least NCV c columns for Z. NOTE: Not necessary if Z and V share c the same space. Please notify the authors if this error c occurs. c c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 2 and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from calculation of a real Schur form. c Informational error from LAPACK routine slahqr. c = -9: Error return from calculation of eigenvectors. c Informational error from LAPACK routine strevc. c = -10: IPARAM(7) must be 1,2,3,4. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: HOWMNY = 'S' not yet implemented c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. c = -14: SNAUPD did not find any eigenvalues to sufficient c accuracy. c = -15: DNEUPD got a different count of the number of converged c Ritz values than DNAUPD got. This indicates the user c probably made an error in passing data from DNAUPD to c DNEUPD or that the data was modified before entering c DNEUPD c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for c Real Matrices", Linear Algebra and its Applications, vol 88/89, c pp 575-595, (1987). c c\Routines called: c ivout ARPACK utility routine that prints integers. c smout ARPACK utility routine that prints matrices c svout ARPACK utility routine that prints vectors. c sgeqr2 LAPACK routine that computes the QR factorization of c a matrix. c slacpy LAPACK matrix copy routine. c slahqr LAPACK routine to compute the real Schur form of an c upper Hessenberg matrix. c slamch LAPACK routine that determines machine constants. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slaset LAPACK matrix initialization routine. c sorm2r LAPACK routine that applies an orthogonal matrix in c factored form. c strevc LAPACK routine to compute the eigenvectors of a matrix c in upper quasi-triangular form. c strsen LAPACK routine that re-orders the Schur form. c strmm Level 3 BLAS matrix times an upper triangular matrix. c sger Level 2 BLAS rank one update to a matrix. c scopy Level 1 BLAS that copies one vector to another . c sdot Level 1 BLAS that computes the scalar product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c sscal Level 1 BLAS that scales a vector. c c\Remarks c c 1. Currently only HOWMNY = 'A' and 'P' are implemented. c c Let trans(X) denote the transpose of X. c c 2. Schur vectors are an orthogonal representation for the basis of c Ritz vectors. Thus, their numerical properties are often superior. c If RVEC = .TRUE. then the relationship c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and c trans(V(:,1:IPARAM(5))) * V(:,1:IPARAM(5)) = I are approximately c satisfied. Here T is the leading submatrix of order IPARAM(5) of the c real upper quasi-triangular matrix stored workl(ipntr(12)). That is, c T is block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; c each 2-by-2 diagonal block has its diagonal elements equal and its c off-diagonal elements of opposite sign. Corresponding to each 2-by-2 c diagonal block is a complex conjugate pair of Ritz values. The real c Ritz values are stored on the diagonal of T. c c 3. If IPARAM(7) = 3 or 4 and SIGMAI is not equal zero, then the user must c form the IPARAM(5) Rayleigh quotients in order to transform the Ritz c values computed by SNAUPD for OP to those of A*z = lambda*B*z. c Set RVEC = .true. and HOWMNY = 'A', and c compute c trans(Z(:,I)) * A * Z(:,I) if DI(I) = 0. c If DI(I) is not equal to zero and DI(I+1) = - D(I), c then the desired real and imaginary parts of the Ritz value are c trans(Z(:,I)) * A * Z(:,I) + trans(Z(:,I+1)) * A * Z(:,I+1), c trans(Z(:,I)) * A * Z(:,I+1) - trans(Z(:,I+1)) * A * Z(:,I), c respectively. c Another possibility is to set RVEC = .true. and HOWMNY = 'P' and c compute trans(V(:,1:IPARAM(5))) * A * V(:,1:IPARAM(5)) and then an upper c quasi-triangular matrix of order IPARAM(5) is computed. See remark c 2 above. c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Chao Yang Houston, Texas c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: neupd.F SID: 2.7 DATE OF SID: 09/20/00 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- subroutine sneupd(rvec , howmny, select, dr , di, & z , ldz , sigmar, sigmai, workev, & bmat , n , which , nev , tol, & resid, ncv , v , ldv , iparam, & ipntr, workd , workl , lworkl, info) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat, howmny, which*2 logical rvec integer info, ldz, ldv, lworkl, n, ncv, nev Real & sigmar, sigmai, tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(14) logical select(ncv) Real & dr(nev+1) , di(nev+1), resid(n) , & v(ldv,ncv) , z(ldz,*) , workd(3*n), & workl(lworkl), workev(3*ncv) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0 , zero = 0.0E+0 ) c c %---------------% c | Local Scalars | c %---------------% c character type*6 integer bounds, ierr , ih , ihbds , & iheigr, iheigi, iconj , nconv , & invsub, iuptri, iwev , iwork(1), & j , k , ldh , ldq , & mode , msglvl, outncv, ritzr , & ritzi , wri , wrr , irr , & iri , ibd , ishift, numcnv , & np , jj logical reord Real & conds , rnorm, sep , temp, & vl(1,1), temp1, eps23 c c %----------------------% c | External Subroutines | c %----------------------% c external scopy , sger , sgeqr2, slacpy, & slahqr, slaset, smout , sorm2r, & strevc, strmm , strsen, sscal , & svout , ivout c c %--------------------% c | External Functions | c %--------------------% c Real & slapy2, snrm2, slamch, sdot external slapy2, snrm2, slamch, sdot c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs, min, sqrt c c %-----------------------% c | Executable Statements | c %-----------------------% c c %------------------------% c | Set default parameters | c %------------------------% c msglvl = mneupd mode = iparam(7) nconv = iparam(5) info = 0 c c %---------------------------------% c | Get machine dependent constant. | c %---------------------------------% c eps23 = slamch('Epsilon-Machine') eps23 = eps23**(2.0E+0 / 3.0E+0 ) c c %--------------% c | Quick return | c %--------------% c ierr = 0 c if (nconv .le. 0) then ierr = -14 else if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev+1 .or. ncv .gt. n) then ierr = -3 else if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LR' .and. & which .ne. 'SR' .and. & which .ne. 'LI' .and. & which .ne. 'SI') then ierr = -5 else if (bmat .ne. 'I' .and. bmat .ne. 'G') then ierr = -6 else if (lworkl .lt. 3*ncv**2 + 6*ncv) then ierr = -7 else if ( (howmny .ne. 'A' .and. & howmny .ne. 'P' .and. & howmny .ne. 'S') .and. rvec ) then ierr = -13 else if (howmny .eq. 'S' ) then ierr = -12 end if c if (mode .eq. 1 .or. mode .eq. 2) then type = 'REGULR' else if (mode .eq. 3 .and. sigmai .eq. zero) then type = 'SHIFTI' else if (mode .eq. 3 ) then type = 'REALPT' else if (mode .eq. 4 ) then type = 'IMAGPT' else ierr = -10 end if if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr go to 9000 end if c c %--------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:ncv*ncv) := generated Hessenberg matrix | c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | c | parts of ritz values | c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | c %--------------------------------------------------------% c c %-----------------------------------------------------------% c | The following is used and set by SNEUPD. | c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | c | real part of the Ritz values. | c | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | c | imaginary part of the Ritz values. | c | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | c | error bounds of the Ritz values | c | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | c | quasi-triangular matrix for H | c | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | c | associated matrix representation of the invariant | c | subspace for H. | c | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | c %-----------------------------------------------------------% c ih = ipntr(5) ritzr = ipntr(6) ritzi = ipntr(7) bounds = ipntr(8) ldh = ncv ldq = ncv iheigr = bounds + ldh iheigi = iheigr + ldh ihbds = iheigi + ldh iuptri = ihbds + ldh invsub = iuptri + ldh*ncv ipntr(9) = iheigr ipntr(10) = iheigi ipntr(11) = ihbds ipntr(12) = iuptri ipntr(13) = invsub wrr = 1 wri = ncv + 1 iwev = wri + ncv c c %-----------------------------------------% c | irr points to the REAL part of the Ritz | c | values computed by _neigh before | c | exiting _naup2. | c | iri points to the IMAGINARY part of the | c | Ritz values computed by _neigh | c | before exiting _naup2. | c | ibd points to the Ritz estimates | c | computed by _neigh before exiting | c | _naup2. | c %-----------------------------------------% c irr = ipntr(14)+ncv*ncv iri = irr+ncv ibd = iri+ncv c c %------------------------------------% c | RNORM is B-norm of the RESID(1:N). | c %------------------------------------% c rnorm = workl(ih+2) workl(ih+2) = zero c if (msglvl .gt. 2) then call svout(logfil, ncv, workl(irr), ndigit, & '_neupd: Real part of Ritz values passed in from _NAUPD.') call svout(logfil, ncv, workl(iri), ndigit, & '_neupd: Imag part of Ritz values passed in from _NAUPD.') call svout(logfil, ncv, workl(ibd), ndigit, & '_neupd: Ritz estimates passed in from _NAUPD.') end if c if (rvec) then c reord = .false. c c %---------------------------------------------------% c | Use the temporary bounds array to store indices | c | These will be used to mark the select array later | c %---------------------------------------------------% c do 10 j = 1,ncv workl(bounds+j-1) = j select(j) = .false. 10 continue c c %-------------------------------------% c | Select the wanted Ritz values. | c | Sort the Ritz values so that the | c | wanted ones appear at the tailing | c | NEV positions of workl(irr) and | c | workl(iri). Move the corresponding | c | error estimates in workl(bound) | c | accordingly. | c %-------------------------------------% c np = ncv - nev ishift = 0 call sngets(ishift , which , nev , & np , workl(irr), workl(iri), & workl(bounds), workl , workl(np+1)) c if (msglvl .gt. 2) then call svout(logfil, ncv, workl(irr), ndigit, & '_neupd: Real part of Ritz values after calling _NGETS.') call svout(logfil, ncv, workl(iri), ndigit, & '_neupd: Imag part of Ritz values after calling _NGETS.') call svout(logfil, ncv, workl(bounds), ndigit, & '_neupd: Ritz value indices after calling _NGETS.') end if c c %-----------------------------------------------------% c | Record indices of the converged wanted Ritz values | c | Mark the select array for possible reordering | c %-----------------------------------------------------% c numcnv = 0 do 11 j = 1,ncv temp1 = max(eps23, & slapy2( workl(irr+ncv-j), workl(iri+ncv-j) )) jj = workl(bounds + ncv - j) if (numcnv .lt. nconv .and. & workl(ibd+jj-1) .le. tol*temp1) then select(jj) = .true. numcnv = numcnv + 1 if (jj .gt. nev) reord = .true. endif 11 continue c c %-----------------------------------------------------------% c | Check the count (numcnv) of converged Ritz values with | c | the number (nconv) reported by dnaupd. If these two | c | are different then there has probably been an error | c | caused by incorrect passing of the dnaupd data. | c %-----------------------------------------------------------% c if (msglvl .gt. 2) then call ivout(logfil, 1, numcnv, ndigit, & '_neupd: Number of specified eigenvalues') call ivout(logfil, 1, nconv, ndigit, & '_neupd: Number of "converged" eigenvalues') end if c if (numcnv .ne. nconv) then info = -15 go to 9000 end if c c %-----------------------------------------------------------% c | Call LAPACK routine slahqr to compute the real Schur form | c | of the upper Hessenberg matrix returned by SNAUPD. | c | Make a copy of the upper Hessenberg matrix. | c | Initialize the Schur vector matrix Q to the identity. | c %-----------------------------------------------------------% c call scopy(ldh*ncv, workl(ih), 1, workl(iuptri), 1) call slaset('All', ncv, ncv, & zero , one, workl(invsub), & ldq) call slahqr(.true., .true. , ncv, & 1 , ncv , workl(iuptri), & ldh , workl(iheigr), workl(iheigi), & 1 , ncv , workl(invsub), & ldq , ierr) call scopy(ncv , workl(invsub+ncv-1), ldq, & workl(ihbds), 1) c if (ierr .ne. 0) then info = -8 go to 9000 end if c if (msglvl .gt. 1) then call svout(logfil, ncv, workl(iheigr), ndigit, & '_neupd: Real part of the eigenvalues of H') call svout(logfil, ncv, workl(iheigi), ndigit, & '_neupd: Imaginary part of the Eigenvalues of H') call svout(logfil, ncv, workl(ihbds), ndigit, & '_neupd: Last row of the Schur vector matrix') if (msglvl .gt. 3) then call smout(logfil , ncv, ncv , & workl(iuptri), ldh, ndigit, & '_neupd: The upper quasi-triangular matrix ') end if end if c if (reord) then c c %-----------------------------------------------------% c | Reorder the computed upper quasi-triangular matrix. | c %-----------------------------------------------------% c call strsen('None' , 'V' , & select , ncv , & workl(iuptri), ldh , & workl(invsub), ldq , & workl(iheigr), workl(iheigi), & nconv , conds , & sep , workl(ihbds) , & ncv , iwork , & 1 , ierr) c if (ierr .eq. 1) then info = 1 go to 9000 end if c if (msglvl .gt. 2) then call svout(logfil, ncv, workl(iheigr), ndigit, & '_neupd: Real part of the eigenvalues of H--reordered') call svout(logfil, ncv, workl(iheigi), ndigit, & '_neupd: Imag part of the eigenvalues of H--reordered') if (msglvl .gt. 3) then call smout(logfil , ncv, ncv , & workl(iuptri), ldq, ndigit, & '_neupd: Quasi-triangular matrix after re-ordering') end if end if c end if c c %---------------------------------------% c | Copy the last row of the Schur vector | c | into workl(ihbds). This will be used | c | to compute the Ritz estimates of | c | converged Ritz values. | c %---------------------------------------% c call scopy(ncv, workl(invsub+ncv-1), ldq, workl(ihbds), 1) c c %----------------------------------------------------% c | Place the computed eigenvalues of H into DR and DI | c | if a spectral transformation was not used. | c %----------------------------------------------------% c if (type .eq. 'REGULR') then call scopy(nconv, workl(iheigr), 1, dr, 1) call scopy(nconv, workl(iheigi), 1, di, 1) end if c c %----------------------------------------------------------% c | Compute the QR factorization of the matrix representing | c | the wanted invariant subspace located in the first NCONV | c | columns of workl(invsub,ldq). | c %----------------------------------------------------------% c call sgeqr2(ncv, nconv , workl(invsub), & ldq, workev, workev(ncv+1), & ierr) c c %---------------------------------------------------------% c | * Postmultiply V by Q using sorm2r. | c | * Copy the first NCONV columns of VQ into Z. | c | * Postmultiply Z by R. | c | The N by NCONV matrix Z is now a matrix representation | c | of the approximate invariant subspace associated with | c | the Ritz values in workl(iheigr) and workl(iheigi) | c | The first NCONV columns of V are now approximate Schur | c | vectors associated with the real upper quasi-triangular | c | matrix of order NCONV in workl(iuptri) | c %---------------------------------------------------------% c call sorm2r('Right', 'Notranspose', n , & ncv , nconv , workl(invsub), & ldq , workev , v , & ldv , workd(n+1) , ierr) call slacpy('All', n, nconv, v, ldv, z, ldz) c do 20 j=1, nconv c c %---------------------------------------------------% c | Perform both a column and row scaling if the | c | diagonal element of workl(invsub,ldq) is negative | c | I'm lazy and don't take advantage of the upper | c | quasi-triangular form of workl(iuptri,ldq) | c | Note that since Q is orthogonal, R is a diagonal | c | matrix consisting of plus or minus ones | c %---------------------------------------------------% c if (workl(invsub+(j-1)*ldq+j-1) .lt. zero) then call sscal(nconv, -one, workl(iuptri+j-1), ldq) call sscal(nconv, -one, workl(iuptri+(j-1)*ldq), 1) end if c 20 continue c if (howmny .eq. 'A') then c c %--------------------------------------------% c | Compute the NCONV wanted eigenvectors of T | c | located in workl(iuptri,ldq). | c %--------------------------------------------% c do 30 j=1, ncv if (j .le. nconv) then select(j) = .true. else select(j) = .false. end if 30 continue c call strevc('Right', 'Select' , select , & ncv , workl(iuptri), ldq , & vl , 1 , workl(invsub), & ldq , ncv , outncv , & workev , ierr) c if (ierr .ne. 0) then info = -9 go to 9000 end if c c %------------------------------------------------% c | Scale the returning eigenvectors so that their | c | Euclidean norms are all one. LAPACK subroutine | c | strevc returns each eigenvector normalized so | c | that the element of largest magnitude has | c | magnitude 1; | c %------------------------------------------------% c iconj = 0 do 40 j=1, nconv c if ( workl(iheigi+j-1) .eq. zero ) then c c %----------------------% c | real eigenvalue case | c %----------------------% c temp = snrm2( ncv, workl(invsub+(j-1)*ldq), 1 ) call sscal( ncv, one / temp, & workl(invsub+(j-1)*ldq), 1 ) c else c c %-------------------------------------------% c | Complex conjugate pair case. Note that | c | since the real and imaginary part of | c | the eigenvector are stored in consecutive | c | columns, we further normalize by the | c | square root of two. | c %-------------------------------------------% c if (iconj .eq. 0) then temp = slapy2(snrm2(ncv, & workl(invsub+(j-1)*ldq), & 1), & snrm2(ncv, & workl(invsub+j*ldq), & 1)) call sscal(ncv, one/temp, & workl(invsub+(j-1)*ldq), 1 ) call sscal(ncv, one/temp, & workl(invsub+j*ldq), 1 ) iconj = 1 else iconj = 0 end if c end if c 40 continue c call sgemv('T', ncv, nconv, one, workl(invsub), & ldq, workl(ihbds), 1, zero, workev, 1) c iconj = 0 do 45 j=1, nconv if (workl(iheigi+j-1) .ne. zero) then c c %-------------------------------------------% c | Complex conjugate pair case. Note that | c | since the real and imaginary part of | c | the eigenvector are stored in consecutive | c %-------------------------------------------% c if (iconj .eq. 0) then workev(j) = slapy2(workev(j), workev(j+1)) workev(j+1) = workev(j) iconj = 1 else iconj = 0 end if end if 45 continue c if (msglvl .gt. 2) then call scopy(ncv, workl(invsub+ncv-1), ldq, & workl(ihbds), 1) call svout(logfil, ncv, workl(ihbds), ndigit, & '_neupd: Last row of the eigenvector matrix for T') if (msglvl .gt. 3) then call smout(logfil, ncv, ncv, workl(invsub), ldq, & ndigit, '_neupd: The eigenvector matrix for T') end if end if c c %---------------------------------------% c | Copy Ritz estimates into workl(ihbds) | c %---------------------------------------% c call scopy(nconv, workev, 1, workl(ihbds), 1) c c %---------------------------------------------------------% c | Compute the QR factorization of the eigenvector matrix | c | associated with leading portion of T in the first NCONV | c | columns of workl(invsub,ldq). | c %---------------------------------------------------------% c call sgeqr2(ncv, nconv , workl(invsub), & ldq, workev, workev(ncv+1), & ierr) c c %----------------------------------------------% c | * Postmultiply Z by Q. | c | * Postmultiply Z by R. | c | The N by NCONV matrix Z is now contains the | c | Ritz vectors associated with the Ritz values | c | in workl(iheigr) and workl(iheigi). | c %----------------------------------------------% c call sorm2r('Right', 'Notranspose', n , & ncv , nconv , workl(invsub), & ldq , workev , z , & ldz , workd(n+1) , ierr) c call strmm('Right' , 'Upper' , 'No transpose', & 'Non-unit', n , nconv , & one , workl(invsub), ldq , & z , ldz) c end if c else c c %------------------------------------------------------% c | An approximate invariant subspace is not needed. | c | Place the Ritz values computed SNAUPD into DR and DI | c %------------------------------------------------------% c call scopy(nconv, workl(ritzr), 1, dr, 1) call scopy(nconv, workl(ritzi), 1, di, 1) call scopy(nconv, workl(ritzr), 1, workl(iheigr), 1) call scopy(nconv, workl(ritzi), 1, workl(iheigi), 1) call scopy(nconv, workl(bounds), 1, workl(ihbds), 1) end if c c %------------------------------------------------% c | Transform the Ritz values and possibly vectors | c | and corresponding error bounds of OP to those | c | of A*x = lambda*B*x. | c %------------------------------------------------% c if (type .eq. 'REGULR') then c if (rvec) & call sscal(ncv, rnorm, workl(ihbds), 1) c else c c %---------------------------------------% c | A spectral transformation was used. | c | * Determine the Ritz estimates of the | c | Ritz values in the original system. | c %---------------------------------------% c if (type .eq. 'SHIFTI') then c if (rvec) & call sscal(ncv, rnorm, workl(ihbds), 1) c do 50 k=1, ncv temp = slapy2( workl(iheigr+k-1), & workl(iheigi+k-1) ) workl(ihbds+k-1) = abs( workl(ihbds+k-1) ) & / temp / temp 50 continue c else if (type .eq. 'REALPT') then c do 60 k=1, ncv 60 continue c else if (type .eq. 'IMAGPT') then c do 70 k=1, ncv 70 continue c end if c c %-----------------------------------------------------------% c | * Transform the Ritz values back to the original system. | c | For TYPE = 'SHIFTI' the transformation is | c | lambda = 1/theta + sigma | c | For TYPE = 'REALPT' or 'IMAGPT' the user must from | c | Rayleigh quotients or a projection. See remark 3 above.| c | NOTES: | c | *The Ritz vectors are not affected by the transformation. | c %-----------------------------------------------------------% c if (type .eq. 'SHIFTI') then c do 80 k=1, ncv temp = slapy2( workl(iheigr+k-1), & workl(iheigi+k-1) ) workl(iheigr+k-1) = workl(iheigr+k-1)/temp/temp & + sigmar workl(iheigi+k-1) = -workl(iheigi+k-1)/temp/temp & + sigmai 80 continue c call scopy(nconv, workl(iheigr), 1, dr, 1) call scopy(nconv, workl(iheigi), 1, di, 1) c else if (type .eq. 'REALPT' .or. type .eq. 'IMAGPT') then c call scopy(nconv, workl(iheigr), 1, dr, 1) call scopy(nconv, workl(iheigi), 1, di, 1) c end if c end if c if (type .eq. 'SHIFTI' .and. msglvl .gt. 1) then call svout(logfil, nconv, dr, ndigit, & '_neupd: Untransformed real part of the Ritz valuess.') call svout (logfil, nconv, di, ndigit, & '_neupd: Untransformed imag part of the Ritz valuess.') call svout(logfil, nconv, workl(ihbds), ndigit, & '_neupd: Ritz estimates of untransformed Ritz values.') else if (type .eq. 'REGULR' .and. msglvl .gt. 1) then call svout(logfil, nconv, dr, ndigit, & '_neupd: Real parts of converged Ritz values.') call svout (logfil, nconv, di, ndigit, & '_neupd: Imag parts of converged Ritz values.') call svout(logfil, nconv, workl(ihbds), ndigit, & '_neupd: Associated Ritz estimates.') end if c c %-------------------------------------------------% c | Eigenvector Purification step. Formally perform | c | one of inverse subspace iteration. Only used | c | for MODE = 2. | c %-------------------------------------------------% c if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then c c %------------------------------------------------% c | Purify the computed Ritz vectors by adding a | c | little bit of the residual vector: | c | T | c | resid(:)*( e s ) / theta | c | NCV | c | where H s = s theta. Remember that when theta | c | has nonzero imaginary part, the corresponding | c | Ritz vector is stored across two columns of Z. | c %------------------------------------------------% c iconj = 0 do 110 j=1, nconv if (workl(iheigi+j-1) .eq. zero) then workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / & workl(iheigr+j-1) else if (iconj .eq. 0) then temp = slapy2( workl(iheigr+j-1), workl(iheigi+j-1) ) workev(j) = ( workl(invsub+(j-1)*ldq+ncv-1) * & workl(iheigr+j-1) + & workl(invsub+j*ldq+ncv-1) * & workl(iheigi+j-1) ) / temp / temp workev(j+1) = ( workl(invsub+j*ldq+ncv-1) * & workl(iheigr+j-1) - & workl(invsub+(j-1)*ldq+ncv-1) * & workl(iheigi+j-1) ) / temp / temp iconj = 1 else iconj = 0 end if 110 continue c c %---------------------------------------% c | Perform a rank one update to Z and | c | purify all the Ritz vectors together. | c %---------------------------------------% c call sger(n, nconv, one, resid, 1, workev, 1, z, ldz) c end if c 9000 continue c return c c %---------------% c | End of SNEUPD | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/slaqrb.f000644 001750 001750 00000043644 11266605602 022113 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: slaqrb c c\Description: c Compute the eigenvalues and the Schur decomposition of an upper c Hessenberg submatrix in rows and columns ILO to IHI. Only the c last component of the Schur vectors are computed. c c This is mostly a modification of the LAPACK routine slahqr. c c\Usage: c call slaqrb c ( WANTT, N, ILO, IHI, H, LDH, WR, WI, Z, INFO ) c c\Arguments c WANTT Logical variable. (INPUT) c = .TRUE. : the full Schur form T is required; c = .FALSE.: only eigenvalues are required. c c N Integer. (INPUT) c The order of the matrix H. N >= 0. c c ILO Integer. (INPUT) c IHI Integer. (INPUT) c It is assumed that H is already upper quasi-triangular in c rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless c ILO = 1). SLAQRB works primarily with the Hessenberg c submatrix in rows and columns ILO to IHI, but applies c transformations to all of H if WANTT is .TRUE.. c 1 <= ILO <= max(1,IHI); IHI <= N. c c H Real array, dimension (LDH,N). (INPUT/OUTPUT) c On entry, the upper Hessenberg matrix H. c On exit, if WANTT is .TRUE., H is upper quasi-triangular in c rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in c standard form. If WANTT is .FALSE., the contents of H are c unspecified on exit. c c LDH Integer. (INPUT) c The leading dimension of the array H. LDH >= max(1,N). c c WR Real array, dimension (N). (OUTPUT) c WI Real array, dimension (N). (OUTPUT) c The real and imaginary parts, respectively, of the computed c eigenvalues ILO to IHI are stored in the corresponding c elements of WR and WI. If two eigenvalues are computed as a c complex conjugate pair, they are stored in consecutive c elements of WR and WI, say the i-th and (i+1)th, with c WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the c eigenvalues are stored in the same order as on the diagonal c of the Schur form returned in H, with WR(i) = H(i,i), and, if c H(i:i+1,i:i+1) is a 2-by-2 diagonal block, c WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). c c Z Real array, dimension (N). (OUTPUT) c On exit Z contains the last components of the Schur vectors. c c INFO Integer. (OUPUT) c = 0: successful exit c > 0: SLAQRB failed to compute all the eigenvalues ILO to IHI c in a total of 30*(IHI-ILO+1) iterations; if INFO = i, c elements i+1:ihi of WR and WI contain those eigenvalues c which have been successfully computed. c c\Remarks c 1. None. c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c slabad LAPACK routine that computes machine constants. c slamch LAPACK routine that determines machine constants. c slanhs LAPACK routine that computes various norms of a matrix. c slanv2 LAPACK routine that computes the Schur factorization of c 2 by 2 nonsymmetric matrix in standard form. c slarfg LAPACK Householder reflection construction routine. c scopy Level 1 BLAS that copies one vector to another. c srot Level 1 BLAS that applies a rotation to a 2 by 2 matrix. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.4' c Modified from the LAPACK routine slahqr so that only the c last component of the Schur vectors are computed. c c\SCCS Information: @(#) c FILE: laqrb.F SID: 2.2 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c subroutine slaqrb ( wantt, n, ilo, ihi, h, ldh, wr, wi, & z, info ) c c %------------------% c | Scalar Arguments | c %------------------% c logical wantt integer ihi, ilo, info, ldh, n c c %-----------------% c | Array Arguments | c %-----------------% c Real & h( ldh, * ), wi( * ), wr( * ), z( * ) c c %------------% c | Parameters | c %------------% c Real & zero, one, dat1, dat2 parameter (zero = 0.0E+0, one = 1.0E+0, dat1 = 7.5E-1, & dat2 = -4.375E-1) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c integer i, i1, i2, itn, its, j, k, l, m, nh, nr Real & cs, h00, h10, h11, h12, h21, h22, h33, h33s, & h43h34, h44, h44s, ovfl, s, smlnum, sn, sum, & t1, t2, t3, tst1, ulp, unfl, v1, v2, v3 Real & v( 3 ), work( 1 ) c c %--------------------% c | External Functions | c %--------------------% c Real & slamch, slanhs external slamch, slanhs c c %----------------------% c | External Subroutines | c %----------------------% c external scopy, slabad, slanv2, slarfg, srot c c %-----------------------% c | Executable Statements | c %-----------------------% c info = 0 c c %--------------------------% c | Quick return if possible | c %--------------------------% c if( n.eq.0 ) & return if( ilo.eq.ihi ) then wr( ilo ) = h( ilo, ilo ) wi( ilo ) = zero return end if c c %---------------------------------------------% c | Initialize the vector of last components of | c | the Schur vectors for accumulation. | c %---------------------------------------------% c do 5 j = 1, n-1 z(j) = zero 5 continue z(n) = one c nh = ihi - ilo + 1 c c %-------------------------------------------------------------% c | Set machine-dependent constants for the stopping criterion. | c | If norm(H) <= sqrt(OVFL), overflow should not occur. | c %-------------------------------------------------------------% c unfl = slamch( 'safe minimum' ) ovfl = one / unfl call slabad( unfl, ovfl ) ulp = slamch( 'precision' ) smlnum = unfl*( nh / ulp ) c c %---------------------------------------------------------------% c | I1 and I2 are the indices of the first row and last column | c | of H to which transformations must be applied. If eigenvalues | c | only are computed, I1 and I2 are set inside the main loop. | c | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE. | c | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE. | c %---------------------------------------------------------------% c if( wantt ) then i1 = 1 i2 = n do 8 i=1,i2-2 h(i1+i+1,i) = zero 8 continue else do 9 i=1, ihi-ilo-1 h(ilo+i+1,ilo+i-1) = zero 9 continue end if c c %---------------------------------------------------% c | ITN is the total number of QR iterations allowed. | c %---------------------------------------------------% c itn = 30*nh c c ------------------------------------------------------------------ c The main loop begins here. I is the loop index and decreases from c IHI to ILO in steps of 1 or 2. Each iteration of the loop works c with the active submatrix in rows and columns L to I. c Eigenvalues I+1 to IHI have already converged. Either L = ILO or c H(L,L-1) is negligible so that the matrix splits. c ------------------------------------------------------------------ c i = ihi 10 continue l = ilo if( i.lt.ilo ) & go to 150 c %--------------------------------------------------------------% c | Perform QR iterations on rows and columns ILO to I until a | c | submatrix of order 1 or 2 splits off at the bottom because a | c | subdiagonal element has become negligible. | c %--------------------------------------------------------------% do 130 its = 0, itn c c %----------------------------------------------% c | Look for a single small subdiagonal element. | c %----------------------------------------------% c do 20 k = i, l + 1, -1 tst1 = abs( h( k-1, k-1 ) ) + abs( h( k, k ) ) if( tst1.eq.zero ) & tst1 = slanhs( '1', i-l+1, h( l, l ), ldh, work ) if( abs( h( k, k-1 ) ).le.max( ulp*tst1, smlnum ) ) & go to 30 20 continue 30 continue l = k if( l.gt.ilo ) then c c %------------------------% c | H(L,L-1) is negligible | c %------------------------% c h( l, l-1 ) = zero end if c c %-------------------------------------------------------------% c | Exit from loop if a submatrix of order 1 or 2 has split off | c %-------------------------------------------------------------% c if( l.ge.i-1 ) & go to 140 c c %---------------------------------------------------------% c | Now the active submatrix is in rows and columns L to I. | c | If eigenvalues only are being computed, only the active | c | submatrix need be transformed. | c %---------------------------------------------------------% c if( .not.wantt ) then i1 = l i2 = i end if c if( its.eq.10 .or. its.eq.20 ) then c c %-------------------% c | Exceptional shift | c %-------------------% c s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) ) h44 = dat1*s h33 = h44 h43h34 = dat2*s*s c else c c %-----------------------------------------% c | Prepare to use Wilkinson's double shift | c %-----------------------------------------% c h44 = h( i, i ) h33 = h( i-1, i-1 ) h43h34 = h( i, i-1 )*h( i-1, i ) end if c c %-----------------------------------------------------% c | Look for two consecutive small subdiagonal elements | c %-----------------------------------------------------% c do 40 m = i - 2, l, -1 c c %---------------------------------------------------------% c | Determine the effect of starting the double-shift QR | c | iteration at row M, and see if this would make H(M,M-1) | c | negligible. | c %---------------------------------------------------------% c h11 = h( m, m ) h22 = h( m+1, m+1 ) h21 = h( m+1, m ) h12 = h( m, m+1 ) h44s = h44 - h11 h33s = h33 - h11 v1 = ( h33s*h44s-h43h34 ) / h21 + h12 v2 = h22 - h11 - h33s - h44s v3 = h( m+2, m+1 ) s = abs( v1 ) + abs( v2 ) + abs( v3 ) v1 = v1 / s v2 = v2 / s v3 = v3 / s v( 1 ) = v1 v( 2 ) = v2 v( 3 ) = v3 if( m.eq.l ) & go to 50 h00 = h( m-1, m-1 ) h10 = h( m, m-1 ) tst1 = abs( v1 )*( abs( h00 )+abs( h11 )+abs( h22 ) ) if( abs( h10 )*( abs( v2 )+abs( v3 ) ).le.ulp*tst1 ) & go to 50 40 continue 50 continue c c %----------------------% c | Double-shift QR step | c %----------------------% c do 120 k = m, i - 1 c c ------------------------------------------------------------ c The first iteration of this loop determines a reflection G c from the vector V and applies it from left and right to H, c thus creating a nonzero bulge below the subdiagonal. c c Each subsequent iteration determines a reflection G to c restore the Hessenberg form in the (K-1)th column, and thus c chases the bulge one step toward the bottom of the active c submatrix. NR is the order of G. c ------------------------------------------------------------ c nr = min( 3, i-k+1 ) if( k.gt.m ) & call scopy( nr, h( k, k-1 ), 1, v, 1 ) call slarfg( nr, v( 1 ), v( 2 ), 1, t1 ) if( k.gt.m ) then h( k, k-1 ) = v( 1 ) h( k+1, k-1 ) = zero if( k.lt.i-1 ) & h( k+2, k-1 ) = zero else if( m.gt.l ) then h( k, k-1 ) = -h( k, k-1 ) end if v2 = v( 2 ) t2 = t1*v2 if( nr.eq.3 ) then v3 = v( 3 ) t3 = t1*v3 c c %------------------------------------------------% c | Apply G from the left to transform the rows of | c | the matrix in columns K to I2. | c %------------------------------------------------% c do 60 j = k, i2 sum = h( k, j ) + v2*h( k+1, j ) + v3*h( k+2, j ) h( k, j ) = h( k, j ) - sum*t1 h( k+1, j ) = h( k+1, j ) - sum*t2 h( k+2, j ) = h( k+2, j ) - sum*t3 60 continue c c %----------------------------------------------------% c | Apply G from the right to transform the columns of | c | the matrix in rows I1 to min(K+3,I). | c %----------------------------------------------------% c do 70 j = i1, min( k+3, i ) sum = h( j, k ) + v2*h( j, k+1 ) + v3*h( j, k+2 ) h( j, k ) = h( j, k ) - sum*t1 h( j, k+1 ) = h( j, k+1 ) - sum*t2 h( j, k+2 ) = h( j, k+2 ) - sum*t3 70 continue c c %----------------------------------% c | Accumulate transformations for Z | c %----------------------------------% c sum = z( k ) + v2*z( k+1 ) + v3*z( k+2 ) z( k ) = z( k ) - sum*t1 z( k+1 ) = z( k+1 ) - sum*t2 z( k+2 ) = z( k+2 ) - sum*t3 else if( nr.eq.2 ) then c c %------------------------------------------------% c | Apply G from the left to transform the rows of | c | the matrix in columns K to I2. | c %------------------------------------------------% c do 90 j = k, i2 sum = h( k, j ) + v2*h( k+1, j ) h( k, j ) = h( k, j ) - sum*t1 h( k+1, j ) = h( k+1, j ) - sum*t2 90 continue c c %----------------------------------------------------% c | Apply G from the right to transform the columns of | c | the matrix in rows I1 to min(K+3,I). | c %----------------------------------------------------% c do 100 j = i1, i sum = h( j, k ) + v2*h( j, k+1 ) h( j, k ) = h( j, k ) - sum*t1 h( j, k+1 ) = h( j, k+1 ) - sum*t2 100 continue c c %----------------------------------% c | Accumulate transformations for Z | c %----------------------------------% c sum = z( k ) + v2*z( k+1 ) z( k ) = z( k ) - sum*t1 z( k+1 ) = z( k+1 ) - sum*t2 end if 120 continue 130 continue c c %-------------------------------------------------------% c | Failure to converge in remaining number of iterations | c %-------------------------------------------------------% c info = i return 140 continue if( l.eq.i ) then c c %------------------------------------------------------% c | H(I,I-1) is negligible: one eigenvalue has converged | c %------------------------------------------------------% c wr( i ) = h( i, i ) wi( i ) = zero else if( l.eq.i-1 ) then c c %--------------------------------------------------------% c | H(I-1,I-2) is negligible; | c | a pair of eigenvalues have converged. | c | | c | Transform the 2-by-2 submatrix to standard Schur form, | c | and compute and store the eigenvalues. | c %--------------------------------------------------------% c call slanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ), & h( i, i ), wr( i-1 ), wi( i-1 ), wr( i ), wi( i ), & cs, sn ) if( wantt ) then c c %-----------------------------------------------------% c | Apply the transformation to the rest of H and to Z, | c | as required. | c %-----------------------------------------------------% c if( i2.gt.i ) & call srot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh, & cs, sn ) call srot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn ) sum = cs*z( i-1 ) + sn*z( i ) z( i ) = cs*z( i ) - sn*z( i-1 ) z( i-1 ) = sum end if end if c c %---------------------------------------------------------% c | Decrement number of remaining iterations, and return to | c | start of the main loop with new value of I. | c %---------------------------------------------------------% c itn = itn - its i = l - 1 go to 10 150 continue return c c %---------------% c | End of slaqrb | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dnapps.f000644 001750 001750 00000055721 11266605602 022113 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dnapps c c\Description: c Given the Arnoldi factorization c c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, c c apply NP implicit shifts resulting in c c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q c c where Q is an orthogonal matrix which is the product of rotations c and reflections resulting from the NP bulge chage sweeps. c The updated Arnoldi factorization becomes: c c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. c c\Usage: c call dnapps c ( N, KEV, NP, SHIFTR, SHIFTI, V, LDV, H, LDH, RESID, Q, LDQ, c WORKL, WORKD ) c c\Arguments c N Integer. (INPUT) c Problem size, i.e. size of matrix A. c c KEV Integer. (INPUT/OUTPUT) c KEV+NP is the size of the input matrix H. c KEV is the size of the updated matrix HNEW. KEV is only c updated on ouput when fewer than NP shifts are applied in c order to keep the conjugate pair together. c c NP Integer. (INPUT) c Number of implicit shifts to be applied. c c SHIFTR, Double precision array of length NP. (INPUT) c SHIFTI Real and imaginary part of the shifts to be applied. c Upon, entry to dnapps, the shifts must be sorted so that the c conjugate pairs are in consecutive locations. c c V Double precision N by (KEV+NP) array. (INPUT/OUTPUT) c On INPUT, V contains the current KEV+NP Arnoldi vectors. c On OUTPUT, V contains the updated KEV Arnoldi vectors c in the first KEV columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Double precision (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) c On INPUT, H contains the current KEV+NP by KEV+NP upper c Hessenber matrix of the Arnoldi factorization. c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg c matrix in the KEV leading submatrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RESID Double precision array of length N. (INPUT/OUTPUT) c On INPUT, RESID contains the the residual vector r_{k+p}. c On OUTPUT, RESID is the update residual vector rnew_{k} c in the first KEV locations. c c Q Double precision KEV+NP by KEV+NP work array. (WORKSPACE) c Work array used to accumulate the rotations and reflections c during the bulge chase sweep. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Double precision work array of length (KEV+NP). (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c WORKD Double precision work array of length 2*N. (WORKSPACE) c Distributed array used in the application of the accumulated c orthogonal matrix Q. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c c\Routines called: c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c dmout ARPACK utility routine that prints matrices. c dvout ARPACK utility routine that prints vectors. c dlabad LAPACK routine that computes machine constants. c dlacpy LAPACK matrix copy routine. c dlamch LAPACK routine that determines machine constants. c dlanhs LAPACK routine that computes various norms of a matrix. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlarf LAPACK routine that applies Householder reflection to c a matrix. c dlarfg LAPACK Householder reflection construction routine. c dlartg LAPACK Givens rotation construction routine. c dlaset LAPACK matrix initialization routine. c dgemv Level 2 BLAS routine for matrix vector multiplication. c daxpy Level 1 BLAS that computes a vector triad. c dcopy Level 1 BLAS that copies one vector to another . c dscal Level 1 BLAS that scales a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.4' c c\SCCS Information: @(#) c FILE: napps.F SID: 2.4 DATE OF SID: 3/28/97 RELEASE: 2 c c\Remarks c 1. In this version, each shift is applied to all the sublocks of c the Hessenberg matrix H and not just to the submatrix that it c comes from. Deflation as in LAPACK routine dlahqr (QR algorithm c for upper Hessenberg matrices ) is used. c The subdiagonals of H are enforced to be non-negative. c c\EndLib c c----------------------------------------------------------------------- c subroutine dnapps & ( n, kev, np, shiftr, shifti, v, ldv, h, ldh, resid, q, ldq, & workl, workd ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer kev, ldh, ldq, ldv, n, np c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & h(ldh,kev+np), resid(n), shifti(np), shiftr(np), & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c integer i, iend, ir, istart, j, jj, kplusp, msglvl, nr logical cconj, first Double precision & c, f, g, h11, h12, h21, h22, h32, ovfl, r, s, sigmai, & sigmar, smlnum, ulp, unfl, u(3), t, tau, tst1 save first, ovfl, smlnum, ulp, unfl c c %----------------------% c | External Subroutines | c %----------------------% c external daxpy, dcopy, dscal, dlacpy, dlarfg, dlarf, & dlaset, dlabad, second, dlartg c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlamch, dlanhs, dlapy2 external dlamch, dlanhs, dlapy2 c c %----------------------% c | Intrinsics Functions | c %----------------------% c intrinsic abs, max, min c c %----------------% c | Data statments | c %----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then c c %-----------------------------------------------% c | Set machine-dependent constants for the | c | stopping criterion. If norm(H) <= sqrt(OVFL), | c | overflow should not occur. | c | REFERENCE: LAPACK subroutine dlahqr | c %-----------------------------------------------% c unfl = dlamch( 'safe minimum' ) ovfl = one / unfl call dlabad( unfl, ovfl ) ulp = dlamch( 'precision' ) smlnum = unfl*( n / ulp ) first = .false. end if c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mnapps kplusp = kev + np c c %--------------------------------------------% c | Initialize Q to the identity to accumulate | c | the rotations and reflections | c %--------------------------------------------% c call dlaset ('All', kplusp, kplusp, zero, one, q, ldq) c c %----------------------------------------------% c | Quick return if there are no shifts to apply | c %----------------------------------------------% c if (np .eq. 0) go to 9000 c c %----------------------------------------------% c | Chase the bulge with the application of each | c | implicit shift. Each shift is applied to the | c | whole matrix including each block. | c %----------------------------------------------% c cconj = .false. do 110 jj = 1, np sigmar = shiftr(jj) sigmai = shifti(jj) c if (msglvl .gt. 2 ) then call ivout (logfil, 1, jj, ndigit, & '_napps: shift number.') call dvout (logfil, 1, sigmar, ndigit, & '_napps: The real part of the shift ') call dvout (logfil, 1, sigmai, ndigit, & '_napps: The imaginary part of the shift ') end if c c %-------------------------------------------------% c | The following set of conditionals is necessary | c | in order that complex conjugate pairs of shifts | c | are applied together or not at all. | c %-------------------------------------------------% c if ( cconj ) then c c %-----------------------------------------% c | cconj = .true. means the previous shift | c | had non-zero imaginary part. | c %-----------------------------------------% c cconj = .false. go to 110 else if ( jj .lt. np .and. abs( sigmai ) .gt. zero ) then c c %------------------------------------% c | Start of a complex conjugate pair. | c %------------------------------------% c cconj = .true. else if ( jj .eq. np .and. abs( sigmai ) .gt. zero ) then c c %----------------------------------------------% c | The last shift has a nonzero imaginary part. | c | Don't apply it; thus the order of the | c | compressed H is order KEV+1 since only np-1 | c | were applied. | c %----------------------------------------------% c kev = kev + 1 go to 110 end if istart = 1 20 continue c c %--------------------------------------------------% c | if sigmai = 0 then | c | Apply the jj-th shift ... | c | else | c | Apply the jj-th and (jj+1)-th together ... | c | (Note that jj < np at this point in the code) | c | end | c | to the current block of H. The next do loop | c | determines the current block ; | c %--------------------------------------------------% c do 30 i = istart, kplusp-1 c c %----------------------------------------% c | Check for splitting and deflation. Use | c | a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine dlahqr | c %----------------------------------------% c tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) if( tst1.eq.zero ) & tst1 = dlanhs( '1', kplusp-jj+1, h, ldh, workl ) if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) then if (msglvl .gt. 0) then call ivout (logfil, 1, i, ndigit, & '_napps: matrix splitting at row/column no.') call ivout (logfil, 1, jj, ndigit, & '_napps: matrix splitting with shift number.') call dvout (logfil, 1, h(i+1,i), ndigit, & '_napps: off diagonal element.') end if iend = i h(i+1,i) = zero go to 40 end if 30 continue iend = kplusp 40 continue c if (msglvl .gt. 2) then call ivout (logfil, 1, istart, ndigit, & '_napps: Start of current block ') call ivout (logfil, 1, iend, ndigit, & '_napps: End of current block ') end if c c %------------------------------------------------% c | No reason to apply a shift to block of order 1 | c %------------------------------------------------% c if ( istart .eq. iend ) go to 100 c c %------------------------------------------------------% c | If istart + 1 = iend then no reason to apply a | c | complex conjugate pair of shifts on a 2 by 2 matrix. | c %------------------------------------------------------% c if ( istart + 1 .eq. iend .and. abs( sigmai ) .gt. zero ) & go to 100 c h11 = h(istart,istart) h21 = h(istart+1,istart) if ( abs( sigmai ) .le. zero ) then c c %---------------------------------------------% c | Real-valued shift ==> apply single shift QR | c %---------------------------------------------% c f = h11 - sigmar g = h21 c do 80 i = istart, iend-1 c c %-----------------------------------------------------% c | Contruct the plane rotation G to zero out the bulge | c %-----------------------------------------------------% c call dlartg (f, g, c, s, r) if (i .gt. istart) then c c %-------------------------------------------% c | The following ensures that h(1:iend-1,1), | c | the first iend-2 off diagonal of elements | c | H, remain non negative. | c %-------------------------------------------% c if (r .lt. zero) then r = -r c = -c s = -s end if h(i,i-1) = r h(i+1,i-1) = zero end if c c %---------------------------------------------% c | Apply rotation to the left of H; H <- G'*H | c %---------------------------------------------% c do 50 j = i, kplusp t = c*h(i,j) + s*h(i+1,j) h(i+1,j) = -s*h(i,j) + c*h(i+1,j) h(i,j) = t 50 continue c c %---------------------------------------------% c | Apply rotation to the right of H; H <- H*G | c %---------------------------------------------% c do 60 j = 1, min(i+2,iend) t = c*h(j,i) + s*h(j,i+1) h(j,i+1) = -s*h(j,i) + c*h(j,i+1) h(j,i) = t 60 continue c c %----------------------------------------------------% c | Accumulate the rotation in the matrix Q; Q <- Q*G | c %----------------------------------------------------% c do 70 j = 1, min( i+jj, kplusp ) t = c*q(j,i) + s*q(j,i+1) q(j,i+1) = - s*q(j,i) + c*q(j,i+1) q(j,i) = t 70 continue c c %---------------------------% c | Prepare for next rotation | c %---------------------------% c if (i .lt. iend-1) then f = h(i+1,i) g = h(i+2,i) end if 80 continue c c %-----------------------------------% c | Finished applying the real shift. | c %-----------------------------------% c else c c %----------------------------------------------------% c | Complex conjugate shifts ==> apply double shift QR | c %----------------------------------------------------% c h12 = h(istart,istart+1) h22 = h(istart+1,istart+1) h32 = h(istart+2,istart+1) c c %---------------------------------------------------------% c | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) | c %---------------------------------------------------------% c s = 2.0*sigmar t = dlapy2 ( sigmar, sigmai ) u(1) = ( h11 * (h11 - s) + t * t ) / h21 + h12 u(2) = h11 + h22 - s u(3) = h32 c do 90 i = istart, iend-1 c nr = min ( 3, iend-i+1 ) c c %-----------------------------------------------------% c | Construct Householder reflector G to zero out u(1). | c | G is of the form I - tau*( 1 u )' * ( 1 u' ). | c %-----------------------------------------------------% c call dlarfg ( nr, u(1), u(2), 1, tau ) c if (i .gt. istart) then h(i,i-1) = u(1) h(i+1,i-1) = zero if (i .lt. iend-1) h(i+2,i-1) = zero end if u(1) = one c c %--------------------------------------% c | Apply the reflector to the left of H | c %--------------------------------------% c call dlarf ('Left', nr, kplusp-i+1, u, 1, tau, & h(i,i), ldh, workl) c c %---------------------------------------% c | Apply the reflector to the right of H | c %---------------------------------------% c ir = min ( i+3, iend ) call dlarf ('Right', ir, nr, u, 1, tau, & h(1,i), ldh, workl) c c %-----------------------------------------------------% c | Accumulate the reflector in the matrix Q; Q <- Q*G | c %-----------------------------------------------------% c call dlarf ('Right', kplusp, nr, u, 1, tau, & q(1,i), ldq, workl) c c %----------------------------% c | Prepare for next reflector | c %----------------------------% c if (i .lt. iend-1) then u(1) = h(i+1,i) u(2) = h(i+2,i) if (i .lt. iend-2) u(3) = h(i+3,i) end if c 90 continue c c %--------------------------------------------% c | Finished applying a complex pair of shifts | c | to the current block | c %--------------------------------------------% c end if c 100 continue c c %---------------------------------------------------------% c | Apply the same shift to the next block if there is any. | c %---------------------------------------------------------% c istart = iend + 1 if (iend .lt. kplusp) go to 20 c c %---------------------------------------------% c | Loop back to the top to get the next shift. | c %---------------------------------------------% c 110 continue c c %--------------------------------------------------% c | Perform a similarity transformation that makes | c | sure that H will have non negative sub diagonals | c %--------------------------------------------------% c do 120 j=1,kev if ( h(j+1,j) .lt. zero ) then call dscal( kplusp-j+1, -one, h(j+1,j), ldh ) call dscal( min(j+2, kplusp), -one, h(1,j+1), 1 ) call dscal( min(j+np+1,kplusp), -one, q(1,j+1), 1 ) end if 120 continue c do 130 i = 1, kev c c %--------------------------------------------% c | Final check for splitting and deflation. | c | Use a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine dlahqr | c %--------------------------------------------% c tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) if( tst1.eq.zero ) & tst1 = dlanhs( '1', kev, h, ldh, workl ) if( h( i+1,i ) .le. max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 130 continue c c %-------------------------------------------------% c | Compute the (kev+1)-st column of (V*Q) and | c | temporarily store the result in WORKD(N+1:2*N). | c | This is needed in the residual update since we | c | cannot GUARANTEE that the corresponding entry | c | of H would be zero as in exact arithmetic. | c %-------------------------------------------------% c if (h(kev+1,kev) .gt. zero) & call dgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, & workd(n+1), 1) c c %----------------------------------------------------------% c | Compute column 1 to kev of (V*Q) in backward order | c | taking advantage of the upper Hessenberg structure of Q. | c %----------------------------------------------------------% c do 140 i = 1, kev call dgemv ('N', n, kplusp-i+1, one, v, ldv, & q(1,kev-i+1), 1, zero, workd, 1) call dcopy (n, workd, 1, v(1,kplusp-i+1), 1) 140 continue c c %-------------------------------------------------% c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | c %-------------------------------------------------% c call dlacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv) c c %--------------------------------------------------------------% c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | c %--------------------------------------------------------------% c if (h(kev+1,kev) .gt. zero) & call dcopy (n, workd(n+1), 1, v(1,kev+1), 1) c c %-------------------------------------% c | Update the residual vector: | c | r <- sigmak*r + betak*v(:,kev+1) | c | where | c | sigmak = (e_{kplusp}'*Q)*e_{kev} | c | betak = e_{kev+1}'*H*e_{kev} | c %-------------------------------------% c call dscal (n, q(kplusp,kev), resid, 1) if (h(kev+1,kev) .gt. zero) & call daxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) c if (msglvl .gt. 1) then call dvout (logfil, 1, q(kplusp,kev), ndigit, & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') call dvout (logfil, 1, h(kev+1,kev), ndigit, & '_napps: betak = e_{kev+1}^T*H*e_{kev}') call ivout (logfil, 1, kev, ndigit, & '_napps: Order of the final Hessenberg matrix ') if (msglvl .gt. 2) then call dmout (logfil, kev, kev, h, ldh, ndigit, & '_napps: updated Hessenberg matrix H for next iteration') end if c end if c 9000 continue call second (t1) tnapps = tnapps + (t1 - t0) c return c c %---------------% c | End of dnapps | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dnaupe.f000644 001750 001750 00000000000 11266605602 022056 0ustar00geuzainegeuzaine000000 000000 getdp-2.4.2-source/contrib/Arpack/dsapps.f000644 001750 001750 00000044122 11266605602 022111 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dsapps c c\Description: c Given the Arnoldi factorization c c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, c c apply NP shifts implicitly resulting in c c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q c c where Q is an orthogonal matrix of order KEV+NP. Q is the product of c rotations resulting from the NP bulge chasing sweeps. The updated Arnoldi c factorization becomes: c c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. c c\Usage: c call dsapps c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, WORKD ) c c\Arguments c N Integer. (INPUT) c Problem size, i.e. dimension of matrix A. c c KEV Integer. (INPUT) c INPUT: KEV+NP is the size of the input matrix H. c OUTPUT: KEV is the size of the updated matrix HNEW. c c NP Integer. (INPUT) c Number of implicit shifts to be applied. c c SHIFT Double precision array of length NP. (INPUT) c The shifts to be applied. c c V Double precision N by (KEV+NP) array. (INPUT/OUTPUT) c INPUT: V contains the current KEV+NP Arnoldi vectors. c OUTPUT: VNEW = V(1:n,1:KEV); the updated Arnoldi vectors c are in the first KEV columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Double precision (KEV+NP) by 2 array. (INPUT/OUTPUT) c INPUT: H contains the symmetric tridiagonal matrix of the c Arnoldi factorization with the subdiagonal in the 1st column c starting at H(2,1) and the main diagonal in the 2nd column. c OUTPUT: H contains the updated tridiagonal matrix in the c KEV leading submatrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RESID Double precision array of length (N). (INPUT/OUTPUT) c INPUT: RESID contains the the residual vector r_{k+p}. c OUTPUT: RESID is the updated residual vector rnew_{k}. c c Q Double precision KEV+NP by KEV+NP work array. (WORKSPACE) c Work array used to accumulate the rotations during the bulge c chase sweep. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKD Double precision work array of length 2*N. (WORKSPACE) c Distributed array used in the application of the accumulated c orthogonal matrix Q. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c dvout ARPACK utility routine that prints vectors. c dlamch LAPACK routine that determines machine constants. c dlartg LAPACK Givens rotation construction routine. c dlacpy LAPACK matrix copy routine. c dlaset LAPACK matrix initialization routine. c dgemv Level 2 BLAS routine for matrix vector multiplication. c daxpy Level 1 BLAS that computes a vector triad. c dcopy Level 1 BLAS that copies one vector to another. c dscal Level 1 BLAS that scales a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/16/93: Version ' 2.4' c c\SCCS Information: @(#) c FILE: sapps.F SID: 2.6 DATE OF SID: 3/28/97 RELEASE: 2 c c\Remarks c 1. In this version, each shift is applied to all the subblocks of c the tridiagonal matrix H and not just to the submatrix that it c comes from. This routine assumes that the subdiagonal elements c of H that are stored in h(1:kev+np,1) are nonegative upon input c and enforce this condition upon output. This version incorporates c deflation. See code for documentation. c c\EndLib c c----------------------------------------------------------------------- c subroutine dsapps & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, workd ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer kev, ldh, ldq, ldv, n, np c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & h(ldh,2), q(ldq,kev+np), resid(n), shift(np), & v(ldv,kev+np), workd(2*n) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %---------------% c | Local Scalars | c %---------------% c integer i, iend, istart, itop, j, jj, kplusp, msglvl logical first Double precision & a1, a2, a3, a4, big, c, epsmch, f, g, r, s save epsmch, first c c c %----------------------% c | External Subroutines | c %----------------------% c external daxpy, dcopy, dscal, dlacpy, dlartg, dlaset, dvout, & ivout, second, dgemv c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlamch external dlamch c c %----------------------% c | Intrinsics Functions | c %----------------------% c intrinsic abs c c %----------------% c | Data statments | c %----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then epsmch = dlamch('Epsilon-Machine') first = .false. end if itop = 1 c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = msapps c kplusp = kev + np c c %----------------------------------------------% c | Initialize Q to the identity matrix of order | c | kplusp used to accumulate the rotations. | c %----------------------------------------------% c call dlaset ('All', kplusp, kplusp, zero, one, q, ldq) c c %----------------------------------------------% c | Quick return if there are no shifts to apply | c %----------------------------------------------% c if (np .eq. 0) go to 9000 c c %----------------------------------------------------------% c | Apply the np shifts implicitly. Apply each shift to the | c | whole matrix and not just to the submatrix from which it | c | comes. | c %----------------------------------------------------------% c do 90 jj = 1, np c istart = itop c c %----------------------------------------------------------% c | Check for splitting and deflation. Currently we consider | c | an off-diagonal element h(i+1,1) negligible if | c | h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) | c | for i=1:KEV+NP-1. | c | If above condition tests true then we set h(i+1,1) = 0. | c | Note that h(1:KEV+NP,1) are assumed to be non negative. | c %----------------------------------------------------------% c 20 continue c c %------------------------------------------------% c | The following loop exits early if we encounter | c | a negligible off diagonal element. | c %------------------------------------------------% c do 30 i = istart, kplusp-1 big = abs(h(i,2)) + abs(h(i+1,2)) if (h(i+1,1) .le. epsmch*big) then if (msglvl .gt. 0) then call ivout (logfil, 1, i, ndigit, & '_sapps: deflation at row/column no.') call ivout (logfil, 1, jj, ndigit, & '_sapps: occured before shift number.') call dvout (logfil, 1, h(i+1,1), ndigit, & '_sapps: the corresponding off diagonal element') end if h(i+1,1) = zero iend = i go to 40 end if 30 continue iend = kplusp 40 continue c if (istart .lt. iend) then c c %--------------------------------------------------------% c | Construct the plane rotation G'(istart,istart+1,theta) | c | that attempts to drive h(istart+1,1) to zero. | c %--------------------------------------------------------% c f = h(istart,2) - shift(jj) g = h(istart+1,1) call dlartg (f, g, c, s, r) c c %-------------------------------------------------------% c | Apply rotation to the left and right of H; | c | H <- G' * H * G, where G = G(istart,istart+1,theta). | c | This will create a "bulge". | c %-------------------------------------------------------% c a1 = c*h(istart,2) + s*h(istart+1,1) a2 = c*h(istart+1,1) + s*h(istart+1,2) a4 = c*h(istart+1,2) - s*h(istart+1,1) a3 = c*h(istart+1,1) - s*h(istart,2) h(istart,2) = c*a1 + s*a2 h(istart+1,2) = c*a4 - s*a3 h(istart+1,1) = c*a3 + s*a4 c c %----------------------------------------------------% c | Accumulate the rotation in the matrix Q; Q <- Q*G | c %----------------------------------------------------% c do 60 j = 1, min(istart+jj,kplusp) a1 = c*q(j,istart) + s*q(j,istart+1) q(j,istart+1) = - s*q(j,istart) + c*q(j,istart+1) q(j,istart) = a1 60 continue c c c %----------------------------------------------% c | The following loop chases the bulge created. | c | Note that the previous rotation may also be | c | done within the following loop. But it is | c | kept separate to make the distinction among | c | the bulge chasing sweeps and the first plane | c | rotation designed to drive h(istart+1,1) to | c | zero. | c %----------------------------------------------% c do 70 i = istart+1, iend-1 c c %----------------------------------------------% c | Construct the plane rotation G'(i,i+1,theta) | c | that zeros the i-th bulge that was created | c | by G(i-1,i,theta). g represents the bulge. | c %----------------------------------------------% c f = h(i,1) g = s*h(i+1,1) c c %----------------------------------% c | Final update with G(i-1,i,theta) | c %----------------------------------% c h(i+1,1) = c*h(i+1,1) call dlartg (f, g, c, s, r) c c %-------------------------------------------% c | The following ensures that h(1:iend-1,1), | c | the first iend-2 off diagonal of elements | c | H, remain non negative. | c %-------------------------------------------% c if (r .lt. zero) then r = -r c = -c s = -s end if c c %--------------------------------------------% c | Apply rotation to the left and right of H; | c | H <- G * H * G', where G = G(i,i+1,theta) | c %--------------------------------------------% c h(i,1) = r c a1 = c*h(i,2) + s*h(i+1,1) a2 = c*h(i+1,1) + s*h(i+1,2) a3 = c*h(i+1,1) - s*h(i,2) a4 = c*h(i+1,2) - s*h(i+1,1) c h(i,2) = c*a1 + s*a2 h(i+1,2) = c*a4 - s*a3 h(i+1,1) = c*a3 + s*a4 c c %----------------------------------------------------% c | Accumulate the rotation in the matrix Q; Q <- Q*G | c %----------------------------------------------------% c do 50 j = 1, min( i+jj, kplusp ) a1 = c*q(j,i) + s*q(j,i+1) q(j,i+1) = - s*q(j,i) + c*q(j,i+1) q(j,i) = a1 50 continue c 70 continue c end if c c %--------------------------% c | Update the block pointer | c %--------------------------% c istart = iend + 1 c c %------------------------------------------% c | Make sure that h(iend,1) is non-negative | c | If not then set h(iend,1) <-- -h(iend,1) | c | and negate the last column of Q. | c | We have effectively carried out a | c | similarity on transformation H | c %------------------------------------------% c if (h(iend,1) .lt. zero) then h(iend,1) = -h(iend,1) call dscal(kplusp, -one, q(1,iend), 1) end if c c %--------------------------------------------------------% c | Apply the same shift to the next block if there is any | c %--------------------------------------------------------% c if (iend .lt. kplusp) go to 20 c c %-----------------------------------------------------% c | Check if we can increase the the start of the block | c %-----------------------------------------------------% c do 80 i = itop, kplusp-1 if (h(i+1,1) .gt. zero) go to 90 itop = itop + 1 80 continue c c %-----------------------------------% c | Finished applying the jj-th shift | c %-----------------------------------% c 90 continue c c %------------------------------------------% c | All shifts have been applied. Check for | c | more possible deflation that might occur | c | after the last shift is applied. | c %------------------------------------------% c do 100 i = itop, kplusp-1 big = abs(h(i,2)) + abs(h(i+1,2)) if (h(i+1,1) .le. epsmch*big) then if (msglvl .gt. 0) then call ivout (logfil, 1, i, ndigit, & '_sapps: deflation at row/column no.') call dvout (logfil, 1, h(i+1,1), ndigit, & '_sapps: the corresponding off diagonal element') end if h(i+1,1) = zero end if 100 continue c c %-------------------------------------------------% c | Compute the (kev+1)-st column of (V*Q) and | c | temporarily store the result in WORKD(N+1:2*N). | c | This is not necessary if h(kev+1,1) = 0. | c %-------------------------------------------------% c if ( h(kev+1,1) .gt. zero ) & call dgemv ('N', n, kplusp, one, v, ldv, & q(1,kev+1), 1, zero, workd(n+1), 1) c c %-------------------------------------------------------% c | Compute column 1 to kev of (V*Q) in backward order | c | taking advantage that Q is an upper triangular matrix | c | with lower bandwidth np. | c | Place results in v(:,kplusp-kev:kplusp) temporarily. | c %-------------------------------------------------------% c do 130 i = 1, kev call dgemv ('N', n, kplusp-i+1, one, v, ldv, & q(1,kev-i+1), 1, zero, workd, 1) call dcopy (n, workd, 1, v(1,kplusp-i+1), 1) 130 continue c c %-------------------------------------------------% c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | c %-------------------------------------------------% c call dlacpy ('All', n, kev, v(1,np+1), ldv, v, ldv) c c %--------------------------------------------% c | Copy the (kev+1)-st column of (V*Q) in the | c | appropriate place if h(kev+1,1) .ne. zero. | c %--------------------------------------------% c if ( h(kev+1,1) .gt. zero ) & call dcopy (n, workd(n+1), 1, v(1,kev+1), 1) c c %-------------------------------------% c | Update the residual vector: | c | r <- sigmak*r + betak*v(:,kev+1) | c | where | c | sigmak = (e_{kev+p}'*Q)*e_{kev} | c | betak = e_{kev+1}'*H*e_{kev} | c %-------------------------------------% c call dscal (n, q(kplusp,kev), resid, 1) if (h(kev+1,1) .gt. zero) & call daxpy (n, h(kev+1,1), v(1,kev+1), 1, resid, 1) c if (msglvl .gt. 1) then call dvout (logfil, 1, q(kplusp,kev), ndigit, & '_sapps: sigmak of the updated residual vector') call dvout (logfil, 1, h(kev+1,1), ndigit, & '_sapps: betak of the updated residual vector') call dvout (logfil, kev, h(1,2), ndigit, & '_sapps: updated main diagonal of H for next iteration') if (kev .gt. 1) then call dvout (logfil, kev-1, h(2,1), ndigit, & '_sapps: updated sub diagonal of H for next iteration') end if end if c call second (t1) tsapps = tsapps + (t1 - t0) c 9000 continue return c c %---------------% c | End of dsapps | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/snaupd.f000644 001750 001750 00000071617 11266605602 022122 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: snaupd c c\Description: c Reverse communication interface for the Implicitly Restarted Arnoldi c iteration. This subroutine computes approximations to a few eigenpairs c of a linear operator "OP" with respect to a semi-inner product defined by c a symmetric positive semi-definite real matrix B. B may be the identity c matrix. NOTE: If the linear operator "OP" is real and symmetric c with respect to the real positive semi-definite symmetric matrix B, c i.e. B*OP = (OP`)*B, then subroutine ssaupd should be used instead. c c The computed approximate eigenvalues are called Ritz values and c the corresponding approximate eigenvectors are called Ritz vectors. c c snaupd is usually called iteratively to solve one of the c following problems: c c Mode 1: A*x = lambda*x. c ===> OP = A and B = I. c c Mode 2: A*x = lambda*M*x, M symmetric positive definite c ===> OP = inv[M]*A and B = M. c ===> (If M can be factored see remark 3 below) c c Mode 3: A*x = lambda*M*x, M symmetric semi-definite c ===> OP = Real_Part{ inv[A - sigma*M]*M } and B = M. c ===> shift-and-invert mode (in real arithmetic) c If OP*x = amu*x, then c amu = 1/2 * [ 1/(lambda-sigma) + 1/(lambda-conjg(sigma)) ]. c Note: If sigma is real, i.e. imaginary part of sigma is zero; c Real_Part{ inv[A - sigma*M]*M } == inv[A - sigma*M]*M c amu == 1/(lambda-sigma). c c Mode 4: A*x = lambda*M*x, M symmetric semi-definite c ===> OP = Imaginary_Part{ inv[A - sigma*M]*M } and B = M. c ===> shift-and-invert mode (in real arithmetic) c If OP*x = amu*x, then c amu = 1/2i * [ 1/(lambda-sigma) - 1/(lambda-conjg(sigma)) ]. c c Both mode 3 and 4 give the same enhancement to eigenvalues close to c the (complex) shift sigma. However, as lambda goes to infinity, c the operator OP in mode 4 dampens the eigenvalues more strongly than c does OP defined in mode 3. c c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v c should be accomplished either by a direct method c using a sparse matrix factorization and solving c c [A - sigma*M]*w = v or M*w = v, c c or through an iterative method for solving these c systems. If an iterative method is used, the c convergence test must be more stringent than c the accuracy requirements for the eigenvalue c approximations. c c\Usage: c call snaupd c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, c IPNTR, WORKD, WORKL, LWORKL, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to snaupd. IDO will be set internally to c indicate the type of operation to be performed. Control is c then given back to the calling routine which has the c responsibility to carry out the requested operation and call c snaupd with the result. The operand is given in c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c In mode 3 and 4, the vector B * X is already c available in WORKD(ipntr(3)). It does not c need to be recomputed in forming OP * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 3: compute the IPARAM(8) real and imaginary parts c of the shifts where INPTR(14) is the pointer c into WORKL for placing the shifts. See Remark c 5 below. c IDO = 99: done c ------------------------------------------------------------- c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*B*x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c WHICH Character*2. (INPUT) c 'LM' -> want the NEV eigenvalues of largest magnitude. c 'SM' -> want the NEV eigenvalues of smallest magnitude. c 'LR' -> want the NEV eigenvalues of largest real part. c 'SR' -> want the NEV eigenvalues of smallest real part. c 'LI' -> want the NEV eigenvalues of largest imaginary part. c 'SI' -> want the NEV eigenvalues of smallest imaginary part. c c NEV Integer. (INPUT/OUTPUT) c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. c c TOL Real scalar. (INPUT) c Stopping criterion: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. c DEFAULT = SLAMCH('EPS') (machine precision as computed c by the LAPACK auxiliary subroutine SLAMCH). c c RESID Real array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V. NCV must satisfy the two c inequalities 2 <= NCV-NEV and NCV <= N. c This will indicate how many Arnoldi vectors are generated c at each iteration. After the startup phase in which NEV c Arnoldi vectors are generated, the algorithm generates c approximately NCV-NEV Arnoldi vectors at each subsequent update c iteration. Most of the cost in generating each Arnoldi vector is c in the matrix-vector operation OP*x. c NOTE: 2 <= NCV-NEV in order that complex conjugate pairs of Ritz c values are kept together. (See remark 4 below) c c V Real array N by NCV. (OUTPUT) c Contains the final set of Arnoldi basis vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling program. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. c The shifts selected at each iteration are used to restart c the Arnoldi iteration in an implicit fashion. c ------------------------------------------------------------- c ISHIFT = 0: the shifts are provided by the user via c reverse communication. The real and imaginary c parts of the NCV eigenvalues of the Hessenberg c matrix H are returned in the part of the WORKL c array corresponding to RITZR and RITZI. See remark c 5 below. c ISHIFT = 1: exact shifts with respect to the current c Hessenberg matrix H. This is equivalent to c restarting the iteration with a starting vector c that is a linear combination of approximate Schur c vectors associated with the "wanted" Ritz values. c ------------------------------------------------------------- c c IPARAM(2) = No longer referenced. c c IPARAM(3) = MXITER c On INPUT: maximum number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" Ritz values. c This represents the number of Ritz values that satisfy c the convergence criterion. c c IPARAM(6) = IUPD c No longer referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = MODE c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2,3,4; See under \Description of snaupd for the c four modes available. c c IPARAM(8) = NP c When ido = 3 and the user provides shifts through reverse c communication (IPARAM(1)=0), snaupd returns NP, the number c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark c 5 below. c c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, c OUTPUT: NUMOP = total number of OP*x operations, c NUMOPB = total number of B*x operations if BMAT='G', c NUMREO = total number of steps of re-orthogonalization. c c IPNTR Integer array of length 14. (OUTPUT) c Pointer to mark the starting locations in the WORKD and WORKL c arrays for matrices/vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X in WORKD. c IPNTR(2): pointer to the current result vector Y in WORKD. c IPNTR(3): pointer to the vector B * X in WORKD when used in c the shift-and-invert mode. c IPNTR(4): pointer to the next available location in WORKL c that is untouched by the program. c IPNTR(5): pointer to the NCV by NCV upper Hessenberg matrix c H in WORKL. c IPNTR(6): pointer to the real part of the ritz value array c RITZR in WORKL. c IPNTR(7): pointer to the imaginary part of the ritz value array c RITZI in WORKL. c IPNTR(8): pointer to the Ritz estimates in array WORKL associated c with the Ritz values located in RITZR and RITZI in WORKL. c c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. c c Note: IPNTR(9:13) is only referenced by sneupd. See Remark 2 below. c c IPNTR(9): pointer to the real part of the NCV RITZ values of the c original system. c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of c the original system. c IPNTR(11): pointer to the NCV corresponding error bounds. c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular c Schur matrix for H. c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors c of the upper Hessenberg matrix H. Only referenced by c sneupd if RVEC = .TRUE. See Remark 2 below. c ------------------------------------------------------------- c c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration. Upon termination c WORKD(1:N) contains B*RESID(1:N). If an invariant subspace c associated with the converged Ritz values is desired, see remark c 2 below, subroutine sneupd uses this output. c See Data Distribution Note below. c c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. See Data Distribution Note below. c c LWORKL Integer. (INPUT) c LWORKL must be at least 3*NCV**2 + 6*NCV. c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal exit. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. IPARAM(5) c returns the number of wanted converged Ritz values. c = 2: No longer an informational error. Deprecated starting c with release 2 of ARPACK. c = 3: No shifts could be applied during a cycle of the c Implicitly restarted Arnoldi iteration. One possibility c is to increase the size of NCV relative to NEV. c See remark 4 below. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 2 and less than or equal to N. c = -4: The maximum number of Arnoldi update iteration c must be greater than zero. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work array is not sufficient. c = -8: Error return from LAPACK eigenvalue calculation; c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3,4. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable. c = -12: IPARAM(1) must be equal to 0 or 1. c = -9999: Could not build an Arnoldi factorization. c IPARAM(5) returns the size of the current Arnoldi c factorization. c c\Remarks c 1. The computed Ritz values are approximate eigenvalues of OP. The c selection of WHICH should be made with this in mind when c Mode = 3 and 4. After convergence, approximate eigenvalues of the c original problem may be obtained with the ARPACK subroutine sneupd. c c 2. If a basis for the invariant subspace corresponding to the converged Ritz c values is needed, the user must call sneupd immediately following c completion of snaupd. This is new starting with release 2 of ARPACK. c c 3. If M can be factored into a Cholesky factorization M = LL` c then Mode = 2 should not be selected. Instead one should use c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular c linear systems should be solved with L and L` rather c than computing inverses. After convergence, an approximate c eigenvector z of the original problem is recovered by solving c L`z = x where x is a Ritz vector of OP. c c 4. At present there is no a-priori analysis to guide the selection c of NCV relative to NEV. The only formal requrement is that NCV > NEV + 2. c However, it is recommended that NCV .ge. 2*NEV+1. If many problems of c the same type are to be solved, one should experiment with increasing c NCV while keeping NEV fixed for a given test problem. This will c usually decrease the required number of OP*x operations but it c also increases the work and storage required to maintain the orthogonal c basis vectors. The optimal "cross-over" with respect to CPU time c is problem dependent and must be determined empirically. c See Chapter 8 of Reference 2 for further information. c c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the c NP = IPARAM(8) real and imaginary parts of the shifts in locations c real part imaginary part c ----------------------- -------------- c 1 WORKL(IPNTR(14)) WORKL(IPNTR(14)+NP) c 2 WORKL(IPNTR(14)+1) WORKL(IPNTR(14)+NP+1) c . . c . . c . . c NP WORKL(IPNTR(14)+NP-1) WORKL(IPNTR(14)+2*NP-1). c c Only complex conjugate pairs of shifts may be applied and the pairs c must be placed in consecutive locations. The real part of the c eigenvalues of the current upper Hessenberg matrix are located in c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1) and the imaginary part c in WORKL(IPNTR(7)) through WORKL(IPNTR(7)+NCV-1). They are ordered c according to the order defined by WHICH. The complex conjugate c pairs are kept together and the associated Ritz estimates are located in c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). c c----------------------------------------------------------------------- c c\Data Distribution Note: c c Fortran-D syntax: c ================ c Real resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) c decompose d1(n), d2(n,ncv) c align resid(i) with d1(i) c align v(i,j) with d2(i,j) c align workd(i) with d1(i) range (1:n) c align workd(i) with d1(i-n) range (n+1:2*n) c align workd(i) with d1(i-2*n) range (2*n+1:3*n) c distribute d1(block), d2(block,:) c replicated workl(lworkl) c c Cray MPP syntax: c =============== c Real resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) c shared resid(block), v(block,:), workd(block,:) c replicated workl(lworkl) c c CM2/CM5 syntax: c ============== c c----------------------------------------------------------------------- c c include 'ex-nonsym.doc' c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for c Real Matrices", Linear Algebra and its Applications, vol 88/89, c pp 575-595, (1987). c c\Routines called: c snaup2 ARPACK routine that implements the Implicitly Restarted c Arnoldi Iteration. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c svout ARPACK utility routine that prints vectors. c slamch LAPACK routine that determines machine constants. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/16/93: Version '1.1' c c\SCCS Information: @(#) c FILE: naupd.F SID: 2.10 DATE OF SID: 08/23/02 RELEASE: 2 c c\Remarks c c\EndLib c c----------------------------------------------------------------------- c subroutine snaupd & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, & ipntr, workd, workl, lworkl, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ldv, lworkl, n, ncv, nev Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(14) Real & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %---------------% c | Local Scalars | c %---------------% c integer bounds, ierr, ih, iq, ishift, iupd, iw, & ldh, ldq, levec, mode, msglvl, mxiter, nb, & nev0, next, np, ritzi, ritzr, j save bounds, ih, iq, ishift, iupd, iw, ldh, ldq, & levec, mode, msglvl, mxiter, nb, nev0, next, & np, ritzi, ritzr c c %----------------------% c | External Subroutines | c %----------------------% c external snaup2, svout, ivout, second, sstatn c c %--------------------% c | External Functions | c %--------------------% c Real & slamch external slamch c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call sstatn call second (t0) msglvl = mnaupd c c %----------------% c | Error checking | c %----------------% c ierr = 0 ishift = iparam(1) c levec = iparam(2) mxiter = iparam(3) c nb = iparam(4) nb = 1 c c %--------------------------------------------% c | Revision 2 performs only implicit restart. | c %--------------------------------------------% c iupd = 1 mode = iparam(7) c if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev+1 .or. ncv .gt. n) then ierr = -3 else if (mxiter .le. 0) then ierr = 4 else if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LR' .and. & which .ne. 'SR' .and. & which .ne. 'LI' .and. & which .ne. 'SI') then ierr = -5 else if (bmat .ne. 'I' .and. bmat .ne. 'G') then ierr = -6 else if (lworkl .lt. 3*ncv**2 + 6*ncv) then ierr = -7 else if (mode .lt. 1 .or. mode .gt. 4) then ierr = -10 else if (mode .eq. 1 .and. bmat .eq. 'G') then ierr = -11 else if (ishift .lt. 0 .or. ishift .gt. 1) then ierr = -12 end if c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr ido = 99 go to 9000 end if c c %------------------------% c | Set default parameters | c %------------------------% c if (nb .le. 0) nb = 1 if (tol .le. zero) tol = slamch('EpsMach') c c %----------------------------------------------% c | NP is the number of additional steps to | c | extend the length NEV Lanczos factorization. | c | NEV0 is the local variable designating the | c | size of the invariant subspace desired. | c %----------------------------------------------% c np = ncv - nev nev0 = nev c c %-----------------------------% c | Zero out internal workspace | c %-----------------------------% c do 10 j = 1, 3*ncv**2 + 6*ncv workl(j) = zero 10 continue c c %-------------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:ncv*ncv) := generated Hessenberg matrix | c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | c | parts of ritz values | c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | c | workl(ncv*ncv+3*ncv+1:2*ncv*ncv+3*ncv) := rotation matrix Q | c | workl(2*ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) := workspace | c | The final workspace is needed by subroutine sneigh called | c | by snaup2. Subroutine sneigh calls LAPACK routines for | c | calculating eigenvalues and the last row of the eigenvector | c | matrix. | c %-------------------------------------------------------------% c ldh = ncv ldq = ncv ih = 1 ritzr = ih + ldh*ncv ritzi = ritzr + ncv bounds = ritzi + ncv iq = bounds + ncv iw = iq + ldq*ncv next = iw + ncv**2 + 3*ncv c ipntr(4) = next ipntr(5) = ih ipntr(6) = ritzr ipntr(7) = ritzi ipntr(8) = bounds ipntr(14) = iw c end if c c %-------------------------------------------------------% c | Carry out the Implicitly restarted Arnoldi Iteration. | c %-------------------------------------------------------% c call snaup2 & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritzr), & workl(ritzi), workl(bounds), workl(iq), ldq, workl(iw), & ipntr, workd, info ) c c %--------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP or shifts. | c %--------------------------------------------------% c if (ido .eq. 3) iparam(8) = np if (ido .ne. 99) go to 9000 c iparam(3) = mxiter iparam(5) = np iparam(9) = nopx iparam(10) = nbx iparam(11) = nrorth c c %------------------------------------% c | Exit if there was an informational | c | error within snaup2. | c %------------------------------------% c if (info .lt. 0) go to 9000 if (info .eq. 2) info = 3 c if (msglvl .gt. 0) then call ivout (logfil, 1, mxiter, ndigit, & '_naupd: Number of update iterations taken') call ivout (logfil, 1, np, ndigit, & '_naupd: Number of wanted "converged" Ritz values') call svout (logfil, np, workl(ritzr), ndigit, & '_naupd: Real part of the final Ritz values') call svout (logfil, np, workl(ritzi), ndigit, & '_naupd: Imaginary part of the final Ritz values') call svout (logfil, np, workl(bounds), ndigit, & '_naupd: Associated Ritz estimates') end if c call second (t1) tnaupd = t1 - t0 c if (msglvl .gt. 0) then c c %--------------------------------------------------------% c | Version Number & Version Date are defined in version.h | c %--------------------------------------------------------% c write (6,1000) write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, & tmvopx, tmvbx, tnaupd, tnaup2, tnaitr, titref, & tgetv0, tneigh, tngets, tnapps, tnconv, trvec 1000 format (//, & 5x, '=============================================',/ & 5x, '= Nonsymmetric implicit Arnoldi update code =',/ & 5x, '= Version Number: ', ' 2.4', 21x, ' =',/ & 5x, '= Version Date: ', ' 07/31/96', 16x, ' =',/ & 5x, '=============================================',/ & 5x, '= Summary of timing statistics =',/ & 5x, '=============================================',//) 1100 format ( & 5x, 'Total number update iterations = ', i5,/ & 5x, 'Total number of OP*x operations = ', i5,/ & 5x, 'Total number of B*x operations = ', i5,/ & 5x, 'Total number of reorthogonalization steps = ', i5,/ & 5x, 'Total number of iterative refinement steps = ', i5,/ & 5x, 'Total number of restart steps = ', i5,/ & 5x, 'Total time in user OP*x operation = ', f12.6,/ & 5x, 'Total time in user B*x operation = ', f12.6,/ & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ & 5x, 'Total time in naup2 routine = ', f12.6,/ & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ & 5x, 'Total time in (re)start vector generation = ', f12.6,/ & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ & 5x, 'Total time in getting the shifts = ', f12.6,/ & 5x, 'Total time in applying the shifts = ', f12.6,/ & 5x, 'Total time in convergence testing = ', f12.6,/ & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) end if c 9000 continue c return c c %---------------% c | End of snaupd | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/smout.f000644 001750 001750 00000012145 11266605602 021766 0ustar00geuzainegeuzaine000000 000000 *----------------------------------------------------------------------- * Routine: SMOUT * * Purpose: Real matrix output routine. * * Usage: CALL SMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) * * Arguments * M - Number of rows of A. (Input) * N - Number of columns of A. (Input) * A - Real M by N matrix to be printed. (Input) * LDA - Leading dimension of A exactly as specified in the * dimension statement of the calling program. (Input) * IFMT - Format to be used in printing matrix A. (Input) * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) * If IDIGIT .LT. 0, printing is done with 72 columns. * If IDIGIT .GT. 0, printing is done with 132 columns. * *----------------------------------------------------------------------- * SUBROUTINE SMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) * ... * ... SPECIFICATIONS FOR ARGUMENTS INTEGER M, N, IDIGIT, LDA, LOUT REAL A( LDA, * ) CHARACTER IFMT*( * ) * ... * ... SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I, J, NDIGIT, K1, K2, LLL CHARACTER*1 ICOL( 3 ) CHARACTER*80 LINE * ... * ... SPECIFICATIONS INTRINSICS INTRINSIC MIN * DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', $ 'l' / * ... * ... FIRST EXECUTABLE STATEMENT * LLL = MIN( LEN( IFMT ), 80 ) DO 10 I = 1, LLL LINE( I: I ) = '-' 10 CONTINUE * DO 20 I = LLL + 1, 80 LINE( I: I ) = ' ' 20 CONTINUE * WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) 9999 FORMAT( / 1X, A / 1X, A ) * IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) $ RETURN NDIGIT = IDIGIT IF( IDIGIT.EQ.0 ) $ NDIGIT = 4 * *======================================================================= * CODE FOR OUTPUT USING 72 COLUMNS FORMAT *======================================================================= * IF( IDIGIT.LT.0 ) THEN NDIGIT = -IDIGIT IF( NDIGIT.LE.4 ) THEN DO 40 K1 = 1, N, 5 K2 = MIN0( N, K1+4 ) WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) DO 30 I = 1, M WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 ) 30 CONTINUE 40 CONTINUE * ELSE IF( NDIGIT.LE.6 ) THEN DO 60 K1 = 1, N, 4 K2 = MIN0( N, K1+3 ) WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) DO 50 I = 1, M WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 ) 50 CONTINUE 60 CONTINUE * ELSE IF( NDIGIT.LE.10 ) THEN DO 80 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) DO 70 I = 1, M WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 ) 70 CONTINUE 80 CONTINUE * ELSE DO 100 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 ) DO 90 I = 1, M WRITE( LOUT, 9991 )I, ( A( I, J ), J = K1, K2 ) 90 CONTINUE 100 CONTINUE END IF * *======================================================================= * CODE FOR OUTPUT USING 132 COLUMNS FORMAT *======================================================================= * ELSE IF( NDIGIT.LE.4 ) THEN DO 120 K1 = 1, N, 10 K2 = MIN0( N, K1+9 ) WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) DO 110 I = 1, M WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 ) 110 CONTINUE 120 CONTINUE * ELSE IF( NDIGIT.LE.6 ) THEN DO 140 K1 = 1, N, 8 K2 = MIN0( N, K1+7 ) WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) DO 130 I = 1, M WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 ) 130 CONTINUE 140 CONTINUE * ELSE IF( NDIGIT.LE.10 ) THEN DO 160 K1 = 1, N, 6 K2 = MIN0( N, K1+5 ) WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) DO 150 I = 1, M WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 ) 150 CONTINUE 160 CONTINUE * ELSE DO 180 K1 = 1, N, 5 K2 = MIN0( N, K1+4 ) WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 ) DO 170 I = 1, M WRITE( LOUT, 9991 )I, ( A( I, J ), J = K1, K2 ) 170 CONTINUE 180 CONTINUE END IF END IF WRITE( LOUT, 9990 ) * 9998 FORMAT( 10X, 10( 4X, 3A1, I4, 1X ) ) 9997 FORMAT( 10X, 8( 5X, 3A1, I4, 2X ) ) 9996 FORMAT( 10X, 6( 7X, 3A1, I4, 4X ) ) 9995 FORMAT( 10X, 5( 9X, 3A1, I4, 6X ) ) 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P10E12.3 ) 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P8E14.5 ) 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P6E18.9 ) 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P5E22.13 ) 9990 FORMAT( 1X, ' ' ) * RETURN END getdp-2.4.2-source/contrib/Arpack/zneigh.f000644 001750 001750 00000020070 11266605602 022077 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: zneigh c c\Description: c Compute the eigenvalues of the current upper Hessenberg matrix c and the corresponding Ritz estimates given the current residual norm. c c\Usage: c call zneigh c ( RNORM, N, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, RWORK, IERR ) c c\Arguments c RNORM Double precision scalar. (INPUT) c Residual norm corresponding to the current upper Hessenberg c matrix H. c c N Integer. (INPUT) c Size of the matrix H. c c H Complex*16 N by N array. (INPUT) c H contains the current upper Hessenberg matrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZ Complex*16 array of length N. (OUTPUT) c On output, RITZ(1:N) contains the eigenvalues of H. c c BOUNDS Complex*16 array of length N. (OUTPUT) c On output, BOUNDS contains the Ritz estimates associated with c the eigenvalues held in RITZ. This is equal to RNORM c times the last components of the eigenvectors corresponding c to the eigenvalues in RITZ. c c Q Complex*16 N by N array. (WORKSPACE) c Workspace needed to store the eigenvectors of H. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Complex*16 work array of length N**2 + 3*N. (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. This is needed to keep the full Schur form c of H and also in the calculation of the eigenvectors of H. c c RWORK Double precision work array of length N (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c IERR Integer. (OUTPUT) c Error exit flag from zlahqr or ztrevc. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex*16 c c\Routines called: c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c zmout ARPACK utility routine that prints matrices c zvout ARPACK utility routine that prints vectors. c dvout ARPACK utility routine that prints vectors. c zlacpy LAPACK matrix copy routine. c zlahqr LAPACK routine to compute the Schur form of an c upper Hessenberg matrix. c zlaset LAPACK matrix initialization routine. c ztrevc LAPACK routine to compute the eigenvectors of a matrix c in upper triangular form c zcopy Level 1 BLAS that copies one vector to another. c zdscal Level 1 BLAS that scales a complex vector by a real number. c dznrm2 Level 1 BLAS that computes the norm of a vector. c c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: neigh.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c None c c\EndLib c c----------------------------------------------------------------------- c subroutine zneigh (rnorm, n, h, ldh, ritz, bounds, & q, ldq, workl, rwork, ierr) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer ierr, n, ldh, ldq Double precision & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c Complex*16 & bounds(n), h(ldh,n), q(ldq,n), ritz(n), & workl(n*(n+3)) Double precision & rwork(n) c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero Double precision & rone parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0), & rone = 1.0D+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c logical select(1) integer j, msglvl Complex*16 & vl(1) Double precision & temp c c %----------------------% c | External Subroutines | c %----------------------% c external zlacpy, zlahqr, ztrevc, zcopy, & zdscal, zmout, zvout, second c c %--------------------% c | External Functions | c %--------------------% c Double precision & dznrm2 external dznrm2 c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mceigh c if (msglvl .gt. 2) then call zmout (logfil, n, n, h, ldh, ndigit, & '_neigh: Entering upper Hessenberg matrix H ') end if c c %----------------------------------------------------------% c | 1. Compute the eigenvalues, the last components of the | c | corresponding Schur vectors and the full Schur form T | c | of the current upper Hessenberg matrix H. | c | zlahqr returns the full Schur form of H | c | in WORKL(1:N**2), and the Schur vectors in q. | c %----------------------------------------------------------% c call zlacpy ('All', n, n, h, ldh, workl, n) call zlaset ('All', n, n, zero, one, q, ldq) call zlahqr (.true., .true., n, 1, n, workl, ldh, ritz, & 1, n, q, ldq, ierr) if (ierr .ne. 0) go to 9000 c call zcopy (n, q(n-1,1), ldq, bounds, 1) if (msglvl .gt. 1) then call zvout (logfil, n, bounds, ndigit, & '_neigh: last row of the Schur matrix for H') end if c c %----------------------------------------------------------% c | 2. Compute the eigenvectors of the full Schur form T and | c | apply the Schur vectors to get the corresponding | c | eigenvectors. | c %----------------------------------------------------------% c call ztrevc ('Right', 'Back', select, n, workl, n, vl, n, q, & ldq, n, n, workl(n*n+1), rwork, ierr) c if (ierr .ne. 0) go to 9000 c c %------------------------------------------------% c | Scale the returning eigenvectors so that their | c | Euclidean norms are all one. LAPACK subroutine | c | ztrevc returns each eigenvector normalized so | c | that the element of largest magnitude has | c | magnitude 1; here the magnitude of a complex | c | number (x,y) is taken to be |x| + |y|. | c %------------------------------------------------% c do 10 j=1, n temp = dznrm2( n, q(1,j), 1 ) call zdscal ( n, rone / temp, q(1,j), 1 ) 10 continue c if (msglvl .gt. 1) then call zcopy(n, q(n,1), ldq, workl, 1) call zvout (logfil, n, workl, ndigit, & '_neigh: Last row of the eigenvector matrix for H') end if c c %----------------------------% c | Compute the Ritz estimates | c %----------------------------% c call zcopy(n, q(n,1), n, bounds, 1) call zdscal(n, rnorm, bounds, 1) c if (msglvl .gt. 2) then call zvout (logfil, n, ritz, ndigit, & '_neigh: The eigenvalues of H') call zvout (logfil, n, bounds, ndigit, & '_neigh: Ritz estimates for the eigenvalues of H') end if c call second(t1) tceigh = tceigh + (t1 - t0) c 9000 continue return c c %---------------% c | End of zneigh | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/zngets.f000644 001750 001750 00000012712 11266605602 022131 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: zngets c c\Description: c Given the eigenvalues of the upper Hessenberg matrix H, c computes the NP shifts AMU that are zeros of the polynomial of c degree NP which filters out components of the unwanted eigenvectors c corresponding to the AMU's based on some given criteria. c c NOTE: call this even in the case of user specified shifts in order c to sort the eigenvalues, and error bounds of H for later use. c c\Usage: c call zngets c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS ) c c\Arguments c ISHIFT Integer. (INPUT) c Method for selecting the implicit shifts at each iteration. c ISHIFT = 0: user specified shifts c ISHIFT = 1: exact shift with respect to the matrix H. c c WHICH Character*2. (INPUT) c Shift selection criteria. c 'LM' -> want the KEV eigenvalues of largest magnitude. c 'SM' -> want the KEV eigenvalues of smallest magnitude. c 'LR' -> want the KEV eigenvalues of largest REAL part. c 'SR' -> want the KEV eigenvalues of smallest REAL part. c 'LI' -> want the KEV eigenvalues of largest imaginary part. c 'SI' -> want the KEV eigenvalues of smallest imaginary part. c c KEV Integer. (INPUT) c The number of desired eigenvalues. c c NP Integer. (INPUT) c The number of shifts to compute. c c RITZ Complex*16 array of length KEV+NP. (INPUT/OUTPUT) c On INPUT, RITZ contains the the eigenvalues of H. c On OUTPUT, RITZ are sorted so that the unwanted c eigenvalues are in the first NP locations and the wanted c portion is in the last KEV locations. When exact shifts are c selected, the unwanted part corresponds to the shifts to c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues c are further sorted so that the ones with largest Ritz values c are first. c c BOUNDS Complex*16 array of length KEV+NP. (INPUT/OUTPUT) c Error bounds corresponding to the ordering in RITZ. c c c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex*16 c c\Routines called: c zsortc ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c zvout ARPACK utility routine that prints vectors. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ngets.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c 1. This routine does not keep complex conjugate pairs of c eigenvalues together. c c\EndLib c c----------------------------------------------------------------------- c subroutine zngets ( ishift, which, kev, np, ritz, bounds) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which integer ishift, kev, np c c %-----------------% c | Array Arguments | c %-----------------% c Complex*16 & bounds(kev+np), ritz(kev+np) c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0)) c c %---------------% c | Local Scalars | c %---------------% c integer msglvl c c %----------------------% c | External Subroutines | c %----------------------% c external zvout, zsortc, second c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mcgets c call zsortc (which, .true., kev+np, ritz, bounds) c if ( ishift .eq. 1 ) then c c %-------------------------------------------------------% c | Sort the unwanted Ritz values used as shifts so that | c | the ones with largest Ritz estimates are first | c | This will tend to minimize the effects of the | c | forward instability of the iteration when the shifts | c | are applied in subroutine znapps. | c | Be careful and use 'SM' since we want to sort BOUNDS! | c %-------------------------------------------------------% c call zsortc ( 'SM', .true., np, bounds, ritz ) c end if c call second (t1) tcgets = tcgets + (t1 - t0) c if (msglvl .gt. 0) then call ivout (logfil, 1, kev, ndigit, '_ngets: KEV is') call ivout (logfil, 1, np, ndigit, '_ngets: NP is') call zvout (logfil, kev+np, ritz, ndigit, & '_ngets: Eigenvalues of current H matrix ') call zvout (logfil, kev+np, bounds, ndigit, & '_ngets: Ritz estimates of the current KEV+NP Ritz values') end if c return c c %---------------% c | End of zngets | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dnaitr.f000644 001750 001750 00000073673 11266605602 022115 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dnaitr c c\Description: c Reverse communication interface for applying NP additional steps to c a K step nonsymmetric Arnoldi factorization. c c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T c c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. c c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T c c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. c c where OP and B are as in dnaupd. The B-norm of r_{k+p} is also c computed and returned. c c\Usage: c call dnaitr c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, c IPNTR, WORKD, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c This is for the restart phase to force the new c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y, c IPNTR(3) is the pointer into WORK for B * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c IDO = 99: done c ------------------------------------------------------------- c When the routine is used in the "shift-and-invert" mode, the c vector B * Q is already available and do not need to be c recompute in forming OP * Q. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. See dnaupd. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c K Integer. (INPUT) c Current size of V and H. c c NP Integer. (INPUT) c Number of additional Arnoldi steps to take. c c NB Integer. (INPUT) c Blocksize to be used in the recurrence. c Only work for NB = 1 right now. The goal is to have a c program that implement both the block and non-block method. c c RESID Double precision array of length N. (INPUT/OUTPUT) c On INPUT: RESID contains the residual vector r_{k}. c On OUTPUT: RESID contains the residual vector r_{k+p}. c c RNORM Double precision scalar. (INPUT/OUTPUT) c B-norm of the starting residual on input. c B-norm of the updated residual r_{k+p} on output. c c V Double precision N by K+NP array. (INPUT/OUTPUT) c On INPUT: V contains the Arnoldi vectors in the first K c columns. c On OUTPUT: V contains the new NP Arnoldi vectors in the next c NP columns. The first K columns are unchanged. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Double precision (K+NP) by (K+NP) array. (INPUT/OUTPUT) c H is used to store the generated upper Hessenberg matrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORK for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The calling program should not c use WORKD as temporary workspace during the iteration !!!!!! c On input, WORKD(1:N) = B*RESID and is used to save some c computation at the first step. c c INFO Integer. (OUTPUT) c = 0: Normal exit. c > 0: Size of the spanning invariant subspace of OP found. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c dgetv0 ARPACK routine to generate the initial vector. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c dmout ARPACK utility routine that prints matrices c dvout ARPACK utility routine that prints vectors. c dlabad LAPACK routine that computes machine constants. c dlamch LAPACK routine that determines machine constants. c dlascl LAPACK routine for careful scaling of a matrix. c dlanhs LAPACK routine that computes various norms of a matrix. c dgemv Level 2 BLAS routine for matrix vector multiplication. c daxpy Level 1 BLAS that computes a vector triad. c dscal Level 1 BLAS that scales a vector. c dcopy Level 1 BLAS that copies one vector to another . c ddot Level 1 BLAS that computes the scalar product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.4' c c\SCCS Information: @(#) c FILE: naitr.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c The algorithm implemented is: c c restart = .false. c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; c r_{k} contains the initial residual vector even for k = 0; c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already c computed by the calling program. c c betaj = rnorm ; p_{k+1} = B*r_{k} ; c For j = k+1, ..., k+np Do c 1) if ( betaj < tol ) stop or restart depending on j. c ( At present tol is zero ) c if ( restart ) generate a new starting vector. c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; c p_{j} = p_{j}/betaj c 3) r_{j} = OP*v_{j} where OP is defined as in dnaupd c For shift-invert mode p_{j} = B*v_{j} is already available. c wnorm = || OP*v_{j} || c 4) Compute the j-th step residual vector. c w_{j} = V_{j}^T * B * OP * v_{j} c r_{j} = OP*v_{j} - V_{j} * w_{j} c H(:,j) = w_{j}; c H(j,j-1) = rnorm c rnorm = || r_(j) || c If (rnorm > 0.717*wnorm) accept step and go back to 1) c 5) Re-orthogonalization step: c s = V_{j}'*B*r_{j} c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || c alphaj = alphaj + s_{j}; c 6) Iterative refinement step: c If (rnorm1 > 0.717*rnorm) then c rnorm = rnorm1 c accept step and go back to 1) c Else c rnorm = rnorm1 c If this is the first time in step 6), go to 5) c Else r_{j} lies in the span of V_{j} numerically. c Set r_{j} = 0 and rnorm = 0; go to 1) c EndIf c End Do c c\EndLib c c----------------------------------------------------------------------- c subroutine dnaitr & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, & ipntr, workd, info) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 integer ido, info, k, ldh, ldv, n, nb, np Double precision & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Double precision & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %---------------% c | Local Scalars | c %---------------% c logical first, orth1, orth2, rstart, step3, step4 integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, & jj Double precision & betaj, ovfl, temp1, rnorm1, smlnum, tst1, ulp, unfl, & wnorm save first, orth1, orth2, rstart, step3, step4, & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, & betaj, rnorm1, smlnum, ulp, unfl, wnorm c c %-----------------------% c | Local Array Arguments | c %-----------------------% c Double precision & xtemp(2) c c %----------------------% c | External Subroutines | c %----------------------% c external daxpy, dcopy, dscal, dgemv, dgetv0, dlabad, & dvout, dmout, ivout, second c c %--------------------% c | External Functions | c %--------------------% c Double precision & ddot, dnrm2, dlanhs, dlamch external ddot, dnrm2, dlanhs, dlamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs, sqrt c c %-----------------% c | Data statements | c %-----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then c c %-----------------------------------------% c | Set machine-dependent constants for the | c | the splitting and deflation criterion. | c | If norm(H) <= sqrt(OVFL), | c | overflow should not occur. | c | REFERENCE: LAPACK subroutine dlahqr | c %-----------------------------------------% c unfl = dlamch( 'safe minimum' ) ovfl = one / unfl call dlabad( unfl, ovfl ) ulp = dlamch( 'precision' ) smlnum = unfl*( n / ulp ) first = .false. end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mnaitr c c %------------------------------% c | Initial call to this routine | c %------------------------------% c info = 0 step3 = .false. step4 = .false. rstart = .false. orth1 = .false. orth2 = .false. j = k + 1 ipj = 1 irj = ipj + n ivj = irj + n end if c c %-------------------------------------------------% c | When in reverse communication mode one of: | c | STEP3, STEP4, ORTH1, ORTH2, RSTART | c | will be .true. when .... | c | STEP3: return from computing OP*v_{j}. | c | STEP4: return from computing B-norm of OP*v_{j} | c | ORTH1: return from computing B-norm of r_{j+1} | c | ORTH2: return from computing B-norm of | c | correction to the residual vector. | c | RSTART: return from OP computations needed by | c | dgetv0. | c %-------------------------------------------------% c if (step3) go to 50 if (step4) go to 60 if (orth1) go to 70 if (orth2) go to 90 if (rstart) go to 30 c c %-----------------------------% c | Else this is the first step | c %-----------------------------% c c %--------------------------------------------------------------% c | | c | A R N O L D I I T E R A T I O N L O O P | c | | c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | c %--------------------------------------------------------------% 1000 continue c if (msglvl .gt. 1) then call ivout (logfil, 1, j, ndigit, & '_naitr: generating Arnoldi vector number') call dvout (logfil, 1, rnorm, ndigit, & '_naitr: B-norm of the current residual is') end if c c %---------------------------------------------------% c | STEP 1: Check if the B norm of j-th residual | c | vector is zero. Equivalent to determing whether | c | an exact j-step Arnoldi factorization is present. | c %---------------------------------------------------% c betaj = rnorm if (rnorm .gt. zero) go to 40 c c %---------------------------------------------------% c | Invariant subspace found, generate a new starting | c | vector which is orthogonal to the current Arnoldi | c | basis and continue the iteration. | c %---------------------------------------------------% c if (msglvl .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_naitr: ****** RESTART AT STEP ******') end if c c %---------------------------------------------% c | ITRY is the loop variable that controls the | c | maximum amount of times that a restart is | c | attempted. NRSTRT is used by stat.h | c %---------------------------------------------% c betaj = zero nrstrt = nrstrt + 1 itry = 1 20 continue rstart = .true. ido = 0 30 continue c c %--------------------------------------% c | If in reverse communication mode and | c | RSTART = .true. flow returns here. | c %--------------------------------------% c call dgetv0 (ido, bmat, itry, .false., n, j, v, ldv, & resid, rnorm, ipntr, workd, ierr) if (ido .ne. 99) go to 9000 if (ierr .lt. 0) then itry = itry + 1 if (itry .le. 3) go to 20 c c %------------------------------------------------% c | Give up after several restart attempts. | c | Set INFO to the size of the invariant subspace | c | which spans OP and exit. | c %------------------------------------------------% c info = j - 1 call second (t1) tnaitr = tnaitr + (t1 - t0) ido = 99 go to 9000 end if c 40 continue c c %---------------------------------------------------------% c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | c | when reciprocating a small RNORM, test against lower | c | machine bound. | c %---------------------------------------------------------% c call dcopy (n, resid, 1, v(1,j), 1) if (rnorm .ge. unfl) then temp1 = one / rnorm call dscal (n, temp1, v(1,j), 1) call dscal (n, temp1, workd(ipj), 1) else c c %-----------------------------------------% c | To scale both v_{j} and p_{j} carefully | c | use LAPACK routine SLASCL | c %-----------------------------------------% c call dlascl ('General', i, i, rnorm, one, n, 1, & v(1,j), n, infol) call dlascl ('General', i, i, rnorm, one, n, 1, & workd(ipj), n, infol) end if c c %------------------------------------------------------% c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | c | Note that this is not quite yet r_{j}. See STEP 4 | c %------------------------------------------------------% c step3 = .true. nopx = nopx + 1 call second (t2) call dcopy (n, v(1,j), 1, workd(ivj), 1) ipntr(1) = ivj ipntr(2) = irj ipntr(3) = ipj ido = 1 c c %-----------------------------------% c | Exit in order to compute OP*v_{j} | c %-----------------------------------% c go to 9000 50 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | c | if step3 = .true. | c %----------------------------------% c call second (t3) tmvopx = tmvopx + (t3 - t2) step3 = .false. c c %------------------------------------------% c | Put another copy of OP*v_{j} into RESID. | c %------------------------------------------% c call dcopy (n, workd(irj), 1, resid, 1) c c %---------------------------------------% c | STEP 4: Finish extending the Arnoldi | c | factorization to length j. | c %---------------------------------------% c call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 step4 = .true. ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-------------------------------------% c | Exit in order to compute B*OP*v_{j} | c %-------------------------------------% c go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd(ipj), 1) end if 60 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | c | if step4 = .true. | c %----------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c step4 = .false. c c %-------------------------------------% c | The following is needed for STEP 5. | c | Compute the B-norm of OP*v_{j}. | c %-------------------------------------% c if (bmat .eq. 'G') then wnorm = ddot (n, resid, 1, workd(ipj), 1) wnorm = sqrt(abs(wnorm)) else if (bmat .eq. 'I') then wnorm = dnrm2(n, resid, 1) end if c c %-----------------------------------------% c | Compute the j-th residual corresponding | c | to the j step factorization. | c | Use Classical Gram Schmidt and compute: | c | w_{j} <- V_{j}^T * B * OP * v_{j} | c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | c %-----------------------------------------% c c c %------------------------------------------% c | Compute the j Fourier coefficients w_{j} | c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | c %------------------------------------------% c call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1, & zero, h(1,j), 1) c c %--------------------------------------% c | Orthogonalize r_{j} against V_{j}. | c | RESID contains OP*v_{j}. See STEP 3. | c %--------------------------------------% c call dgemv ('N', n, j, -one, v, ldv, h(1,j), 1, & one, resid, 1) c if (j .gt. 1) h(j,j-1) = betaj c call second (t4) c orth1 = .true. c call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call dcopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %----------------------------------% c | Exit in order to compute B*r_{j} | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd(ipj), 1) end if 70 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH1 = .true. | c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c orth1 = .false. c c %------------------------------% c | Compute the B-norm of r_{j}. | c %------------------------------% c if (bmat .eq. 'G') then rnorm = ddot (n, resid, 1, workd(ipj), 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = dnrm2(n, resid, 1) end if c c %-----------------------------------------------------------% c | STEP 5: Re-orthogonalization / Iterative refinement phase | c | Maximum NITER_ITREF tries. | c | | c | s = V_{j}^T * B * r_{j} | c | r_{j} = r_{j} - V_{j}*s | c | alphaj = alphaj + s_{j} | c | | c | The stopping criteria used for iterative refinement is | c | discussed in Parlett's book SEP, page 107 and in Gragg & | c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | c | Determine if we need to correct the residual. The goal is | c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | c | The following test determines whether the sine of the | c | angle between OP*x and the computed residual is less | c | than or equal to 0.717. | c %-----------------------------------------------------------% c if (rnorm .gt. 0.717*wnorm) go to 100 iter = 0 nrorth = nrorth + 1 c c %---------------------------------------------------% c | Enter the Iterative refinement phase. If further | c | refinement is necessary, loop back here. The loop | c | variable is ITER. Perform a step of Classical | c | Gram-Schmidt using all the Arnoldi vectors V_{j} | c %---------------------------------------------------% c 80 continue c if (msglvl .gt. 2) then xtemp(1) = wnorm xtemp(2) = rnorm call dvout (logfil, 2, xtemp, ndigit, & '_naitr: re-orthonalization; wnorm and rnorm are') call dvout (logfil, j, h(1,j), ndigit, & '_naitr: j-th column of H') end if c c %----------------------------------------------------% c | Compute V_{j}^T * B * r_{j}. | c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | c %----------------------------------------------------% c call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1, & zero, workd(irj), 1) c c %---------------------------------------------% c | Compute the correction to the residual: | c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | c | The correction to H is v(:,1:J)*H(1:J,1:J) | c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | c %---------------------------------------------% c call dgemv ('N', n, j, -one, v, ldv, workd(irj), 1, & one, resid, 1) call daxpy (j, one, workd(irj), 1, h(1,j), 1) c orth2 = .true. call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call dcopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-----------------------------------% c | Exit in order to compute B*r_{j}. | c | r_{j} is the corrected residual. | c %-----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd(ipj), 1) end if 90 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH2 = .true. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c c %-----------------------------------------------------% c | Compute the B-norm of the corrected residual r_{j}. | c %-----------------------------------------------------% c if (bmat .eq. 'G') then rnorm1 = ddot (n, resid, 1, workd(ipj), 1) rnorm1 = sqrt(abs(rnorm1)) else if (bmat .eq. 'I') then rnorm1 = dnrm2(n, resid, 1) end if c if (msglvl .gt. 0 .and. iter .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_naitr: Iterative refinement for Arnoldi residual') if (msglvl .gt. 2) then xtemp(1) = rnorm xtemp(2) = rnorm1 call dvout (logfil, 2, xtemp, ndigit, & '_naitr: iterative refinement ; rnorm and rnorm1 are') end if end if c c %-----------------------------------------% c | Determine if we need to perform another | c | step of re-orthogonalization. | c %-----------------------------------------% c if (rnorm1 .gt. 0.717*rnorm) then c c %---------------------------------------% c | No need for further refinement. | c | The cosine of the angle between the | c | corrected residual vector and the old | c | residual vector is greater than 0.717 | c | In other words the corrected residual | c | and the old residual vector share an | c | angle of less than arcCOS(0.717) | c %---------------------------------------% c rnorm = rnorm1 c else c c %-------------------------------------------% c | Another step of iterative refinement step | c | is required. NITREF is used by stat.h | c %-------------------------------------------% c nitref = nitref + 1 rnorm = rnorm1 iter = iter + 1 if (iter .le. 1) go to 80 c c %-------------------------------------------------% c | Otherwise RESID is numerically in the span of V | c %-------------------------------------------------% c do 95 jj = 1, n resid(jj) = zero 95 continue rnorm = zero end if c c %----------------------------------------------% c | Branch here directly if iterative refinement | c | wasn't necessary or after at most NITER_REF | c | steps of iterative refinement. | c %----------------------------------------------% c 100 continue c rstart = .false. orth2 = .false. c call second (t5) titref = titref + (t5 - t4) c c %------------------------------------% c | STEP 6: Update j = j+1; Continue | c %------------------------------------% c j = j + 1 if (j .gt. k+np) then call second (t1) tnaitr = tnaitr + (t1 - t0) ido = 99 do 110 i = max(1,k), k+np-1 c c %--------------------------------------------% c | Check for splitting and deflation. | c | Use a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine dlahqr | c %--------------------------------------------% c tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) if( tst1.eq.zero ) & tst1 = dlanhs( '1', k+np, h, ldh, workd(n+1) ) if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 110 continue c if (msglvl .gt. 2) then call dmout (logfil, k+np, k+np, h, ldh, ndigit, & '_naitr: Final upper Hessenberg matrix H of order K+NP') end if c go to 9000 end if c c %--------------------------------------------------------% c | Loop back to extend the factorization by another step. | c %--------------------------------------------------------% c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 9000 continue return c c %---------------% c | End of dnaitr | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/CMakeLists.txt000644 001750 001750 00000002071 12116424200 023171 0ustar00geuzainegeuzaine000000 000000 # GetDP - Copyright (C) 1997-2013 P. Dular, C. Geuzaine # # See the LICENSE.txt file for license information. Please report all # bugs and problems to the public mailing list . set(SRC sgetv0.f slaqrb.f sstqrb.f ssortc.f ssortr.f sstatn.f sstats.f snaitr.f snapps.f snaup2.f snaupd.f snconv.f sneigh.f sngets.f ssaitr.f ssapps.f ssaup2.f ssaupd.f ssconv.f sseigt.f ssgets.f sneupd.f sseupd.f ssesrt.f dgetv0.f dlaqrb.f dstqrb.f dsortc.f dsortr.f dstatn.f dstats.f dnaitr.f dnapps.f dnaup2.f dnaupd.f dnconv.f dneigh.f dngets.f dsaitr.f dsapps.f dsaup2.f dsaupd.f dsconv.f dseigt.f dsgets.f dneupd.f dseupd.f dsesrt.f cnaitr.f cnapps.f cnaup2.f cnaupd.f cneigh.f cneupd.f cngets.f cgetv0.f csortc.f cstatn.f znaitr.f znapps.f znaup2.f znaupd.f zneigh.f zneupd.f zngets.f zgetv0.f zsortc.f zstatn.f cvout.f dmout.f dvout.f icnteq.f icopy.f iset.f iswap.f ivout.f second.f smout.f svout.f zmout.f zvout.f cmout.f ) file(GLOB HDR RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} *.h) append_getdp_src(contrib/Arpack "${SRC};${HDR}") getdp-2.4.2-source/contrib/Arpack/zvout.f000644 001750 001750 00000020026 11266605602 022003 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c c\SCCS Information: @(#) c FILE: zvout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2 c *----------------------------------------------------------------------- * Routine: ZVOUT * * Purpose: Complex*16 vector output routine. * * Usage: CALL ZVOUT (LOUT, N, CX, IDIGIT, IFMT) * * Arguments * N - Length of array CX. (Input) * CX - Complex*16 array to be printed. (Input) * IFMT - Format to be used in printing array CX. (Input) * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) * If IDIGIT .LT. 0, printing is done with 72 columns. * If IDIGIT .GT. 0, printing is done with 132 columns. * *----------------------------------------------------------------------- * SUBROUTINE ZVOUT( LOUT, N, CX, IDIGIT, IFMT ) * ... * ... SPECIFICATIONS FOR ARGUMENTS INTEGER N, IDIGIT, LOUT Complex*16 & CX( * ) CHARACTER IFMT*( * ) * ... * ... SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I, NDIGIT, K1, K2, LLL CHARACTER*80 LINE * ... * ... FIRST EXECUTABLE STATEMENT * * LLL = MIN( LEN( IFMT ), 80 ) DO 10 I = 1, LLL LINE( I: I ) = '-' 10 CONTINUE * DO 20 I = LLL + 1, 80 LINE( I: I ) = ' ' 20 CONTINUE * WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) 9999 FORMAT( / 1X, A / 1X, A ) * IF( N.LE.0 ) $ RETURN NDIGIT = IDIGIT IF( IDIGIT.EQ.0 ) $ NDIGIT = 4 * *======================================================================= * CODE FOR OUTPUT USING 72 COLUMNS FORMAT *======================================================================= * IF( IDIGIT.LT.0 ) THEN NDIGIT = -IDIGIT IF( NDIGIT.LE.4 ) THEN DO 30 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) IF (K1.NE.N) THEN WRITE( LOUT, 9998 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE WRITE( LOUT, 9997 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 30 CONTINUE ELSE IF( NDIGIT.LE.6 ) THEN DO 40 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) IF (K1.NE.N) THEN WRITE( LOUT, 9988 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE WRITE( LOUT, 9987 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 40 CONTINUE ELSE IF( NDIGIT.LE.8 ) THEN DO 50 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) IF (K1.NE.N) THEN WRITE( LOUT, 9978 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE WRITE( LOUT, 9977 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 50 CONTINUE ELSE DO 60 K1 = 1, N WRITE( LOUT, 9968 )K1, K1, CX( I ) 60 CONTINUE END IF * *======================================================================= * CODE FOR OUTPUT USING 132 COLUMNS FORMAT *======================================================================= * ELSE IF( NDIGIT.LE.4 ) THEN DO 70 K1 = 1, N, 4 K2 = MIN0( N, K1+3 ) IF ((K1+3).LE.N) THEN WRITE( LOUT, 9958 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+3-N) .EQ. 1) THEN WRITE( LOUT, 9957 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+3-N) .EQ. 2) THEN WRITE( LOUT, 9956 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+3-N) .EQ. 1) THEN WRITE( LOUT, 9955 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 70 CONTINUE ELSE IF( NDIGIT.LE.6 ) THEN DO 80 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) IF ((K1+2).LE.N) THEN WRITE( LOUT, 9948 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 1) THEN WRITE( LOUT, 9947 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 2) THEN WRITE( LOUT, 9946 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 80 CONTINUE ELSE IF( NDIGIT.LE.8 ) THEN DO 90 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) IF ((K1+2).LE.N) THEN WRITE( LOUT, 9938 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 1) THEN WRITE( LOUT, 9937 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 2) THEN WRITE( LOUT, 9936 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 90 CONTINUE ELSE DO 100 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) IF ((K1+2).LE.N) THEN WRITE( LOUT, 9928 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 1) THEN WRITE( LOUT, 9927 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 100 CONTINUE END IF END IF WRITE( LOUT, 9994 ) RETURN * *======================================================================= * FORMAT FOR 72 COLUMNS *======================================================================= * * DISPLAY 4 SIGNIFICANT DIGITS * 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',D10.3,',',D10.3,') ') ) 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',D10.3,',',D10.3,') ') ) * * DISPLAY 6 SIGNIFICANT DIGITS * 9988 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',D12.5,',',D12.5,') ') ) 9987 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',D12.5,',',D12.5,') ') ) * * DISPLAY 8 SIGNIFICANT DIGITS * 9978 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',D14.7,',',D14.7,') ') ) 9977 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',D14.7,',',D14.7,') ') ) * * DISPLAY 13 SIGNIFICANT DIGITS * 9968 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',D20.13,',',D20.13,') ') ) * *========================================================================= * FORMAT FOR 132 COLUMNS *========================================================================= * * DISPLAY 4 SIGNIFICANT DIGITS * 9958 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,4('(',D10.3,',',D10.3,') ') ) 9957 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,3('(',D10.3,',',D10.3,') ') ) 9956 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',D10.3,',',D10.3,') ') ) 9955 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',D10.3,',',D10.3,') ') ) * * DISPLAY 6 SIGNIFICANT DIGITS * 9948 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,3('(',D12.5,',',D12.5,') ') ) 9947 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',D12.5,',',D12.5,') ') ) 9946 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',D12.5,',',D12.5,') ') ) * * DISPLAY 8 SIGNIFICANT DIGITS * 9938 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,3('(',D14.7,',',D14.7,') ') ) 9937 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',D14.7,',',D14.7,') ') ) 9936 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',D14.7,',',D14.7,') ') ) * * DISPLAY 13 SIGNIFICANT DIGITS * 9928 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',D20.13,',',D20.13,') ') ) 9927 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',D20.13,',',D20.13,') ') ) * * * 9994 FORMAT( 1X, ' ' ) END getdp-2.4.2-source/contrib/Arpack/dsaup2.f000644 001750 001750 00000077127 11266605602 022030 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c\BeginDoc c c\Name: dsaup2 c c\Description: c Intermediate level interface called by dsaupd. c c\Usage: c call dsaup2 c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, c IPNTR, WORKD, INFO ) c c\Arguments c c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in dsaupd. c MODE, ISHIFT, MXITER: see the definition of IPARAM in dsaupd. c c NP Integer. (INPUT/OUTPUT) c Contains the number of implicit shifts to apply during c each Arnoldi/Lanczos iteration. c If ISHIFT=1, NP is adjusted dynamically at each iteration c to accelerate convergence and prevent stagnation. c This is also roughly equal to the number of matrix-vector c products (involving the operator OP) per Arnoldi iteration. c The logic for adjusting is contained within the current c subroutine. c If ISHIFT=0, NP is the number of shifts the user needs c to provide via reverse comunication. 0 < NP < NCV-NEV. c NP may be less than NCV-NEV since a leading block of the current c upper Tridiagonal matrix has split off and contains "unwanted" c Ritz values. c Upon termination of the IRA iteration, NP contains the number c of "converged" wanted Ritz values. c c IUPD Integer. (INPUT) c IUPD .EQ. 0: use explicit restart instead implicit update. c IUPD .NE. 0: use implicit update. c c V Double precision N by (NEV+NP) array. (INPUT/OUTPUT) c The Lanczos basis vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Double precision (NEV+NP) by 2 array. (OUTPUT) c H is used to store the generated symmetric tridiagonal matrix c The subdiagonal is stored in the first column of H starting c at H(2,1). The main diagonal is stored in the second column c of H starting at H(1,2). If dsaup2 converges store the c B-norm of the final residual vector in H(1,1). c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZ Double precision array of length NEV+NP. (OUTPUT) c RITZ(1:NEV) contains the computed Ritz values of OP. c c BOUNDS Double precision array of length NEV+NP. (OUTPUT) c BOUNDS(1:NEV) contain the error bounds corresponding to RITZ. c c Q Double precision (NEV+NP) by (NEV+NP) array. (WORKSPACE) c Private (replicated) work array used to accumulate the c rotation in the shift application step. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Double precision array of length at least 3*(NEV+NP). (INPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. It is used in the computation of the c tridiagonal eigenvalue problem, the calculation and c application of the shifts and convergence checking. c If ISHIFT .EQ. O and IDO .EQ. 3, the first NP locations c of WORKL are used in reverse communication to hold the user c supplied shifts. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORKD for c vectors used by the Lanczos iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in one of c the spectral transformation modes. X is the current c operand. c ------------------------------------------------------------- c c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Lanczos iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration !!!!!!!!!! c See Data Distribution Note in dsaupd. c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal return. c = 1: All possible eigenvalues of OP has been found. c NP returns the size of the invariant subspace c spanning the operator OP. c = 2: No shifts could be applied. c = -8: Error return from trid. eigenvalue calculation; c This should never happen. c = -9: Starting vector is zero. c = -9999: Could not build an Lanczos factorization. c Size that was built in returned in NP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, c 1980. c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", c Computer Physics Communications, 53 (1989), pp 169-179. c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to c Implement the Spectral Transformation", Math. Comp., 48 (1987), c pp 663-673. c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", c SIAM J. Matr. Anal. Apps., January (1993). c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines c for Updating the QR decomposition", ACM TOMS, December 1990, c Volume 16 Number 4, pp 369-377. c c\Routines called: c dgetv0 ARPACK initial vector generation routine. c dsaitr ARPACK Lanczos factorization routine. c dsapps ARPACK application of implicit shifts routine. c dsconv ARPACK convergence of Ritz values routine. c dseigt ARPACK compute Ritz values and error bounds routine. c dsgets ARPACK reorder Ritz values and error bounds routine. c dsortr ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c second ARPACK utility routine for timing. c dvout ARPACK utility routine that prints vectors. c dlamch LAPACK routine that determines machine constants. c dcopy Level 1 BLAS that copies one vector to another. c ddot Level 1 BLAS that computes the scalar product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dscal Level 1 BLAS that scales a vector. c dswap Level 1 BLAS that swaps two vectors. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/15/93: Version ' 2.4' c xx/xx/95: Version ' 2.4'. (R.B. Lehoucq) c c\SCCS Information: @(#) c FILE: saup2.F SID: 2.7 DATE OF SID: 5/19/98 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine dsaup2 & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, & q, ldq, workl, ipntr, workd, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ishift, iupd, ldh, ldq, ldv, mxiter, & n, mode, nev, np Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Double precision & bounds(nev+np), h(ldh,2), q(ldq,nev+np), resid(n), & ritz(nev+np), v(ldv,nev+np), workd(3*n), & workl(3*(nev+np)) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %---------------% c | Local Scalars | c %---------------% c character wprime*2 logical cnorm, getv0, initv, update, ushift integer ierr, iter, j, kplusp, msglvl, nconv, nevbef, nev0, & np0, nptemp, nevd2, nevm2, kp(3) Double precision & rnorm, temp, eps23 save cnorm, getv0, initv, update, ushift, & iter, kplusp, msglvl, nconv, nev0, np0, & rnorm, eps23 c c %----------------------% c | External Subroutines | c %----------------------% c external dcopy, dgetv0, dsaitr, dscal, dsconv, dseigt, dsgets, & dsapps, dsortr, dvout, ivout, second, dswap c c %--------------------% c | External Functions | c %--------------------% c Double precision & ddot, dnrm2, dlamch external ddot, dnrm2, dlamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic min c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = msaup2 c c %---------------------------------% c | Set machine dependent constant. | c %---------------------------------% c eps23 = dlamch('Epsilon-Machine') eps23 = eps23**(2.0D+0/3.0D+0) c c %-------------------------------------% c | nev0 and np0 are integer variables | c | hold the initial values of NEV & NP | c %-------------------------------------% c nev0 = nev np0 = np c c %-------------------------------------% c | kplusp is the bound on the largest | c | Lanczos factorization built. | c | nconv is the current number of | c | "converged" eigenvlues. | c | iter is the counter on the current | c | iteration step. | c %-------------------------------------% c kplusp = nev0 + np0 nconv = 0 iter = 0 c c %--------------------------------------------% c | Set flags for computing the first NEV steps | c | of the Lanczos factorization. | c %--------------------------------------------% c getv0 = .true. update = .false. ushift = .false. cnorm = .false. c if (info .ne. 0) then c c %--------------------------------------------% c | User provides the initial residual vector. | c %--------------------------------------------% c initv = .true. info = 0 else initv = .false. end if end if c c %---------------------------------------------% c | Get a possibly random starting vector and | c | force it into the range of the operator OP. | c %---------------------------------------------% c 10 continue c if (getv0) then call dgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, & ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (rnorm .eq. zero) then c c %-----------------------------------------% c | The initial vector is zero. Error exit. | c %-----------------------------------------% c info = -9 go to 1200 end if getv0 = .false. ido = 0 end if c c %------------------------------------------------------------% c | Back from reverse communication: continue with update step | c %------------------------------------------------------------% c if (update) go to 20 c c %-------------------------------------------% c | Back from computing user specified shifts | c %-------------------------------------------% c if (ushift) go to 50 c c %-------------------------------------% c | Back from computing residual norm | c | at the end of the current iteration | c %-------------------------------------% c if (cnorm) go to 100 c c %----------------------------------------------------------% c | Compute the first NEV steps of the Lanczos factorization | c %----------------------------------------------------------% c call dsaitr (ido, bmat, n, 0, nev0, mode, resid, rnorm, v, ldv, & h, ldh, ipntr, workd, info) c c %---------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP and possibly B | c %---------------------------------------------------% c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then c c %-----------------------------------------------------% c | dsaitr was unable to build an Lanczos factorization | c | of length NEV0. INFO is returned with the size of | c | the factorization built. Exit main loop. | c %-----------------------------------------------------% c np = info mxiter = iter info = -9999 go to 1200 end if c c %--------------------------------------------------------------% c | | c | M A I N LANCZOS I T E R A T I O N L O O P | c | Each iteration implicitly restarts the Lanczos | c | factorization in place. | c | | c %--------------------------------------------------------------% c 1000 continue c iter = iter + 1 c if (msglvl .gt. 0) then call ivout (logfil, 1, iter, ndigit, & '_saup2: **** Start of major iteration number ****') end if if (msglvl .gt. 1) then call ivout (logfil, 1, nev, ndigit, & '_saup2: The length of the current Lanczos factorization') call ivout (logfil, 1, np, ndigit, & '_saup2: Extend the Lanczos factorization by') end if c c %------------------------------------------------------------% c | Compute NP additional steps of the Lanczos factorization. | c %------------------------------------------------------------% c ido = 0 20 continue update = .true. c call dsaitr (ido, bmat, n, nev, np, mode, resid, rnorm, v, & ldv, h, ldh, ipntr, workd, info) c c %---------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP and possibly B | c %---------------------------------------------------% c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then c c %-----------------------------------------------------% c | dsaitr was unable to build an Lanczos factorization | c | of length NEV0+NP0. INFO is returned with the size | c | of the factorization built. Exit main loop. | c %-----------------------------------------------------% c np = info mxiter = iter info = -9999 go to 1200 end if update = .false. c if (msglvl .gt. 1) then call dvout (logfil, 1, rnorm, ndigit, & '_saup2: Current B-norm of residual for factorization') end if c c %--------------------------------------------------------% c | Compute the eigenvalues and corresponding error bounds | c | of the current symmetric tridiagonal matrix. | c %--------------------------------------------------------% c call dseigt (rnorm, kplusp, h, ldh, ritz, bounds, workl, ierr) c if (ierr .ne. 0) then info = -8 go to 1200 end if c c %----------------------------------------------------% c | Make a copy of eigenvalues and corresponding error | c | bounds obtained from _seigt. | c %----------------------------------------------------% c call dcopy(kplusp, ritz, 1, workl(kplusp+1), 1) call dcopy(kplusp, bounds, 1, workl(2*kplusp+1), 1) c c %---------------------------------------------------% c | Select the wanted Ritz values and their bounds | c | to be used in the convergence test. | c | The selection is based on the requested number of | c | eigenvalues instead of the current NEV and NP to | c | prevent possible misconvergence. | c | * Wanted Ritz values := RITZ(NP+1:NEV+NP) | c | * Shifts := RITZ(1:NP) := WORKL(1:NP) | c %---------------------------------------------------% c nev = nev0 np = np0 call dsgets (ishift, which, nev, np, ritz, bounds, workl) c c %-------------------% c | Convergence test. | c %-------------------% c call dcopy (nev, bounds(np+1), 1, workl(np+1), 1) call dsconv (nev, ritz(np+1), workl(np+1), tol, nconv) c if (msglvl .gt. 2) then kp(1) = nev kp(2) = np kp(3) = nconv call ivout (logfil, 3, kp, ndigit, & '_saup2: NEV, NP, NCONV are') call dvout (logfil, kplusp, ritz, ndigit, & '_saup2: The eigenvalues of H') call dvout (logfil, kplusp, bounds, ndigit, & '_saup2: Ritz estimates of the current NCV Ritz values') end if c c %---------------------------------------------------------% c | Count the number of unwanted Ritz values that have zero | c | Ritz estimates. If any Ritz estimates are equal to zero | c | then a leading block of H of order equal to at least | c | the number of Ritz values with zero Ritz estimates has | c | split off. None of these Ritz values may be removed by | c | shifting. Decrease NP the number of shifts to apply. If | c | no shifts may be applied, then prepare to exit | c %---------------------------------------------------------% c nptemp = np do 30 j=1, nptemp if (bounds(j) .eq. zero) then np = np - 1 nev = nev + 1 end if 30 continue c if ( (nconv .ge. nev0) .or. & (iter .gt. mxiter) .or. & (np .eq. 0) ) then c c %------------------------------------------------% c | Prepare to exit. Put the converged Ritz values | c | and corresponding bounds in RITZ(1:NCONV) and | c | BOUNDS(1:NCONV) respectively. Then sort. Be | c | careful when NCONV > NP since we don't want to | c | swap overlapping locations. | c %------------------------------------------------% c if (which .eq. 'BE') then c c %-----------------------------------------------------% c | Both ends of the spectrum are requested. | c | Sort the eigenvalues into algebraically decreasing | c | order first then swap low end of the spectrum next | c | to high end in appropriate locations. | c | NOTE: when np < floor(nev/2) be careful not to swap | c | overlapping locations. | c %-----------------------------------------------------% c wprime = 'SA' call dsortr (wprime, .true., kplusp, ritz, bounds) nevd2 = nev0 / 2 nevm2 = nev0 - nevd2 if ( nev .gt. 1 ) then call dswap ( min(nevd2,np), ritz(nevm2+1), 1, & ritz( max(kplusp-nevd2+1,kplusp-np+1) ), 1) call dswap ( min(nevd2,np), bounds(nevm2+1), 1, & bounds( max(kplusp-nevd2+1,kplusp-np+1)), 1) end if c else c c %--------------------------------------------------% c | LM, SM, LA, SA case. | c | Sort the eigenvalues of H into the an order that | c | is opposite to WHICH, and apply the resulting | c | order to BOUNDS. The eigenvalues are sorted so | c | that the wanted part are always within the first | c | NEV locations. | c %--------------------------------------------------% c if (which .eq. 'LM') wprime = 'SM' if (which .eq. 'SM') wprime = 'LM' if (which .eq. 'LA') wprime = 'SA' if (which .eq. 'SA') wprime = 'LA' c call dsortr (wprime, .true., kplusp, ritz, bounds) c end if c c %--------------------------------------------------% c | Scale the Ritz estimate of each Ritz value | c | by 1 / max(eps23,magnitude of the Ritz value). | c %--------------------------------------------------% c do 35 j = 1, nev0 temp = max( eps23, abs(ritz(j)) ) bounds(j) = bounds(j)/temp 35 continue c c %----------------------------------------------------% c | Sort the Ritz values according to the scaled Ritz | c | esitmates. This will push all the converged ones | c | towards the front of ritzr, ritzi, bounds | c | (in the case when NCONV < NEV.) | c %----------------------------------------------------% c wprime = 'LA' call dsortr(wprime, .true., nev0, bounds, ritz) c c %----------------------------------------------% c | Scale the Ritz estimate back to its original | c | value. | c %----------------------------------------------% c do 40 j = 1, nev0 temp = max( eps23, abs(ritz(j)) ) bounds(j) = bounds(j)*temp 40 continue c c %--------------------------------------------------% c | Sort the "converged" Ritz values again so that | c | the "threshold" values and their associated Ritz | c | estimates appear at the appropriate position in | c | ritz and bound. | c %--------------------------------------------------% c if (which .eq. 'BE') then c c %------------------------------------------------% c | Sort the "converged" Ritz values in increasing | c | order. The "threshold" values are in the | c | middle. | c %------------------------------------------------% c wprime = 'LA' call dsortr(wprime, .true., nconv, ritz, bounds) c else c c %----------------------------------------------% c | In LM, SM, LA, SA case, sort the "converged" | c | Ritz values according to WHICH so that the | c | "threshold" value appears at the front of | c | ritz. | c %----------------------------------------------% call dsortr(which, .true., nconv, ritz, bounds) c end if c c %------------------------------------------% c | Use h( 1,1 ) as storage to communicate | c | rnorm to _seupd if needed | c %------------------------------------------% c h(1,1) = rnorm c if (msglvl .gt. 1) then call dvout (logfil, kplusp, ritz, ndigit, & '_saup2: Sorted Ritz values.') call dvout (logfil, kplusp, bounds, ndigit, & '_saup2: Sorted ritz estimates.') end if c c %------------------------------------% c | Max iterations have been exceeded. | c %------------------------------------% c if (iter .gt. mxiter .and. nconv .lt. nev) info = 1 c c %---------------------% c | No shifts to apply. | c %---------------------% c if (np .eq. 0 .and. nconv .lt. nev0) info = 2 c np = nconv go to 1100 c else if (nconv .lt. nev .and. ishift .eq. 1) then c c %---------------------------------------------------% c | Do not have all the requested eigenvalues yet. | c | To prevent possible stagnation, adjust the number | c | of Ritz values and the shifts. | c %---------------------------------------------------% c nevbef = nev nev = nev + min (nconv, np/2) if (nev .eq. 1 .and. kplusp .ge. 6) then nev = kplusp / 2 else if (nev .eq. 1 .and. kplusp .gt. 2) then nev = 2 end if np = kplusp - nev c c %---------------------------------------% c | If the size of NEV was just increased | c | resort the eigenvalues. | c %---------------------------------------% c if (nevbef .lt. nev) & call dsgets (ishift, which, nev, np, ritz, bounds, & workl) c end if c if (msglvl .gt. 0) then call ivout (logfil, 1, nconv, ndigit, & '_saup2: no. of "converged" Ritz values at this iter.') if (msglvl .gt. 1) then kp(1) = nev kp(2) = np call ivout (logfil, 2, kp, ndigit, & '_saup2: NEV and NP are') call dvout (logfil, nev, ritz(np+1), ndigit, & '_saup2: "wanted" Ritz values.') call dvout (logfil, nev, bounds(np+1), ndigit, & '_saup2: Ritz estimates of the "wanted" values ') end if end if c if (ishift .eq. 0) then c c %-----------------------------------------------------% c | User specified shifts: reverse communication to | c | compute the shifts. They are returned in the first | c | NP locations of WORKL. | c %-----------------------------------------------------% c ushift = .true. ido = 3 go to 9000 end if c 50 continue c c %------------------------------------% c | Back from reverse communication; | c | User specified shifts are returned | c | in WORKL(1:*NP) | c %------------------------------------% c ushift = .false. c c c %---------------------------------------------------------% c | Move the NP shifts to the first NP locations of RITZ to | c | free up WORKL. This is for the non-exact shift case; | c | in the exact shift case, dsgets already handles this. | c %---------------------------------------------------------% c if (ishift .eq. 0) call dcopy (np, workl, 1, ritz, 1) c if (msglvl .gt. 2) then call ivout (logfil, 1, np, ndigit, & '_saup2: The number of shifts to apply ') call dvout (logfil, np, workl, ndigit, & '_saup2: shifts selected') if (ishift .eq. 1) then call dvout (logfil, np, bounds, ndigit, & '_saup2: corresponding Ritz estimates') end if end if c c %---------------------------------------------------------% c | Apply the NP0 implicit shifts by QR bulge chasing. | c | Each shift is applied to the entire tridiagonal matrix. | c | The first 2*N locations of WORKD are used as workspace. | c | After dsapps is done, we have a Lanczos | c | factorization of length NEV. | c %---------------------------------------------------------% c call dsapps (n, nev, np, ritz, v, ldv, h, ldh, resid, q, ldq, & workd) c c %---------------------------------------------% c | Compute the B-norm of the updated residual. | c | Keep B*RESID in WORKD(1:N) to be used in | c | the first step of the next call to dsaitr. | c %---------------------------------------------% c cnorm = .true. call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call dcopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 c c %----------------------------------% c | Exit in order to compute B*RESID | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd, 1) end if c 100 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(1:N) := B*RESID | c %----------------------------------% c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then rnorm = ddot (n, resid, 1, workd, 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = dnrm2(n, resid, 1) end if cnorm = .false. 130 continue c if (msglvl .gt. 2) then call dvout (logfil, 1, rnorm, ndigit, & '_saup2: B-norm of residual for NEV factorization') call dvout (logfil, nev, h(1,2), ndigit, & '_saup2: main diagonal of compressed H matrix') call dvout (logfil, nev-1, h(2,1), ndigit, & '_saup2: subdiagonal of compressed H matrix') end if c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 1100 continue c mxiter = iter nev = nconv c 1200 continue ido = 99 c c %------------% c | Error exit | c %------------% c call second (t1) tsaup2 = t1 - t0 c 9000 continue return c c %---------------% c | End of dsaup2 | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/ivout.f000644 001750 001750 00000006457 11266605602 021776 0ustar00geuzainegeuzaine000000 000000 C----------------------------------------------------------------------- C Routine: IVOUT C C Purpose: Integer vector output routine. C C Usage: CALL IVOUT (LOUT, N, IX, IDIGIT, IFMT) C C Arguments C N - Length of array IX. (Input) C IX - Integer array to be printed. (Input) C IFMT - Format to be used in printing array IX. (Input) C IDIGIT - Print up to ABS(IDIGIT) decimal digits / number. (Input) C If IDIGIT .LT. 0, printing is done with 72 columns. C If IDIGIT .GT. 0, printing is done with 132 columns. C C----------------------------------------------------------------------- C SUBROUTINE IVOUT (LOUT, N, IX, IDIGIT, IFMT) C ... C ... SPECIFICATIONS FOR ARGUMENTS INTEGER IX(*), N, IDIGIT, LOUT CHARACTER IFMT*(*) C ... C ... SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I, NDIGIT, K1, K2, LLL CHARACTER*80 LINE * ... * ... SPECIFICATIONS INTRINSICS INTRINSIC MIN * C LLL = MIN ( LEN ( IFMT ), 80 ) DO 1 I = 1, LLL LINE(I:I) = '-' 1 CONTINUE C DO 2 I = LLL+1, 80 LINE(I:I) = ' ' 2 CONTINUE C WRITE ( LOUT, 2000 ) IFMT, LINE(1:LLL) 2000 FORMAT ( /1X, A /1X, A ) C IF (N .LE. 0) RETURN NDIGIT = IDIGIT IF (IDIGIT .EQ. 0) NDIGIT = 4 C C======================================================================= C CODE FOR OUTPUT USING 72 COLUMNS FORMAT C======================================================================= C IF (IDIGIT .LT. 0) THEN C NDIGIT = -IDIGIT IF (NDIGIT .LE. 4) THEN DO 10 K1 = 1, N, 10 K2 = MIN0(N,K1+9) WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2) 10 CONTINUE C ELSE IF (NDIGIT .LE. 6) THEN DO 30 K1 = 1, N, 7 K2 = MIN0(N,K1+6) WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2) 30 CONTINUE C ELSE IF (NDIGIT .LE. 10) THEN DO 50 K1 = 1, N, 5 K2 = MIN0(N,K1+4) WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2) 50 CONTINUE C ELSE DO 70 K1 = 1, N, 3 K2 = MIN0(N,K1+2) WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2) 70 CONTINUE END IF C C======================================================================= C CODE FOR OUTPUT USING 132 COLUMNS FORMAT C======================================================================= C ELSE C IF (NDIGIT .LE. 4) THEN DO 90 K1 = 1, N, 20 K2 = MIN0(N,K1+19) WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2) 90 CONTINUE C ELSE IF (NDIGIT .LE. 6) THEN DO 110 K1 = 1, N, 15 K2 = MIN0(N,K1+14) WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2) 110 CONTINUE C ELSE IF (NDIGIT .LE. 10) THEN DO 130 K1 = 1, N, 10 K2 = MIN0(N,K1+9) WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2) 130 CONTINUE C ELSE DO 150 K1 = 1, N, 7 K2 = MIN0(N,K1+6) WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2) 150 CONTINUE END IF END IF WRITE (LOUT,1004) C 1000 FORMAT(1X,I4,' - ',I4,':',20(1X,I5)) 1001 FORMAT(1X,I4,' - ',I4,':',15(1X,I7)) 1002 FORMAT(1X,I4,' - ',I4,':',10(1X,I11)) 1003 FORMAT(1X,I4,' - ',I4,':',7(1X,I15)) 1004 FORMAT(1X,' ') C RETURN END getdp-2.4.2-source/contrib/Arpack/cvout.f000644 001750 001750 00000020015 11266605602 021752 0ustar00geuzainegeuzaine000000 000000 c----------------------------------------------------------------------- c c\SCCS Information: @(#) c FILE: cvout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2 c *----------------------------------------------------------------------- * Routine: CVOUT * * Purpose: Complex vector output routine. * * Usage: CALL CVOUT (LOUT, N, CX, IDIGIT, IFMT) * * Arguments * N - Length of array CX. (Input) * CX - Complex array to be printed. (Input) * IFMT - Format to be used in printing array CX. (Input) * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) * If IDIGIT .LT. 0, printing is done with 72 columns. * If IDIGIT .GT. 0, printing is done with 132 columns. * *----------------------------------------------------------------------- * SUBROUTINE CVOUT( LOUT, N, CX, IDIGIT, IFMT ) * ... * ... SPECIFICATIONS FOR ARGUMENTS INTEGER N, IDIGIT, LOUT Complex & CX( * ) CHARACTER IFMT*( * ) * ... * ... SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I, NDIGIT, K1, K2, LLL CHARACTER*80 LINE * ... * ... FIRST EXECUTABLE STATEMENT * * LLL = MIN( LEN( IFMT ), 80 ) DO 10 I = 1, LLL LINE( I: I ) = '-' 10 CONTINUE * DO 20 I = LLL + 1, 80 LINE( I: I ) = ' ' 20 CONTINUE * WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) 9999 FORMAT( / 1X, A / 1X, A ) * IF( N.LE.0 ) $ RETURN NDIGIT = IDIGIT IF( IDIGIT.EQ.0 ) $ NDIGIT = 4 * *======================================================================= * CODE FOR OUTPUT USING 72 COLUMNS FORMAT *======================================================================= * IF( IDIGIT.LT.0 ) THEN NDIGIT = -IDIGIT IF( NDIGIT.LE.4 ) THEN DO 30 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) IF (K1.NE.N) THEN WRITE( LOUT, 9998 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE WRITE( LOUT, 9997 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 30 CONTINUE ELSE IF( NDIGIT.LE.6 ) THEN DO 40 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) IF (K1.NE.N) THEN WRITE( LOUT, 9988 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE WRITE( LOUT, 9987 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 40 CONTINUE ELSE IF( NDIGIT.LE.8 ) THEN DO 50 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) IF (K1.NE.N) THEN WRITE( LOUT, 9978 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE WRITE( LOUT, 9977 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 50 CONTINUE ELSE DO 60 K1 = 1, N WRITE( LOUT, 9968 )K1, K1, CX( I ) 60 CONTINUE END IF * *======================================================================= * CODE FOR OUTPUT USING 132 COLUMNS FORMAT *======================================================================= * ELSE IF( NDIGIT.LE.4 ) THEN DO 70 K1 = 1, N, 4 K2 = MIN0( N, K1+3 ) IF ((K1+3).LE.N) THEN WRITE( LOUT, 9958 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+3-N) .EQ. 1) THEN WRITE( LOUT, 9957 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+3-N) .EQ. 2) THEN WRITE( LOUT, 9956 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+3-N) .EQ. 1) THEN WRITE( LOUT, 9955 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 70 CONTINUE ELSE IF( NDIGIT.LE.6 ) THEN DO 80 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) IF ((K1+2).LE.N) THEN WRITE( LOUT, 9948 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 1) THEN WRITE( LOUT, 9947 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 2) THEN WRITE( LOUT, 9946 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 80 CONTINUE ELSE IF( NDIGIT.LE.8 ) THEN DO 90 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) IF ((K1+2).LE.N) THEN WRITE( LOUT, 9938 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 1) THEN WRITE( LOUT, 9937 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 2) THEN WRITE( LOUT, 9936 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 90 CONTINUE ELSE DO 100 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) IF ((K1+2).LE.N) THEN WRITE( LOUT, 9928 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 1) THEN WRITE( LOUT, 9927 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 100 CONTINUE END IF END IF WRITE( LOUT, 9994 ) RETURN * *======================================================================= * FORMAT FOR 72 COLUMNS *======================================================================= * * DISPLAY 4 SIGNIFICANT DIGITS * 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',E10.3,',',E10.3,') ') ) 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',E10.3,',',E10.3,') ') ) * * DISPLAY 6 SIGNIFICANT DIGITS * 9988 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',E12.5,',',E12.5,') ') ) 9987 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',E12.5,',',E12.5,') ') ) * * DISPLAY 8 SIGNIFICANT DIGITS * 9978 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',E14.7,',',E14.7,') ') ) 9977 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',E14.7,',',E14.7,') ') ) * * DISPLAY 13 SIGNIFICANT DIGITS * 9968 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',E20.13,',',E20.13,') ') ) * *========================================================================= * FORMAT FOR 132 COLUMNS *========================================================================= * * DISPLAY 4 SIGNIFICANT DIGITS * 9958 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,4('(',E10.3,',',E10.3,') ') ) 9957 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,3('(',E10.3,',',E10.3,') ') ) 9956 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',E10.3,',',E10.3,') ') ) 9955 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',E10.3,',',E10.3,') ') ) * * DISPLAY 6 SIGNIFICANT DIGITS * 9948 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,3('(',E12.5,',',E12.5,') ') ) 9947 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',E12.5,',',E12.5,') ') ) 9946 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',E12.5,',',E12.5,') ') ) * * DISPLAY 8 SIGNIFICANT DIGITS * 9938 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,3('(',E14.7,',',E14.7,') ') ) 9937 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',E14.7,',',E14.7,') ') ) 9936 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',E14.7,',',E14.7,') ') ) * * DISPLAY 13 SIGNIFICANT DIGITS * 9928 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',E20.13,',',E20.13,') ') ) 9927 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',E20.13,',',E20.13,') ') ) * * * 9994 FORMAT( 1X, ' ' ) END getdp-2.4.2-source/contrib/Arpack/znaupd.f000644 001750 001750 00000066315 11266605602 022130 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: znaupd c c\Description: c Reverse communication interface for the Implicitly Restarted Arnoldi c iteration. This is intended to be used to find a few eigenpairs of a c complex linear operator OP with respect to a semi-inner product defined c by a hermitian positive semi-definite real matrix B. B may be the identity c matrix. NOTE: if both OP and B are real, then dsaupd or dnaupd should c be used. c c c The computed approximate eigenvalues are called Ritz values and c the corresponding approximate eigenvectors are called Ritz vectors. c c znaupd is usually called iteratively to solve one of the c following problems: c c Mode 1: A*x = lambda*x. c ===> OP = A and B = I. c c Mode 2: A*x = lambda*M*x, M hermitian positive definite c ===> OP = inv[M]*A and B = M. c ===> (If M can be factored see remark 3 below) c c Mode 3: A*x = lambda*M*x, M hermitian semi-definite c ===> OP = inv[A - sigma*M]*M and B = M. c ===> shift-and-invert mode c If OP*x = amu*x, then lambda = sigma + 1/amu. c c c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v c should be accomplished either by a direct method c using a sparse matrix factorization and solving c c [A - sigma*M]*w = v or M*w = v, c c or through an iterative method for solving these c systems. If an iterative method is used, the c convergence test must be more stringent than c the accuracy requirements for the eigenvalue c approximations. c c\Usage: c call znaupd c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, c IPNTR, WORKD, WORKL, LWORKL, RWORK, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to znaupd. IDO will be set internally to c indicate the type of operation to be performed. Control is c then given back to the calling routine which has the c responsibility to carry out the requested operation and call c znaupd with the result. The operand is given in c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c In mode 3, the vector B * X is already c available in WORKD(ipntr(3)). It does not c need to be recomputed in forming OP * X. c IDO = 2: compute Y = M * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 3: compute and return the shifts in the first c NP locations of WORKL. c IDO = 99: done c ------------------------------------------------------------- c After the initialization phase, when the routine is used in c the "shift-and-invert" mode, the vector M * X is already c available and does not need to be recomputed in forming OP*X. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c WHICH Character*2. (INPUT) c 'LM' -> want the NEV eigenvalues of largest magnitude. c 'SM' -> want the NEV eigenvalues of smallest magnitude. c 'LR' -> want the NEV eigenvalues of largest real part. c 'SR' -> want the NEV eigenvalues of smallest real part. c 'LI' -> want the NEV eigenvalues of largest imaginary part. c 'SI' -> want the NEV eigenvalues of smallest imaginary part. c c NEV Integer. (INPUT) c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. c c TOL Double precision scalar. (INPUT) c Stopping criteria: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. c DEFAULT = dlamch('EPS') (machine precision as computed c by the LAPACK auxiliary subroutine dlamch). c c RESID Complex*16 array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V. NCV must satisfy the two c inequalities 1 <= NCV-NEV and NCV <= N. c This will indicate how many Arnoldi vectors are generated c at each iteration. After the startup phase in which NEV c Arnoldi vectors are generated, the algorithm generates c approximately NCV-NEV Arnoldi vectors at each subsequent update c iteration. Most of the cost in generating each Arnoldi vector is c in the matrix-vector operation OP*x. (See remark 4 below.) c c V Complex*16 array N by NCV. (OUTPUT) c Contains the final set of Arnoldi basis vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling program. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. c The shifts selected at each iteration are used to filter out c the components of the unwanted eigenvector. c ------------------------------------------------------------- c ISHIFT = 0: the shifts are to be provided by the user via c reverse communication. The NCV eigenvalues of c the Hessenberg matrix H are returned in the part c of WORKL array corresponding to RITZ. c ISHIFT = 1: exact shifts with respect to the current c Hessenberg matrix H. This is equivalent to c restarting the iteration from the beginning c after updating the starting vector with a linear c combination of Ritz vectors associated with the c "wanted" eigenvalues. c ISHIFT = 2: other choice of internal shift to be defined. c ------------------------------------------------------------- c c IPARAM(2) = No longer referenced c c IPARAM(3) = MXITER c On INPUT: maximum number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" Ritz values. c This represents the number of Ritz values that satisfy c the convergence criterion. c c IPARAM(6) = IUPD c No longer referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = MODE c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2,3; See under \Description of znaupd for the c four modes available. c c IPARAM(8) = NP c When ido = 3 and the user provides shifts through reverse c communication (IPARAM(1)=0), _naupd returns NP, the number c of shifts the user is to provide. 0 < NP < NCV-NEV. c c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, c OUTPUT: NUMOP = total number of OP*x operations, c NUMOPB = total number of B*x operations if BMAT='G', c NUMREO = total number of steps of re-orthogonalization. c c IPNTR Integer array of length 14. (OUTPUT) c Pointer to mark the starting locations in the WORKD and WORKL c arrays for matrices/vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X in WORKD. c IPNTR(2): pointer to the current result vector Y in WORKD. c IPNTR(3): pointer to the vector B * X in WORKD when used in c the shift-and-invert mode. c IPNTR(4): pointer to the next available location in WORKL c that is untouched by the program. c IPNTR(5): pointer to the NCV by NCV upper Hessenberg c matrix H in WORKL. c IPNTR(6): pointer to the ritz value array RITZ c IPNTR(7): pointer to the (projected) ritz vector array Q c IPNTR(8): pointer to the error BOUNDS array in WORKL. c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. c c Note: IPNTR(9:13) is only referenced by zneupd. See Remark 2 below. c c IPNTR(9): pointer to the NCV RITZ values of the c original system. c IPNTR(10): Not Used c IPNTR(11): pointer to the NCV corresponding error bounds. c IPNTR(12): pointer to the NCV by NCV upper triangular c Schur matrix for H. c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors c of the upper Hessenberg matrix H. Only referenced by c zneupd if RVEC = .TRUE. See Remark 2 below. c c ------------------------------------------------------------- c c WORKD Complex*16 work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration !!!!!!!!!! c See Data Distribution Note below. c c WORKL Complex*16 work array of length LWORKL. (OUTPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. See Data Distribution Note below. c c LWORKL Integer. (INPUT) c LWORKL must be at least 3*NCV**2 + 5*NCV. c c RWORK Double precision work array of length NCV (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal exit. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. IPARAM(5) c returns the number of wanted converged Ritz values. c = 2: No longer an informational error. Deprecated starting c with release 2 of ARPACK. c = 3: No shifts could be applied during a cycle of the c Implicitly restarted Arnoldi iteration. One possibility c is to increase the size of NCV relative to NEV. c See remark 4 below. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 1 and less than or equal to N. c = -4: The maximum number of Arnoldi update iteration c must be greater than zero. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work array is not sufficient. c = -8: Error return from LAPACK eigenvalue calculation; c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: IPARAM(1) must be equal to 0 or 1. c = -9999: Could not build an Arnoldi factorization. c User input error highly likely. Please c check actual array dimensions and layout. c IPARAM(5) returns the size of the current Arnoldi c factorization. c c\Remarks c 1. The computed Ritz values are approximate eigenvalues of OP. The c selection of WHICH should be made with this in mind when using c Mode = 3. When operating in Mode = 3 setting WHICH = 'LM' will c compute the NEV eigenvalues of the original problem that are c closest to the shift SIGMA . After convergence, approximate eigenvalues c of the original problem may be obtained with the ARPACK subroutine zneupd. c c 2. If a basis for the invariant subspace corresponding to the converged Ritz c values is needed, the user must call zneupd immediately following c completion of znaupd. This is new starting with release 2 of ARPACK. c c 3. If M can be factored into a Cholesky factorization M = LL` c then Mode = 2 should not be selected. Instead one should use c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular c linear systems should be solved with L and L` rather c than computing inverses. After convergence, an approximate c eigenvector z of the original problem is recovered by solving c L`z = x where x is a Ritz vector of OP. c c 4. At present there is no a-priori analysis to guide the selection c of NCV relative to NEV. The only formal requirement is that NCV > NEV + 1. c However, it is recommended that NCV .ge. 2*NEV. If many problems of c the same type are to be solved, one should experiment with increasing c NCV while keeping NEV fixed for a given test problem. This will c usually decrease the required number of OP*x operations but it c also increases the work and storage required to maintain the orthogonal c basis vectors. The optimal "cross-over" with respect to CPU time c is problem dependent and must be determined empirically. c See Chapter 8 of Reference 2 for further information. c c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the c NP = IPARAM(8) complex shifts in locations c WORKL(IPNTR(14)), WORKL(IPNTR(14)+1), ... , WORKL(IPNTR(14)+NP). c Eigenvalues of the current upper Hessenberg matrix are located in c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are ordered c according to the order defined by WHICH. The associated Ritz estimates c are located in WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , c WORKL(IPNTR(8)+NCV-1). c c----------------------------------------------------------------------- c c\Data Distribution Note: c c Fortran-D syntax: c ================ c Complex*16 resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) c decompose d1(n), d2(n,ncv) c align resid(i) with d1(i) c align v(i,j) with d2(i,j) c align workd(i) with d1(i) range (1:n) c align workd(i) with d1(i-n) range (n+1:2*n) c align workd(i) with d1(i-2*n) range (2*n+1:3*n) c distribute d1(block), d2(block,:) c replicated workl(lworkl) c c Cray MPP syntax: c =============== c Complex*16 resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) c shared resid(block), v(block,:), workd(block,:) c replicated workl(lworkl) c c CM2/CM5 syntax: c ============== c c----------------------------------------------------------------------- c c include 'ex-nonsym.doc' c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex*16 c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett & Y. Saad, "_Complex_ Shift and Invert Strategies for c Double precision Matrices", Linear Algebra and its Applications, vol 88/89, c pp 575-595, (1987). c c\Routines called: c znaup2 ARPACK routine that implements the Implicitly Restarted c Arnoldi Iteration. c zstatn ARPACK routine that initializes the timing variables. c ivout ARPACK utility routine that prints integers. c zvout ARPACK utility routine that prints vectors. c second ARPACK utility routine for timing. c dlamch LAPACK routine that determines machine constants. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: naupd.F SID: 2.9 DATE OF SID: 07/21/02 RELEASE: 2 c c\Remarks c c\EndLib c c----------------------------------------------------------------------- c subroutine znaupd & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, & ipntr, workd, workl, lworkl, rwork, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ldv, lworkl, n, ncv, nev Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(14) Complex*16 & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) Double precision & rwork(ncv) c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0)) c c %---------------% c | Local Scalars | c %---------------% c integer bounds, ierr, ih, iq, ishift, iupd, iw, & ldh, ldq, levec, mode, msglvl, mxiter, nb, & nev0, next, np, ritz, j save bounds, ih, iq, ishift, iupd, iw, & ldh, ldq, levec, mode, msglvl, mxiter, nb, & nev0, next, np, ritz c c %----------------------% c | External Subroutines | c %----------------------% c external znaup2, zvout, ivout, second, zstatn c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlamch external dlamch c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call zstatn call second (t0) msglvl = mcaupd c c %----------------% c | Error checking | c %----------------% c ierr = 0 ishift = iparam(1) c levec = iparam(2) mxiter = iparam(3) c nb = iparam(4) nb = 1 c c %--------------------------------------------% c | Revision 2 performs only implicit restart. | c %--------------------------------------------% c iupd = 1 mode = iparam(7) c if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev .or. ncv .gt. n) then ierr = -3 else if (mxiter .le. 0) then ierr = -4 else if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LR' .and. & which .ne. 'SR' .and. & which .ne. 'LI' .and. & which .ne. 'SI') then ierr = -5 else if (bmat .ne. 'I' .and. bmat .ne. 'G') then ierr = -6 else if (lworkl .lt. 3*ncv**2 + 5*ncv) then ierr = -7 else if (mode .lt. 1 .or. mode .gt. 3) then ierr = -10 else if (mode .eq. 1 .and. bmat .eq. 'G') then ierr = -11 end if c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr ido = 99 go to 9000 end if c c %------------------------% c | Set default parameters | c %------------------------% c if (nb .le. 0) nb = 1 if (tol .le. 0.0D+0 ) tol = dlamch('EpsMach') if (ishift .ne. 0 .and. & ishift .ne. 1 .and. & ishift .ne. 2) ishift = 1 c c %----------------------------------------------% c | NP is the number of additional steps to | c | extend the length NEV Lanczos factorization. | c | NEV0 is the local variable designating the | c | size of the invariant subspace desired. | c %----------------------------------------------% c np = ncv - nev nev0 = nev c c %-----------------------------% c | Zero out internal workspace | c %-----------------------------% c do 10 j = 1, 3*ncv**2 + 5*ncv workl(j) = zero 10 continue c c %-------------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:ncv*ncv) := generated Hessenberg matrix | c | workl(ncv*ncv+1:ncv*ncv+ncv) := the ritz values | c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | c | workl(ncv*ncv+2*ncv+1:2*ncv*ncv+2*ncv) := rotation matrix Q | c | workl(2*ncv*ncv+2*ncv+1:3*ncv*ncv+5*ncv) := workspace | c | The final workspace is needed by subroutine zneigh called | c | by znaup2. Subroutine zneigh calls LAPACK routines for | c | calculating eigenvalues and the last row of the eigenvector | c | matrix. | c %-------------------------------------------------------------% c ldh = ncv ldq = ncv ih = 1 ritz = ih + ldh*ncv bounds = ritz + ncv iq = bounds + ncv iw = iq + ldq*ncv next = iw + ncv**2 + 3*ncv c ipntr(4) = next ipntr(5) = ih ipntr(6) = ritz ipntr(7) = iq ipntr(8) = bounds ipntr(14) = iw end if c c %-------------------------------------------------------% c | Carry out the Implicitly restarted Arnoldi Iteration. | c %-------------------------------------------------------% c call znaup2 & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), & workl(bounds), workl(iq), ldq, workl(iw), & ipntr, workd, rwork, info ) c c %--------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP. | c %--------------------------------------------------% c if (ido .eq. 3) iparam(8) = np if (ido .ne. 99) go to 9000 c iparam(3) = mxiter iparam(5) = np iparam(9) = nopx iparam(10) = nbx iparam(11) = nrorth c c %------------------------------------% c | Exit if there was an informational | c | error within znaup2. | c %------------------------------------% c if (info .lt. 0) go to 9000 if (info .eq. 2) info = 3 c if (msglvl .gt. 0) then call ivout (logfil, 1, mxiter, ndigit, & '_naupd: Number of update iterations taken') call ivout (logfil, 1, np, ndigit, & '_naupd: Number of wanted "converged" Ritz values') call zvout (logfil, np, workl(ritz), ndigit, & '_naupd: The final Ritz values') call zvout (logfil, np, workl(bounds), ndigit, & '_naupd: Associated Ritz estimates') end if c call second (t1) tcaupd = t1 - t0 c if (msglvl .gt. 0) then c c %--------------------------------------------------------% c | Version Number & Version Date are defined in version.h | c %--------------------------------------------------------% c write (6,1000) write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, & tmvopx, tmvbx, tcaupd, tcaup2, tcaitr, titref, & tgetv0, tceigh, tcgets, tcapps, tcconv, trvec 1000 format (//, & 5x, '=============================================',/ & 5x, '= Complex implicit Arnoldi update code =',/ & 5x, '= Version Number: ', ' 2.3', 21x, ' =',/ & 5x, '= Version Date: ', ' 07/31/96', 16x, ' =',/ & 5x, '=============================================',/ & 5x, '= Summary of timing statistics =',/ & 5x, '=============================================',//) 1100 format ( & 5x, 'Total number update iterations = ', i5,/ & 5x, 'Total number of OP*x operations = ', i5,/ & 5x, 'Total number of B*x operations = ', i5,/ & 5x, 'Total number of reorthogonalization steps = ', i5,/ & 5x, 'Total number of iterative refinement steps = ', i5,/ & 5x, 'Total number of restart steps = ', i5,/ & 5x, 'Total time in user OP*x operation = ', f12.6,/ & 5x, 'Total time in user B*x operation = ', f12.6,/ & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ & 5x, 'Total time in naup2 routine = ', f12.6,/ & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ & 5x, 'Total time in (re)start vector generation = ', f12.6,/ & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ & 5x, 'Total time in getting the shifts = ', f12.6,/ & 5x, 'Total time in applying the shifts = ', f12.6,/ & 5x, 'Total time in convergence testing = ', f12.6,/ & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) end if c 9000 continue c return c c %---------------% c | End of znaupd | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/dstatn.f000644 001750 001750 00000002710 11266605602 022111 0ustar00geuzainegeuzaine000000 000000 c c %---------------------------------------------% c | Initialize statistic and timing information | c | for nonsymmetric Arnoldi code. | c %---------------------------------------------% c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: statn.F SID: 2.4 DATE OF SID: 4/20/96 RELEASE: 2 c subroutine dstatn c c %--------------------------------% c | See stat.doc for documentation | c %--------------------------------% c include 'stat.h' c c %-----------------------% c | Executable Statements | c %-----------------------% c nopx = 0 nbx = 0 nrorth = 0 nitref = 0 nrstrt = 0 c tnaupd = 0.0D+0 tnaup2 = 0.0D+0 tnaitr = 0.0D+0 tneigh = 0.0D+0 tngets = 0.0D+0 tnapps = 0.0D+0 tnconv = 0.0D+0 titref = 0.0D+0 tgetv0 = 0.0D+0 trvec = 0.0D+0 c c %----------------------------------------------------% c | User time including reverse communication overhead | c %----------------------------------------------------% c tmvopx = 0.0D+0 tmvbx = 0.0D+0 c return c c c %---------------% c | End of dstatn | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/cgetv0.f000644 001750 001750 00000031150 11266605602 022004 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: cgetv0 c c\Description: c Generate a random initial residual vector for the Arnoldi process. c Force the residual vector to be in the range of the operator OP. c c\Usage: c call cgetv0 c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, c IPNTR, WORKD, IERR ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to cgetv0. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 99: done c ------------------------------------------------------------- c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B in the (generalized) c eigenvalue problem A*x = lambda*B*x. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x c c ITRY Integer. (INPUT) c ITRY counts the number of times that cgetv0 is called. c It should be set to 1 on the initial call to cgetv0. c c INITV Logical variable. (INPUT) c .TRUE. => the initial residual vector is given in RESID. c .FALSE. => generate a random initial residual vector. c c N Integer. (INPUT) c Dimension of the problem. c c J Integer. (INPUT) c Index of the residual vector to be generated, with respect to c the Arnoldi process. J > 1 in case of a "restart". c c V Complex N by J array. (INPUT) c The first J-1 columns of V contain the current Arnoldi basis c if this is a "restart". c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c RESID Complex array of length N. (INPUT/OUTPUT) c Initial residual vector to be generated. If RESID is c provided, force RESID into the range of the operator OP. c c RNORM Real scalar. (OUTPUT) c B-norm of the generated residual. c c IPNTR Integer array of length 3. (OUTPUT) c c WORKD Complex work array of length 2*N. (REVERSE COMMUNICATION). c On exit, WORK(1:N) = B*RESID to be used in SSAITR. c c IERR Integer. (OUTPUT) c = 0: Normal exit. c = -1: Cannot generate a nontrivial restarted residual vector c in the range of the operator OP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c c\Routines called: c second ARPACK utility routine for timing. c cvout ARPACK utility routine that prints vectors. c clarnv LAPACK routine for generating a random vector. c cgemv Level 2 BLAS routine for matrix vector multiplication. c ccopy Level 1 BLAS that copies one vector to another. c cdotc Level 1 BLAS that computes the scalar product of two vectors. c scnrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: getv0.F SID: 2.3 DATE OF SID: 08/27/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine cgetv0 & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, & ipntr, workd, ierr ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 logical initv integer ido, ierr, itry, j, ldv, n Real & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Complex & resid(n), v(ldv,j), workd(2*n) c c %------------% c | Parameters | c %------------% c Complex & one, zero Real & rzero parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0), & rzero = 0.0E+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c logical first, inits, orth integer idist, iseed(4), iter, msglvl, jj Real & rnorm0 Complex & cnorm save first, iseed, inits, iter, msglvl, orth, rnorm0 c c %----------------------% c | External Subroutines | c %----------------------% c external ccopy, cgemv, clarnv, cvout, second c c %--------------------% c | External Functions | c %--------------------% c Real & scnrm2, slapy2 Complex & cdotc external cdotc, scnrm2, slapy2 c c %-----------------% c | Data Statements | c %-----------------% c data inits /.true./ c c %-----------------------% c | Executable Statements | c %-----------------------% c c c %-----------------------------------% c | Initialize the seed of the LAPACK | c | random number generator | c %-----------------------------------% c if (inits) then iseed(1) = 1 iseed(2) = 3 iseed(3) = 5 iseed(4) = 7 inits = .false. end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call second (t0) msglvl = mgetv0 c ierr = 0 iter = 0 first = .FALSE. orth = .FALSE. c c %-----------------------------------------------------% c | Possibly generate a random starting vector in RESID | c | Use a LAPACK random number generator used by the | c | matrix generation routines. | c | idist = 1: uniform (0,1) distribution; | c | idist = 2: uniform (-1,1) distribution; | c | idist = 3: normal (0,1) distribution; | c %-----------------------------------------------------% c if (.not.initv) then idist = 2 call clarnv (idist, iseed, n, resid) end if c c %----------------------------------------------------------% c | Force the starting vector into the range of OP to handle | c | the generalized problem when B is possibly (singular). | c %----------------------------------------------------------% c call second (t2) if (bmat .eq. 'G') then nopx = nopx + 1 ipntr(1) = 1 ipntr(2) = n + 1 call ccopy (n, resid, 1, workd, 1) ido = -1 go to 9000 end if end if c c %----------------------------------------% c | Back from computing B*(initial-vector) | c %----------------------------------------% c if (first) go to 20 c c %-----------------------------------------------% c | Back from computing B*(orthogonalized-vector) | c %-----------------------------------------------% c if (orth) go to 40 c call second (t3) tmvopx = tmvopx + (t3 - t2) c c %------------------------------------------------------% c | Starting vector is now in the range of OP; r = OP*r; | c | Compute B-norm of starting vector. | c %------------------------------------------------------% c call second (t2) first = .TRUE. if (bmat .eq. 'G') then nbx = nbx + 1 call ccopy (n, workd(n+1), 1, resid, 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 go to 9000 else if (bmat .eq. 'I') then call ccopy (n, resid, 1, workd, 1) end if c 20 continue c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c first = .FALSE. if (bmat .eq. 'G') then cnorm = cdotc (n, resid, 1, workd, 1) rnorm0 = sqrt(slapy2(real(cnorm),aimag(cnorm))) else if (bmat .eq. 'I') then rnorm0 = scnrm2(n, resid, 1) end if rnorm = rnorm0 c c %---------------------------------------------% c | Exit if this is the very first Arnoldi step | c %---------------------------------------------% c if (j .eq. 1) go to 50 c c %---------------------------------------------------------------- c | Otherwise need to B-orthogonalize the starting vector against | c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | c | This is the case where an invariant subspace is encountered | c | in the middle of the Arnoldi factorization. | c | | c | s = V^{T}*B*r; r = r - V*s; | c | | c | Stopping criteria used for iter. ref. is discussed in | c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | c %---------------------------------------------------------------% c orth = .TRUE. 30 continue c call cgemv ('C', n, j-1, one, v, ldv, workd, 1, & zero, workd(n+1), 1) call cgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, & one, resid, 1) c c %----------------------------------------------------------% c | Compute the B-norm of the orthogonalized starting vector | c %----------------------------------------------------------% c call second (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call ccopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 go to 9000 else if (bmat .eq. 'I') then call ccopy (n, resid, 1, workd, 1) end if c 40 continue c if (bmat .eq. 'G') then call second (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then cnorm = cdotc (n, resid, 1, workd, 1) rnorm = sqrt(slapy2(real(cnorm),aimag(cnorm))) else if (bmat .eq. 'I') then rnorm = scnrm2(n, resid, 1) end if c c %--------------------------------------% c | Check for further orthogonalization. | c %--------------------------------------% c if (msglvl .gt. 2) then call svout (logfil, 1, rnorm0, ndigit, & '_getv0: re-orthonalization ; rnorm0 is') call svout (logfil, 1, rnorm, ndigit, & '_getv0: re-orthonalization ; rnorm is') end if c if (rnorm .gt. 0.717*rnorm0) go to 50 c iter = iter + 1 if (iter .le. 1) then c c %-----------------------------------% c | Perform iterative refinement step | c %-----------------------------------% c rnorm0 = rnorm go to 30 else c c %------------------------------------% c | Iterative refinement step "failed" | c %------------------------------------% c do 45 jj = 1, n resid(jj) = zero 45 continue rnorm = rzero ierr = -1 end if c 50 continue c if (msglvl .gt. 0) then call svout (logfil, 1, rnorm, ndigit, & '_getv0: B-norm of initial / restarted starting vector') end if if (msglvl .gt. 2) then call cvout (logfil, n, resid, ndigit, & '_getv0: initial / restarted starting vector') end if ido = 99 c call second (t1) tgetv0 = tgetv0 + (t1 - t0) c 9000 continue return c c %---------------% c | End of cgetv0 | c %---------------% c end getdp-2.4.2-source/contrib/Arpack/cneupd.f000644 001750 001750 00000103756 11266605602 022106 0ustar00geuzainegeuzaine000000 000000 c\BeginDoc c c\Name: cneupd c c\Description: c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) The corresponding approximate eigenvectors; c c (2) An orthonormal basis for the associated approximate c invariant subspace; c c (3) Both. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c basis is always computed. There is an additional storage cost of n*nev c if both are requested (in this case a separate array Z must be supplied). c c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z c are derived from approximate eigenvalues and eigenvectors of c of the linear operator OP prescribed by the MODE selection in the c call to CNAUPD. CNAUPD must be called before this routine is called. c These approximate eigenvalues and vectors are commonly called Ritz c values and Ritz vectors respectively. They are referred to as such c in the comments that follow. The computed orthonormal basis for the c invariant subspace corresponding to these Ritz values is referred to as a c Schur basis. c c The definition of OP as well as other terms and the relation of computed c Ritz values and vectors of OP with respect to the given problem c A*z = lambda*B*z may be found in the header of CNAUPD. For a brief c description, see definitions of IPARAM(7), MODE and WHICH in the c documentation of CNAUPD. c c\Usage: c call cneupd c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, WORKEV, BMAT, c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, c WORKL, LWORKL, RWORK, INFO ) c c\Arguments: c RVEC LOGICAL (INPUT) c Specifies whether a basis for the invariant subspace corresponding c to the converged Ritz value approximations for the eigenproblem c A*z = lambda*B*z is computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute Ritz vectors or Schur vectors. c See Remarks below. c c HOWMNY Character*1 (INPUT) c Specifies the form of the basis for the invariant subspace c corresponding to the converged Ritz values that is to be computed. c c = 'A': Compute NEV Ritz vectors; c = 'P': Compute NEV Schur vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the Ritz vector corresponding to a c Ritz value D(j), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' or 'P', SELECT need not be initialized c but it is used as internal workspace. c c D Complex array of dimension NEV+1. (OUTPUT) c On exit, D contains the Ritz approximations c to the eigenvalues lambda for A*z = lambda*B*z. c c Z Complex N by NEV array (OUTPUT) c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of c Z represents approximate eigenvectors (Ritz vectors) corresponding c to the NCONV=IPARAM(5) Ritz values for eigensystem c A*z = lambda*B*z. c c If RVEC = .FALSE. or HOWMNY = 'P', then Z is NOT REFERENCED. c c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, c the array Z may be set equal to first NEV+1 columns of the Arnoldi c basis array V computed by CNAUPD. In this case the Arnoldi basis c will be destroyed and overwritten with the eigenvector basis. c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ .ge. max( 1, N ) is required. c In any case, LDZ .ge. 1 is required. c c SIGMA Complex (INPUT) c If IPARAM(7) = 3 then SIGMA represents the shift. c Not referenced if IPARAM(7) = 1 or 2. c c WORKEV Complex work array of dimension 2*NCV. (WORKSPACE) c c **** The remaining arguments MUST be the same as for the **** c **** call to CNAUPD that was just completed. **** c c NOTE: The remaining arguments c c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, c WORKD, WORKL, LWORKL, RWORK, INFO c c must be passed directly to CNEUPD following the last call c to CNAUPD. These arguments MUST NOT BE MODIFIED between c the the last call to CNAUPD and the call to CNEUPD. c c Three of these parameters (V, WORKL and INFO) are also output parameters: c c V Complex N by NCV array. (INPUT/OUTPUT) c c Upon INPUT: the NCV columns of V contain the Arnoldi basis c vectors for OP as constructed by CNAUPD . c c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns c contain approximate Schur vectors that span the c desired invariant subspace. c c NOTE: If the array Z has been set equal to first NEV+1 columns c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the c Arnoldi basis held by V has been overwritten by the desired c Ritz vectors. If a separate array Z has been passed then c the first NCONV=IPARAM(5) columns of V will contain approximate c Schur vectors that span the desired invariant subspace. c c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) c WORKL(1:ncv*ncv+2*ncv) contains information obtained in c cnaupd. They are not changed by cneupd. c WORKL(ncv*ncv+2*ncv+1:3*ncv*ncv+4*ncv) holds the c untransformed Ritz values, the untransformed error estimates of c the Ritz values, the upper triangular matrix for H, and the c associated matrix representation of the invariant subspace for H. c c Note: IPNTR(9:13) contains the pointer into WORKL for addresses c of the above information computed by cneupd. c ------------------------------------------------------------- c IPNTR(9): pointer to the NCV RITZ values of the c original system. c IPNTR(10): Not used c IPNTR(11): pointer to the NCV corresponding error estimates. c IPNTR(12): pointer to the NCV by NCV upper triangular c Schur matrix for H. c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors c of the upper Hessenberg matrix H. Only referenced by c cneupd if RVEC = .TRUE. See Remark 2 below. c ------------------------------------------------------------- c c INFO Integer. (OUTPUT) c Error flag on output. c = 0: Normal exit. c c = 1: The Schur form computed by LAPACK routine csheqr c could not be reordered by LAPACK routine ctrsen. c Re-enter subroutine cneupd with IPARAM(5)=NCV and c increase the size of the array D to have c dimension at least dimension NCV and allocate at least NCV c columns for Z. NOTE: Not necessary if Z and V share c the same space. Please notify the authors if this error c occurs. c c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 1 and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from LAPACK eigenvalue calculation. c This should never happened. c = -9: Error return from calculation of eigenvectors. c Informational error from LAPACK routine ctrevc. c = -10: IPARAM(7) must be 1,2,3 c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: HOWMNY = 'S' not yet implemented c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. c = -14: CNAUPD did not find any eigenvalues to sufficient c accuracy. c = -15: CNEUPD got a different count of the number of converged c Ritz values than CNAUPD got. This indicates the user c probably made an error in passing data from CNAUPD to c CNEUPD or that the data was modified before entering c CNEUPD c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B. Nour-Omid, B. N. Parlett, T. Ericsson and P. S. Jensen, c "How to Implement the Spectral Transformation", Math Comp., c Vol. 48, No. 178, April, 1987 pp. 664-673. c c\Routines called: c ivout ARPACK utility routine that prints integers. c cmout ARPACK utility routine that prints matrices c cvout ARPACK utility routine that prints vectors. c cgeqr2 LAPACK routine that computes the QR factorization of c a matrix. c clacpy LAPACK matrix copy routine. c clahqr LAPACK routine that computes the Schur form of a c upper Hessenberg matrix. c claset LAPACK matrix initialization routine. c ctrevc LAPACK routine to compute the eigenvectors of a matrix c in upper triangular form. c ctrsen LAPACK routine that re-orders the Schur form. c cunm2r LAPACK routine that applies an orthogonal matrix in c factored form. c slamch LAPACK routine that determines machine constants. c ctrmm Level 3 BLAS matrix times an upper triangular matrix. c cgeru Level 2 BLAS rank one update to a matrix. c ccopy Level 1 BLAS that copies one vector to another . c cscal Level 1 BLAS that scales a vector. c csscal Level 1 BLAS that scales a complex vector by a real number. c scnrm2 Level 1 BLAS that computes the norm of a complex vector. c c\Remarks c c 1. Currently only HOWMNY = 'A' and 'P' are implemented. c c 2. Schur vectors are an orthogonal representation for the basis of c Ritz vectors. Thus, their numerical properties are often superior. c If RVEC = .true. then the relationship c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and c transpose( V(:,1:IPARAM(5)) ) * V(:,1:IPARAM(5)) = I c are approximately satisfied. c Here T is the leading submatrix of order IPARAM(5) of the c upper triangular matrix stored workl(ipntr(12)). c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Chao Yang Houston, Texas c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: neupd.F SID: 2.8 DATE OF SID: 07/21/02 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- subroutine cneupd(rvec , howmny, select, d , & z , ldz , sigma , workev, & bmat , n , which , nev , & tol , resid , ncv , v , & ldv , iparam, ipntr , workd , & workl, lworkl, rwork , info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat, howmny, which*2 logical rvec integer info, ldz, ldv, lworkl, n, ncv, nev Complex & sigma Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(14) logical select(ncv) Real & rwork(ncv) Complex & d(nev) , resid(n) , v(ldv,ncv), & z(ldz, nev), & workd(3*n) , workl(lworkl), workev(2*ncv) c c %------------% c | Parameters | c %------------% c Complex & one, zero parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0)) c c %---------------% c | Local Scalars | c %---------------% c character type*6 integer bounds, ierr , ih , ihbds, iheig , nconv , & invsub, iuptri, iwev , j , ldh , ldq , & mode , msglvl, ritz , wr , k , irz , & ibd , outncv, iq , np , numcnv, jj , & ishift Complex & rnorm, temp, vl(1) Real & conds, sep, rtemp, eps23 logical reord c c %----------------------% c | External Subroutines | c %----------------------% c external ccopy , cgeru, cgeqr2, clacpy, cmout, & cunm2r, ctrmm, cvout, ivout, & clahqr c c %--------------------% c | External Functions | c %--------------------% c Real & scnrm2, slamch, slapy2 external scnrm2, slamch, slapy2 c Complex & cdotc external cdotc c c %-----------------------% c | Executable Statements | c %-----------------------% c c %------------------------% c | Set default parameters | c %------------------------% c msglvl = mceupd mode = iparam(7) nconv = iparam(5) info = 0 c c c %---------------------------------% c | Get machine dependent constant. | c %---------------------------------% c eps23 = slamch('Epsilon-Machine') eps23 = eps23**(2.0E+0 / 3.0E+0) c c %-------------------------------% c | Quick return | c | Check for incompatible input | c %-------------------------------% c ierr = 0 c if (nconv .le. 0) then ierr = -14 else if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev .or. ncv .gt. n) then ierr = -3 else if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LR' .and. & which .ne. 'SR' .and. & which .ne. 'LI' .and. & which .ne. 'SI') then ierr = -5 else if (bmat .ne. 'I' .and. bmat .ne. 'G') then ierr = -6 else if (lworkl .lt. 3*ncv**2 + 4*ncv) then ierr = -7 else if ( (howmny .ne. 'A' .and. & howmny .ne. 'P' .and. & howmny .ne. 'S') .and. rvec ) then ierr = -13 else if (howmny .eq. 'S' ) then ierr = -12 end if c if (mode .eq. 1 .or. mode .eq. 2) then type = 'REGULR' else if (mode .eq. 3 ) then type = 'SHIFTI' else ierr = -10 end if if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr go to 9000 end if c c %--------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, WORKEV, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:ncv*ncv) := generated Hessenberg matrix | c | workl(ncv*ncv+1:ncv*ncv+ncv) := ritz values | c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | c %--------------------------------------------------------% c c %-----------------------------------------------------------% c | The following is used and set by CNEUPD. | c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed | c | Ritz values. | c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | c | error bounds of | c | the Ritz values | c | workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper | c | triangular matrix | c | for H. | c | workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the | c | associated matrix | c | representation of | c | the invariant | c | subspace for H. | c | GRAND total of NCV * ( 3 * NCV + 4 ) locations. | c %-----------------------------------------------------------% c ih = ipntr(5) ritz = ipntr(6) iq = ipntr(7) bounds = ipntr(8) ldh = ncv ldq = ncv iheig = bounds + ldh ihbds = iheig + ldh iuptri = ihbds + ldh invsub = iuptri + ldh*ncv ipntr(9) = iheig ipntr(11) = ihbds ipntr(12) = iuptri ipntr(13) = invsub wr = 1 iwev = wr + ncv c c %-----------------------------------------% c | irz points to the Ritz values computed | c | by _neigh before exiting _naup2. | c | ibd points to the Ritz estimates | c | computed by _neigh before exiting | c | _naup2. | c %-----------------------------------------% c irz = ipntr(14) + ncv*ncv ibd = irz + ncv c c %------------------------------------% c | RNORM is B-norm of the RESID(1:N). | c %------------------------------------% c rnorm = workl(ih+2) workl(ih+2) = zero c if (msglvl .gt. 2) then call cvout(logfil, ncv, workl(irz), ndigit, & '_neupd: Ritz values passed in from _NAUPD.') call cvout(logfil, ncv, workl(ibd), ndigit, & '_neupd: Ritz estimates passed in from _NAUPD.') end if c if (rvec) then c reord = .false. c c %---------------------------------------------------% c | Use the temporary bounds array to store indices | c | These will be used to mark the select array later | c %---------------------------------------------------% c do 10 j = 1,ncv workl(bounds+j-1) = j select(j) = .false. 10 continue c c %-------------------------------------% c | Select the wanted Ritz values. | c | Sort the Ritz values so that the | c | wanted ones appear at the tailing | c | NEV positions of workl(irr) and | c | workl(iri). Move the corresponding | c | error estimates in workl(ibd) | c | accordingly. | c %-------------------------------------% c np = ncv - nev ishift = 0 call cngets(ishift, which , nev , & np , workl(irz), workl(bounds)) c if (msglvl .gt. 2) then call cvout (logfil, ncv, workl(irz), ndigit, & '_neupd: Ritz values after calling _NGETS.') call cvout (logfil, ncv, workl(bounds), ndigit, & '_neupd: Ritz value indices after calling _NGETS.') end if c c %-----------------------------------------------------% c | Record indices of the converged wanted Ritz values | c | Mark the select array for possible reordering | c %-----------------------------------------------------% c numcnv = 0 do 11 j = 1,ncv rtemp = max(eps23, & slapy2 ( real(workl(irz+ncv-j)), & aimag(workl(irz+ncv-j)) )) jj = workl(bounds + ncv - j) if (numcnv .lt. nconv .and. & slapy2( real(workl(ibd+jj-1)), & aimag(workl(ibd+jj-1)) ) & .le. tol*rtemp) then select(jj) = .true. numcnv = numcnv + 1 if (jj .gt. nev) reord = .true. endif 11 continue c c %-----------------------------------------------------------% c | Check the count (numcnv) of converged Ritz values with | c | the number (nconv) reported by dnaupd. If these two | c | are different then there has probably been an error | c | caused by incorrect passing of the dnaupd data. | c %-----------------------------------------------------------% c if (msglvl .gt. 2) then call ivout(logfil, 1, numcnv, ndigit, & '_neupd: Number of specified eigenvalues') call ivout(logfil, 1, nconv, ndigit, & '_neupd: Number of "converged" eigenvalues') end if c if (numcnv .ne. nconv) then info = -15 go to 9000 end if c c %-------------------------------------------------------% c | Call LAPACK routine clahqr to compute the Schur form | c | of the upper Hessenberg matrix returned by CNAUPD. | c | Make a copy of the upper Hessenberg matrix. | c | Initialize the Schur vector matrix Q to the identity. | c %-------------------------------------------------------% c call ccopy(ldh*ncv, workl(ih), 1, workl(iuptri), 1) call claset('All', ncv, ncv , & zero , one, workl(invsub), & ldq) call clahqr(.true., .true. , ncv , & 1 , ncv , workl(iuptri), & ldh , workl(iheig) , 1 , & ncv , workl(invsub), ldq , & ierr) call ccopy(ncv , workl(invsub+ncv-1), ldq, & workl(ihbds), 1) c if (ierr .ne. 0) then info = -8 go to 9000 end if c if (msglvl .gt. 1) then call cvout (logfil, ncv, workl(iheig), ndigit, & '_neupd: Eigenvalues of H') call cvout (logfil, ncv, workl(ihbds), ndigit, & '_neupd: Last row of the Schur vector matrix') if (msglvl .gt. 3) then call cmout (logfil , ncv, ncv , & workl(iuptri), ldh, ndigit, & '_neupd: The upper triangular matrix ') end if end if c if (reord) then c c %-----------------------------------------------% c | Reorder the computed upper triangular matrix. | c %-----------------------------------------------% c call ctrsen('None' , 'V' , select , & ncv , workl(iuptri), ldh , & workl(invsub), ldq , workl(iheig), & nconv , conds , sep , & workev , ncv , ierr) c if (ierr .eq. 1) then info = 1 go to 9000 end if c if (msglvl .gt. 2) then call cvout (logfil, ncv, workl(iheig), ndigit, & '_neupd: Eigenvalues of H--reordered') if (msglvl .gt. 3) then call cmout(logfil , ncv, ncv , & workl(iuptri), ldq, ndigit, & '_neupd: Triangular matrix after re-ordering') end if end if c end if c c %---------------------------------------------% c | Copy the last row of the Schur basis matrix | c | to workl(ihbds). This vector will be used | c | to compute the Ritz estimates of converged | c | Ritz values. | c %---------------------------------------------% c call ccopy(ncv , workl(invsub+ncv-1), ldq, & workl(ihbds), 1) c c %--------------------------------------------% c | Place the computed eigenvalues of H into D | c | if a spectral transformation was not used. | c %--------------------------------------------% c if (type .eq. 'REGULR') then call ccopy(nconv, workl(iheig), 1, d, 1) end if c c %----------------------------------------------------------% c | Compute the QR factorization of the matrix representing | c | the wanted invariant subspace located in the first NCONV | c | columns of workl(invsub,ldq). | c %----------------------------------------------------------% c call cgeqr2(ncv , nconv , workl(invsub), & ldq , workev, workev(ncv+1), & ierr) c c %--------------------------------------------------------% c | * Postmultiply V by Q using cunm2r. | c | * Copy the first NCONV columns of VQ into Z. | c | * Postmultiply Z by R. | c | The N by NCONV matrix Z is now a matrix representation | c | of the approximate invariant subspace associated with | c | the Ritz values in workl(iheig). The first NCONV | c | columns of V are now approximate Schur vectors | c | associated with the upper triangular matrix of order | c | NCONV in workl(iuptri). | c %--------------------------------------------------------% c call cunm2r('Right', 'Notranspose', n , & ncv , nconv , workl(invsub), & ldq , workev , v , & ldv , workd(n+1) , ierr) call clacpy('All', n, nconv, v, ldv, z, ldz) c do 20 j=1, nconv c c %---------------------------------------------------% c | Perform both a column and row scaling if the | c | diagonal element of workl(invsub,ldq) is negative | c | I'm lazy and don't take advantage of the upper | c | triangular form of workl(iuptri,ldq). | c | Note that since Q is orthogonal, R is a diagonal | c | matrix consisting of plus or minus ones. | c %---------------------------------------------------% c if ( real( workl(invsub+(j-1)*ldq+j-1) ) .lt. & real(zero) ) then call cscal(nconv, -one, workl(iuptri+j-1), ldq) call cscal(nconv, -one, workl(iuptri+(j-1)*ldq), 1) end if c 20 continue c if (howmny .eq. 'A') then c c %--------------------------------------------% c | Compute the NCONV wanted eigenvectors of T | c | located in workl(iuptri,ldq). | c %--------------------------------------------% c do 30 j=1, ncv if (j .le. nconv) then select(j) = .true. else select(j) = .false. end if 30 continue c call ctrevc('Right', 'Select' , select , & ncv , workl(iuptri), ldq , & vl , 1 , workl(invsub), & ldq , ncv , outncv , & workev , rwork , ierr) c if (ierr .ne. 0) then info = -9 go to 9000 end if c c %------------------------------------------------% c | Scale the returning eigenvectors so that their | c | Euclidean norms are all one. LAPACK subroutine | c | ctrevc returns each eigenvector normalized so | c | that the element of largest magnitude has | c | magnitude 1. | c %------------------------------------------------% c do 40 j=1, nconv rtemp = scnrm2(ncv, workl(invsub+(j-1)*ldq), 1) rtemp = real(one) / rtemp call csscal ( ncv, rtemp, & workl(invsub+(j-1)*ldq), 1 ) c c %------------------------------------------% c | Ritz estimates can be obtained by taking | c | the inner product of the last row of the | c | Schur basis of H with eigenvectors of T. | c | Note that the eigenvector matrix of T is | c | upper triangular, thus the length of the | c | inner product can be set to j. | c %------------------------------------------% c workev(j) = cdotc(j, workl(ihbds), 1, & workl(invsub+(j-1)*ldq), 1) 40 continue c if (msglvl .gt. 2) then call ccopy(nconv, workl(invsub+ncv-1), ldq, & workl(ihbds), 1) call cvout (logfil, nconv, workl(ihbds), ndigit, & '_neupd: Last row of the eigenvector matrix for T') if (msglvl .gt. 3) then call cmout(logfil , ncv, ncv , & workl(invsub), ldq, ndigit, & '_neupd: The eigenvector matrix for T') end if end if c c %---------------------------------------% c | Copy Ritz estimates into workl(ihbds) | c %---------------------------------------% c call ccopy(nconv, workev, 1, workl(ihbds), 1) c c %----------------------------------------------% c | The eigenvector matrix Q of T is triangular. | c | Form Z*Q. | c %----------------------------------------------% c call ctrmm('Right' , 'Upper' , 'No transpose', & 'Non-unit', n , nconv , & one , workl(invsub), ldq , & z , ldz) end if c else c c %--------------------------------------------------% c | An approximate invariant subspace is not needed. | c | Place the Ritz values computed CNAUPD into D. | c %--------------------------------------------------% c call ccopy(nconv, workl(ritz), 1, d, 1) call ccopy(nconv, workl(ritz), 1, workl(iheig), 1) call ccopy(nconv, workl(bounds), 1, workl(ihbds), 1) c end if c c %------------------------------------------------% c | Transform the Ritz values and possibly vectors | c | and corresponding error bounds of OP to those | c | of A*x = lambda*B*x. | c %------------------------------------------------% c if (type .eq. 'REGULR') then c if (rvec) & call cscal(ncv, rnorm, workl(ihbds), 1) c else c c %---------------------------------------% c | A spectral transformation was used. | c | * Determine the Ritz estimates of the | c | Ritz values in the original system. | c %---------------------------------------% c if (rvec) & call cscal(ncv, rnorm, workl(ihbds), 1) c do 50 k=1, ncv temp = workl(iheig+k-1) workl(ihbds+k-1) = workl(ihbds+k-1) / temp / temp 50 continue c end if c c %-----------------------------------------------------------% c | * Transform the Ritz values back to the original system. | c | For TYPE = 'SHIFTI' the transformation is | c | lambda = 1/theta + sigma | c | NOTES: | c | *The Ritz vectors are not affected by the transformation. | c %-----------------------------------------------------------% c if (type .eq. 'SHIFTI') then do 60 k=1, nconv d(k) = one / workl(iheig+k-1) + sigma 60 continue end if c if (type .ne. 'REGULR' .and. msglvl .gt. 1) then call cvout (logfil, nconv, d, ndigit, & '_neupd: Untransformed Ritz values.') call cvout (logfil, nconv, workl(ihbds), ndigit, & '_neupd: Ritz estimates of the untransformed Ritz values.') else if ( msglvl .gt. 1) then call cvout (logfil, nconv, d, ndigit, & '_neupd: Converged Ritz values.') call cvout (logfil, nconv, workl(ihbds), ndigit, & '_neupd: Associated Ritz estimates.') end if c c %-------------------------------------------------% c | Eigenvector Purification step. Formally perform | c | one of inverse subspace iteration. Only used | c | for MODE = 3. See reference 3. | c %-------------------------------------------------% c if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then c c %------------------------------------------------% c | Purify the computed Ritz vectors by adding a | c | little bit of the residual vector: | c | T | c | resid(:)*( e s ) / theta | c | NCV | c | where H s = s theta. | c %------------------------------------------------% c do 100 j=1, nconv if (workl(iheig+j-1) .ne. zero) then workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / & workl(iheig+j-1) endif 100 continue c %---------------------------------------% c | Perform a rank one update to Z and | c | purify all the Ritz vectors together. | c %---------------------------------------% c call cgeru (n, nconv, one, resid, 1, workev, 1, z, ldz) c end if c 9000 continue c return c c %---------------% c | End of cneupd| c %---------------% c end